packages feed

ghc 8.10.7 → 9.14.1

raw patch · 1394 files changed

This diff is very large; some files are shown as “too large to diff”. Download the raw patch for the complete diff.

Files

+ Bytecodes.h view
@@ -0,0 +1,230 @@+/* -----------------------------------------------------------------------------+ *+ * (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_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_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++#define bci_TESTLT_I64                  71+#define bci_TESTEQ_I64                  72+#define bci_TESTLT_I32                  73+#define bci_TESTEQ_I32                  74+#define bci_TESTLT_I16                  75+#define bci_TESTEQ_I16                  76+#define bci_TESTLT_I8                   77+#define bci_TESTEQ_I8                   78+#define bci_TESTLT_W64                  79+#define bci_TESTEQ_W64                  80+#define bci_TESTLT_W32                  81+#define bci_TESTEQ_W32                  82+#define bci_TESTLT_W16                  83+#define bci_TESTEQ_W16                  84+#define bci_TESTLT_W8                   85+#define bci_TESTEQ_W8                   86++#define bci_PRIMCALL                    87++#define bci_BCO_NAME                    88++#define bci_OP_ADD_64                   90+#define bci_OP_SUB_64                   91+#define bci_OP_AND_64                   92+#define bci_OP_XOR_64                   93+#define bci_OP_NOT_64                   94+#define bci_OP_NEG_64                   95+#define bci_OP_MUL_64                   96+#define bci_OP_SHL_64                   97+#define bci_OP_ASR_64                   98+#define bci_OP_LSR_64                   99+#define bci_OP_OR_64                   100++#define bci_OP_NEQ_64                  110+#define bci_OP_EQ_64                   111+#define bci_OP_U_GE_64                 112+#define bci_OP_U_GT_64                 113+#define bci_OP_U_LT_64                 114+#define bci_OP_U_LE_64                 115+#define bci_OP_S_GE_64                 116+#define bci_OP_S_GT_64                 117+#define bci_OP_S_LT_64                 118+#define bci_OP_S_LE_64                 119+++#define bci_OP_ADD_32                  130+#define bci_OP_SUB_32                  131+#define bci_OP_AND_32                  132+#define bci_OP_XOR_32                  133+#define bci_OP_NOT_32                  134+#define bci_OP_NEG_32                  135+#define bci_OP_MUL_32                  136+#define bci_OP_SHL_32                  137+#define bci_OP_ASR_32                  138+#define bci_OP_LSR_32                  139+#define bci_OP_OR_32                   140++#define bci_OP_NEQ_32                  150+#define bci_OP_EQ_32                   151+#define bci_OP_U_GE_32                 152+#define bci_OP_U_GT_32                 153+#define bci_OP_U_LT_32                 154+#define bci_OP_U_LE_32                 155+#define bci_OP_S_GE_32                 156+#define bci_OP_S_GT_32                 157+#define bci_OP_S_LT_32                 158+#define bci_OP_S_LE_32                 159+++#define bci_OP_ADD_16                  170+#define bci_OP_SUB_16                  171+#define bci_OP_AND_16                  172+#define bci_OP_XOR_16                  173+#define bci_OP_NOT_16                  174+#define bci_OP_NEG_16                  175+#define bci_OP_MUL_16                  176+#define bci_OP_SHL_16                  177+#define bci_OP_ASR_16                  178+#define bci_OP_LSR_16                  179+#define bci_OP_OR_16                   180++#define bci_OP_NEQ_16                  190+#define bci_OP_EQ_16                   191+#define bci_OP_U_GE_16                 192+#define bci_OP_U_GT_16                 193+#define bci_OP_U_LT_16                 194+#define bci_OP_U_LE_16                 195+#define bci_OP_S_GE_16                 196+#define bci_OP_S_GT_16                 197+#define bci_OP_S_LT_16                 198+#define bci_OP_S_LE_16                 199+++#define bci_OP_ADD_08                  200+#define bci_OP_SUB_08                  201+#define bci_OP_AND_08                  202+#define bci_OP_XOR_08                  203+#define bci_OP_NOT_08                  204+#define bci_OP_NEG_08                  205+#define bci_OP_MUL_08                  206+#define bci_OP_SHL_08                  207+#define bci_OP_ASR_08                  208+#define bci_OP_LSR_08                  209+#define bci_OP_OR_08                   210++#define bci_OP_NEQ_08                  220+#define bci_OP_EQ_08                   221+#define bci_OP_U_GE_08                 222+#define bci_OP_U_GT_08                 223+#define bci_OP_U_LT_08                 224+#define bci_OP_U_LE_08                 225+#define bci_OP_S_GE_08                 226+#define bci_OP_S_GT_08                 227+#define bci_OP_S_LT_08                 228+#define bci_OP_S_LE_08                 229++#define bci_OP_INDEX_ADDR_08           240+#define bci_OP_INDEX_ADDR_16           241+#define bci_OP_INDEX_ADDR_32           242+#define bci_OP_INDEX_ADDR_64           243+++/* 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++/*-------------------------------------------------------------------------*/
+ ClosureTypes.h view
@@ -0,0 +1,93 @@+/* ----------------------------------------------------------------------------+ *+ * (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+ *   - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs+ */++/* 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 ANN_FRAME                     65+#define N_CLOSURE_TYPES               66
+ CodeGen.Platform.h view
@@ -0,0 +1,1329 @@++import GHC.Cmm.Expr+#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64))+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++# define q0 32+# define q1 33+# define q2 34+# define q3 35+# define q4 36+# define q5 37+# define q6 38+# define q7 39+# define q8 40+# define q9 41+# define q10 42+# define q11 43+# define q12 44+# define q13 45+# define q14 46+# define q15 47+# define q16 48+# define q17 49+# define q18 50+# define q19 51+# define q20 52+# define q21 53+# define q22 54+# define q23 55+# define q24 56+# define q25 57+# define q26 58+# define q27 59+# define q28 60+# define q29 61+# define q30 62+# define q31 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++#elif defined(MACHREGS_loongarch64)++# define zero 0+# define ra   1+# define tp   2+# define sp   3+# define a0   4+# define a1   5+# define a2   6+# define a3   7+# define a4   8+# define a5   9+# define a6  10+# define a7  11+# define t0  12+# define t1  13+# define t2  14+# define t3  15+# define t4  16+# define t5  17+# define t6  18+# define t7  19+# define t8  20+# define u0  21+# define fp  22+# define s0  23+# define s1  24+# define s2  25+# define s3  26+# define s4  27+# define s5  28+# define s6  29+# define s7  30+# define s8  31++# define fa0  32+# define fa1  33+# define fa2  34+# define fa3  35+# define fa4  36+# define fa5  37+# define fa6  38+# define fa7  39+# define ft0  40+# define ft1  41+# define ft2  42+# define ft3  43+# define ft4  44+# define ft5  45+# define ft6  46+# define ft7  47+# define ft8  48+# define ft9  49+# define ft10 50+# define ft11 51+# define ft12 52+# define ft13 53+# define ft14 54+# define ft15 55+# define fs0  56+# define fs1  57+# define fs2  58+# define fs3  59+# define fs4  60+# define fs5  61+# define fs6  62+# define fs7  63++#endif++-- See also Note [Caller saves and callee-saves regs.]+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+#endif+#if defined(REG_R2)+    ,VanillaReg 2+#endif+#if defined(REG_R3)+    ,VanillaReg 3+#endif+#if defined(REG_R4)+    ,VanillaReg 4+#endif+#if defined(REG_R5)+    ,VanillaReg 5+#endif+#if defined(REG_R6)+    ,VanillaReg 6+#endif+#if defined(REG_R7)+    ,VanillaReg 7+#endif+#if defined(REG_R8)+    ,VanillaReg 8+#endif+#if defined(REG_R9)+    ,VanillaReg 9+#endif+#if defined(REG_R10)+    ,VanillaReg 10+#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) \+    || defined(MACHREGS_loongarch64)++# 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++-- Note [Aarch64 Register x18 at Darwin and Windows]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 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+-- It is a reserved at Windows as well. Acts like TEB register in user mode at Windows.+-- https://learn.microsoft.com/en-us/cpp/build/arm64-windows-abi-conventions+#if defined(darwin_HOST_OS) || defined(ios_HOST_OS) || defined(mingw32_HOST_OS)+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++#elif defined(MACHREGS_riscv64)++-- zero reg+freeReg 0 = False+-- link register+freeReg 1 = False+-- stack pointer+freeReg 2 = False+-- global pointer+freeReg 3 = False+-- thread pointer+freeReg 4 = False+-- frame pointer+freeReg 8 = False+-- made-up inter-procedural (ip) register+-- See Note [The made-up RISCV64 TMP (IP) register]+freeReg 31 = False++# 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++#elif defined(MACHREGS_loongarch64)++-- zero register+freeReg 0 = False+-- linker regster+freeReg 1 = False+-- thread register+freeReg 2 = False+-- stack pointer+freeReg 3 = False+-- made-up inter-procedural (ip) register for spilling offset computations+freeReg 20 = False+-- reserved+freeReg 21 = False+-- frame pointer+freeReg 22 = False++# 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
− Config.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-module Config-  ( module GHC.Version-  , cBuildPlatformString-  , cHostPlatformString-  , cProjectName-  , cBooterVersion-  , cStage-  ) where--import GhcPrelude--import GHC.Version--cBuildPlatformString :: String-cBuildPlatformString = "x86_64-unknown-linux"--cHostPlatformString :: String-cHostPlatformString = "x86_64-unknown-linux"--cProjectName          :: String-cProjectName          = "The Glorious Glasgow Haskell Compilation System"--cBooterVersion        :: String-cBooterVersion        = "8.10.7"--cStage                :: String-cStage                = show (2 :: Int)
+ FunTypes.h view
@@ -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+ *       - 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
+ GHC.hs view
@@ -0,0 +1,2100 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE TupleSections, NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}++-- -----------------------------------------------------------------------------+--+-- (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,+        setProgramHUG, setProgramHUG_,+        getInteractiveDynFlags, setInteractiveDynFlags,+        normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,+        interpretPackageEnv,++        -- * Logging+        Logger, getLogger,+        pushLogHook, popLogHook,+        pushLogHookM, popLogHookM, modifyLogger,+        putMsgM, putLogMsgM,+++        -- * Targets+        Target(..), TargetId(..), Phase,+        setTargets,+        getTargets,+        addTarget,+        removeTarget,+        guessTarget,+        guessTargetId,++        -- * 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(..),+        pattern ModLocation,+        getModSummary,+        getModuleGraph,+        isLoaded,+        isLoadedModule,+        isLoadedHomeModule,+        topSortModuleGraph,++        -- * Inspecting modules+        ModuleInfo,+        getModuleInfo,+        modInfoTyThings,+        modInfoExports,+        modInfoExportsWithSelectors,+        modInfoInstances,+        modInfoIsExportedName,+        modInfoLookupName,+        modInfoIface,+        modInfoSafe,+        lookupGlobalName,+        findGlobalAnns,+        mkNamePprCtxForModule,+        ModIface,+        ModIface_( mi_mod_info+                 , mi_module+                 , mi_sig_of+                 , mi_hsc_src+                 , mi_iface_hash+                 , mi_deps+                 , mi_public+                 , mi_exports+                 , mi_fixities+                 , mi_warns+                 , mi_anns+                 , mi_decls+                 , mi_defaults+                 , mi_simplified_core+                 , mi_top_env+                 , mi_insts+                 , mi_fam_insts+                 , mi_rules+                 , mi_trust+                 , mi_trust_pkg+                 , mi_complete_matches+                 , mi_docs+                 , mi_abi_hashes+                 , mi_ext_fields+                 , mi_hi_bytes+                 , mi_self_recomp_info+                 , mi_fix_fn+                 , mi_decl_warn_fn+                 , mi_export_warn_fn+                 , mi_hash_fn+                 ),+        pattern 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,+        lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,+        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(historyBreakpointId, historyEnclosingDecls),+        GHC.getHistorySpan, getHistoryModule,+        abandon, abandonAll,+        getResumeContext,+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,+        modInfoModBreaks,+        ModBreaks(..), BreakTickIndex,+        BreakpointId(..), InternalBreakpointId(..),+        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+        EpaComment(..)+  ) 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.Session.Inspect+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.StgToJS (initStgToJSConfig)+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.Env ( trace_if )+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.Exception+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.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst )+import GHC.Core.InstEnv+import GHC.Core++import GHC.Data.Maybe++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.TypeEnv+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env as UnitEnv+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 qualified GHC.Unit.Home.Graph as HUG+import GHC.Settings++import Control.Applicative ((<|>))+import Control.Concurrent+import Control.Monad+import Control.Monad.Catch as MC+import Data.Foldable+import Data.Function ((&))+import Data.IORef+import Data.List (isPrefixOf)+import Data.Typeable    ( Typeable )+import Data.Word        ( Word8 )++import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as S+import qualified Data.Sequence as Seq++import System.Directory+import System.Environment ( getEnv, getProgName )+import System.Exit      ( exitWith, ExitCode(..) )+import System.FilePath+import System.IO.Error  ( isDoesNotExistError )+++-- %************************************************************************+-- %*                                                                      *+--             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"+                     Just HeapOverflow ->+                         fm "heap overflow: use +RTS -M<size> to increase maximum heap size"+                     _ -> 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 ( do+#if !defined(javascript_HOST_ARCH)+    -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.+    -- So we can't use assertM here.+    -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.+    !keep_cafs <- c_keepCAFsForGHCi+    massert keep_cafs+#endif+    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 = UnitEnv.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+            UnitEnv.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+  lookup_cache  <- liftIO $ mkInterpSymbolCache++  -- see Note [Target code interpreter]+  interp <- if+    -- Wasm dynamic linker+    | ArchWasm32 <- platformArch $ targetPlatform dflags+    -> do+        s <- liftIO $ newMVar InterpPending+        loader <- liftIO Loader.uninitializedLoader+        dyld <- liftIO $ makeAbsolute $ topDir dflags </> "dyld.mjs"+#if defined(wasm32_HOST_ARCH)+        let libdir = sorry "cannot spawn child process on wasm"+#else+        libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries"+#endif+        let profiled = ways dflags `hasWay` WayProf+            way_tag = if profiled then "_p" else ""+        let cfg =+              WasmInterpConfig+                { wasmInterpDyLD = dyld,+                  wasmInterpLibDir = libdir,+                  wasmInterpOpts = getOpts dflags opt_i,+                  wasmInterpBrowser = gopt Opt_GhciBrowser dflags,+                  wasmInterpBrowserHost = ghciBrowserHost dflags,+                  wasmInterpBrowserPort = ghciBrowserPort dflags,+                  wasmInterpBrowserRedirectWasiConsole = gopt Opt_GhciBrowserRedirectWasiConsole dflags,+                  wasmInterpBrowserPuppeteerLaunchOpts = ghciBrowserPuppeteerLaunchOpts dflags,+                  wasmInterpBrowserPlaywrightBrowserType = ghciBrowserPlaywrightBrowserType dflags,+                  wasmInterpBrowserPlaywrightLaunchOpts = ghciBrowserPlaywrightLaunchOpts dflags,+                  wasmInterpTargetPlatform = targetPlatform dflags,+                  wasmInterpProfiled = profiled,+                  wasmInterpHsSoSuffix = way_tag ++ dynLibSuffix (ghcNameVersion dflags),+                  wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env+                }+        pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache++    -- JavaScript interpreter+    | ArchJavaScript <- platformArch (targetPlatform dflags)+    -> do+         s <- liftIO $ newMVar InterpPending+         loader <- liftIO Loader.uninitializedLoader+         let cfg = JSInterpConfig+              { jsInterpNodeConfig  = defaultNodeJsSettings+              , jsInterpScript      = topDir dflags </> "ghc-interp.js"+              , jsInterpTmpFs       = hsc_tmpfs hsc_env+              , jsInterpTmpDir      = tmpDir dflags+              , jsInterpLogger      = hsc_logger hsc_env+              , jsInterpCodegenCfg  = initStgToJSConfig dflags+              , jsInterpUnitEnv     = hsc_unit_env hsc_env+              , jsInterpFinderOpts  = initFinderOpts dflags+              , jsInterpFinderCache = hsc_FC hsc_env+              }+         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))++    -- external interpreter+    | gopt Opt_ExternalInterpreter dflags+    -> do+         let+           prog = pgm_i dflags ++ flavour+           profiled = ways dflags `hasWay` WayProf+           dynamic  = ways dflags `hasWay` WayDyn+           flavour+             | profiled && dynamic = "-prof-dyn"+             | profiled  = "-prof"+             | 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 InterpPending+         loader <- liftIO Loader.uninitializedLoader+         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache))++    -- Internal interpreter+    | otherwise+    ->+#if defined(HAVE_INTERNAL_INTERPRETER)+     do+      loader <- liftIO Loader.uninitializedLoader+      return (Just (Interp InternalInterp loader lookup_cache))+#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 = HUG.allUnits (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 $ HUG.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_module_graph    = ue_module_graph 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++-- | Sets the program 'HomeUnitGraph'.+--+-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current+-- session. If the package flags change, we reinitialise the 'UnitState'+-- of all 'HomeUnitEnv's in the current session.+--+-- This function unconditionally invalidates the module graph cache.+--+-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph'+-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called+-- 'new_hug', then:+--+-- @+--  do+--    hug <- hsc_HUG \<$\> getSession+--    pure $ unitEnv_keys new_hug == unitEnv_keys hug+-- @+--+-- If this precondition is violated, the function will crash.+--+-- Conceptually, similar to 'setProgramDynFlags', but performs the same check+-- for all 'HomeUnitEnv's.+setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool+setProgramHUG =+  setProgramHUG_ True++-- | Same as 'setProgramHUG', but gives you control over whether you want to+-- invalidate the module graph cache.+setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool+setProgramHUG_ invalidate_needed new_hug0 = do+  logger <- getLogger++  hug0 <- hsc_HUG <$> getSession+  (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0++  if changed+    then do+      unit_env0 <- hsc_unit_env <$> getSession+      home_unit_graph <- HUG.unitEnv_traverseWithKey+        (updateHomeUnit logger unit_env0 new_hug1)+        (ue_home_unit_graph unit_env0)++      let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) 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 unit_env0+            , ue_eps             = ue_eps unit_env0+            , ue_module_graph    = ue_module_graph unit_env0+            }+      modifySession $ \h ->+        -- hscSetFlags takes care of updating the logger as well.+        hscSetFlags dflags1 h{ hsc_unit_env = unit_env }+    else do+      modifySession (\env ->+        env+          -- Set the new 'HomeUnitGraph'.+          & hscUpdateHUG (const new_hug1)+          -- hscSetActiveUnitId makes sure that the 'hsc_dflags'+          -- are up-to-date.+          & hscSetActiveUnitId (hscActiveUnitId env)+          -- Make sure the logger is also updated.+          & hscUpdateLoggerFlags)++  when invalidate_needed $ invalidateModSummaryCache+  pure changed+  where+    checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph)+    checkNewHugDynFlags logger old_hug new_hug = do+      -- Traverse the new HUG and check its 'DynFlags'.+      -- The old 'HUG' is used to check whether package flags have changed.+      hugWithCheck <- HUG.unitEnv_traverseWithKey+        (\unitId homeUnit -> do+          let newFlags = homeUnitEnv_dflags homeUnit+              oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug)+          checkedFlags <- checkNewDynFlags logger newFlags+          pure+            ( packageFlagsChanged oldFlags checkedFlags+            , homeUnit { homeUnitEnv_dflags = checkedFlags }+            )+        )+        new_hug+      let+        -- Did any of the package flags change?+        changed = or $ fmap fst hugWithCheck+        hug = fmap snd hugWithCheck+      pure (changed, hug)++    updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv)+    updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do+      let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+          dflags = case HUG.unitEnv_lookup_maybe uid updates of+            Nothing -> homeUnitEnv_dflags homeUnitEnv+            Just env -> homeUnitEnv_dflags env+          old_hpt = homeUnitEnv_hpt homeUnitEnv+          home_units = HUG.allUnits (ue_home_unit_graph unit_env)++      (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units++      updated_dflags <- liftIO $ updatePlatformConstants dflags 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+        }++-- 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 $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env+ 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+  icdflags <- normaliseInteractiveDynFlags logger dflags+  modifySessionM (initialiseInteractiveDynFlags icdflags)++-- | 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], Messages DriverMessage)+parseDynamicFlags logger dflags cmdline = do+  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine logger 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++-----------------------------------------------------------------------------++-- | Normalise the 'DynFlags' for us in an interactive context.+--+-- Makes sure unsupported Flags and other incosistencies are reported and removed.+normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+normaliseInteractiveDynFlags logger dflags = do+  dflags' <- checkNewDynFlags logger dflags+  checkNewInteractiveDynFlags logger dflags'++-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags')+-- for the interactive context, initialize the 'InteractiveContext'.+--+-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the+-- 'InteractiveContext'.+initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv+initialiseInteractiveDynFlags dflags 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+                  }+              }++-- | 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, infoverb) = makeDynFlagsConsistent dflags+  let diag_opts = initDiagOpts dflags+      print_config = initPrintConfig dflags+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts+    $ fmap GhcDriverMessage $ warnsToMessages diag_opts warnings+  when (logVerbAtLeast logger 3) $+    mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb+  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+--+--   - If it looks like a module name, interpret it as such+--+--   - otherwise, this function throws a 'GhcException'.+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 = do+  targetId <- guessTargetId str+  toTarget targetId+     where+         obj_allowed+                | '*':_ <- str = False+                | otherwise    = True+         toTarget tid = do+           tuid <- unitIdOrHomeUnit mUnitId+           pure $ Target tid obj_allowed tuid Nothing++-- | Attempts to guess what 'TargetId' 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+--+--   - If it looks like a module name, interpret it as such+--+--   - otherwise, this function throws a 'GhcException'.+guessTargetId :: GhcMonad m => String -> m TargetId+guessTargetId str+   | isHaskellSrcFilename file+   = pure (TargetFile file Nothing)+   | otherwise+   = do exists <- liftIO $ doesFileExist hs_file+        if exists+           then pure (TargetFile hs_file Nothing)+           else do+        exists <- liftIO $ doesFileExist lhs_file+        if exists+           then pure (TargetFile lhs_file Nothing)+           else do+        if looksLikeModuleName file+           then pure (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+          | '*':rest <- str = rest+          | otherwise       = str++        hs_file  = file <.> "hs"+        lhs_file = file <.> "lhs"++-- | 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), Maybe (XRec GhcRn ModuleName))+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 => Module -> m ModSummary+getModSummary mod = do+   mg <- liftM hsc_mod_graph getSession+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod 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 $+          hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) 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_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,+           minf_iface     = Nothing,+           minf_safe      = safe,+           minf_modBreaks = Nothing+         }}++-- | 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+         }++isDictonaryId :: Id -> Bool+isDictonaryId id = isDictTy (idType id)++-- | 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+  liftIO $ trace_if (hsc_logger hsc_env) (text "findQualifiedModule" <+> ppr mod_name <+> ppr pkgqual)+  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 (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 -> liftIO $ do+  trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModule" <+> ppr mod_name <+> ppr uid)+  HUG.lookupHug (hsc_HUG hsc_env) uid mod_name >>= \case+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))+    _not_a_home_module -> return Nothing++-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'.+--+-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'.+-- Otherwise, returns all 'Module's that have the given 'ModuleName'.+--+-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since+-- there can be multiple units exposing the same 'ModuleName' in the case of+-- multiple home units.+-- Thus, this function may return more than one possible 'Module'.+-- We leave it up to the caller to decide how to handle the ambiguity.+-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one.+--+lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module])+lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do+  trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name)+  HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case+    []        -> return Nothing+    mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos))++-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria.+--+-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one+-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'.+--+-- The result is guaranteed to be non-empty, if no 'Module' can be found,+-- this function throws an error.+lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module]+lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do+  home <- lookupLoadedHomeModuleByModuleName 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+lookupAllQualifiedModuleNames pkgqual mod_name = do+  m <- findQualifiedModule pkgqual mod_name+  pure [m]++-- | 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 -> liftIO $ GHC.Runtime.Eval.getHistorySpan (hsc_HUG 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 -- ^ How many times to recurse for subterms+                 -> Bool -- ^ Whether to force the expression+                 -> 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)+++#if !defined(javascript_HOST_ARCH)+foreign import ccall unsafe "keepCAFsForGHCi"+    c_keepCAFsForGHCi   :: IO Bool+#endif
+ GHC/Builtin/Names.hs view
@@ -0,0 +1,2777 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[GHC.Builtin.Names]{Definitions of prelude modules and names}+++Nota Bene: all Names defined in here should come from the base package,+the big-num package or (for plugins) the ghc package.++ - ModuleNames for prelude modules,+        e.g.    pRELUDE_NAME :: ModuleName++ - Modules for prelude modules+        e.g.    pRELUDE :: Module++ - Uniques for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConKey :: Unique+                minusClassOpKey :: Unique++ - Names for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConName :: Name+                minusName    :: Name+   One of these Names contains+        (a) the module and occurrence name of the thing+        (b) its Unique+   The way the compiler "knows about" one of these things is+   where the type checker or desugarer needs to look it up. For+   example, when desugaring list comprehensions the desugarer+   needs to conjure up 'foldr'.  It does this by looking up+   foldrName in the environment.++ - RdrNames for Ids, DataCons etc that the compiler may emit into+   generated code (e.g. for deriving).+        e.g.    and_RDR :: RdrName+   It's not necessary to know the uniques for these guys, only their names+++Note [Known-key names]+~~~~~~~~~~~~~~~~~~~~~~+It is *very* important that the compiler gives wired-in things and+things with "known-key" names the correct Uniques wherever they+occur. We have to be careful about this in exactly two places:++  1. When we parse some source code, renaming the AST better yield an+     AST whose Names have the correct uniques++  2. When we read an interface file, the read-in gubbins better have+     the right uniques++This is accomplished through a combination of mechanisms:++  1. When parsing source code, the RdrName-decorated AST has some+     RdrNames which are Exact. These are wired-in RdrNames where+     we could directly tell from the parsed syntax what Name to+     use. For example, when we parse a [] in a type and ListTuplePuns+     are enabled, we can just insert (Exact listTyConName :: RdrName).++     This is just an optimisation: it would be equally valid to output+     Orig RdrNames that correctly record the module (and package) that+     we expect the final Name to come from. The name would be looked up+     in the OrigNameCache (see point 3).++  2. The knownKeyNames (which consist of the basicKnownKeyNames from+     the module, and those names reachable via the wired-in stuff from+     GHC.Builtin.Types) are used to initialise the "OrigNameCache" in+     GHC.Iface.Env.  This initialization ensures that when the type checker+     or renamer (both of which use GHC.Iface.Env) look up an original name+     (i.e. a pair of a Module and an OccName) for a known-key name+     they get the correct Unique.++     This is the most important mechanism for ensuring that known-key+     stuff gets the right Unique, and is why it is so important to+     place your known-key names in the appropriate lists.++  3. For "infinite families" of known-key names (i.e. tuples and sums), we+     have to be extra careful. Because there are an infinite number of+     these things, we cannot add them to the list of known-key names+     used to initialise the OrigNameCache. Instead, lookupOrigNameCache pretends+     that these names are in the cache by using isInfiniteFamilyOrigName_maybe+     before the actual lookup.+     See Note [Infinite families of known-key names] for details.+++Note [Infinite families of known-key names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Infinite families of known-key things (e.g. tuples and sums) pose a tricky+problem: we can't add them to the knownKeyNames finite map which we use to+ensure that, e.g., a reference to (,) gets assigned the right unique (if this+doesn't sound familiar see Note [Known-key names] above).++We instead handle tuples and sums separately from the "vanilla" known-key+things,++  a) The parser recognises them specially and generates an Exact Name (hence not+     looked up in the orig-name cache)++  b) The known infinite families of names are specially serialised by+     GHC.Iface.Binary.putName, with that special treatment detected when we read+     back to ensure that we get back to the correct uniques.+     See Note [Symbol table representation of names] in GHC.Iface.Binary and+     Note [How tuples work] in GHC.Builtin.Types.++  c) GHC.Iface.Env.lookupOrigNameCache uses isInfiniteFamilyOrigName_maybe to+     map tuples and sums onto their exact names, rather than trying to find them+     in the original-name cache.+     See also Note [Built-in syntax and the OrigNameCache]++-}++{-# LANGUAGE CPP #-}++module GHC.Builtin.Names+   ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience++   -----------------------------------------------------------+   module GHC.Builtin.Names, -- A huge bunch of (a) Names,  e.g. intTyConName+                             --                 (b) Uniques e.g. intTyConKey+                             --                 (c) Groups of classes and types+                             --                 (d) miscellaneous things+                             -- So many that we export them all+   )+where++import GHC.Prelude++import GHC.Unit.Types+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.Unique+import GHC.Builtin.Uniques+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Data.FastString+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import Language.Haskell.Syntax.Module.Name++{-+************************************************************************+*                                                                      *+     allNameStrings+*                                                                      *+************************************************************************+-}++allNameStrings :: Infinite String+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStrings = Inf.allListsOf ['a'..'z']++allNameStringList :: [String]+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStringList = Inf.toList allNameStrings++{-+************************************************************************+*                                                                      *+\subsection{Local Names}+*                                                                      *+************************************************************************++This *local* name is used by the interactive stuff+-}++itName :: Unique -> SrcSpan -> Name+itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc++-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly+-- during compiler debugging.+mkUnboundName :: OccName -> Name+mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan++isUnboundName :: Name -> Bool+isUnboundName name = name `hasKey` unboundKey++{-+************************************************************************+*                                                                      *+\subsection{Known key Names}+*                                                                      *+************************************************************************++This section tells what the compiler knows about the association of+names with uniques.  These ones are the *non* wired-in ones.  The+wired in ones are defined in GHC.Builtin.Types etc.+-}++basicKnownKeyNames :: [Name]  -- See Note [Known-key names]+basicKnownKeyNames+ = genericTyConNames+ ++ [   --  Classes.  *Must* include:+        --      classes that are grabbed by key (e.g., eqClassKey)+        --      classes in "Class.standardClassKeys" (quite a few)+        eqClassName,                    -- mentioned, derivable+        ordClassName,                   -- derivable+        boundedClassName,               -- derivable+        numClassName,                   -- mentioned, numeric+        enumClassName,                  -- derivable+        monadClassName,+        functorClassName,+        realClassName,                  -- numeric+        integralClassName,              -- numeric+        fractionalClassName,            -- numeric+        floatingClassName,              -- numeric+        realFracClassName,              -- numeric+        realFloatClassName,             -- numeric+        dataClassName,+        isStringClassName,+        applicativeClassName,+        alternativeClassName,+        foldableClassName,+        traversableClassName,+        semigroupClassName, sappendName,+        monoidClassName, memptyName, mappendName, mconcatName,++        -- The IO type+        ioTyConName, ioDataConName,+        runMainIOName,+        runRWName,++        -- Type representation types+        trModuleTyConName, trModuleDataConName,+        trNameTyConName, trNameSDataConName, trNameDDataConName,+        trTyConTyConName, trTyConDataConName,++        -- Typeable+        typeableClassName,+        typeRepTyConName,+        someTypeRepTyConName,+        someTypeRepDataConName,+        kindRepTyConName,+        kindRepTyConAppDataConName,+        kindRepVarDataConName,+        kindRepAppDataConName,+        kindRepFunDataConName,+        kindRepTYPEDataConName,+        kindRepTypeLitSDataConName,+        kindRepTypeLitDDataConName,+        typeLitSortTyConName,+        typeLitSymbolDataConName,+        typeLitNatDataConName,+        typeLitCharDataConName,+        typeRepIdName,+        mkTrTypeName,+        mkTrConName,+        mkTrAppCheckedName,+        mkTrFunName,+        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,+        trGhcPrimModuleName,++        -- KindReps for common cases+        starKindRepName,+        starArrStarKindRepName,+        starArrStarArrStarKindRepName,+        constraintKindRepName,++        -- WithDict+        withDictClassName,++        -- DataToTag+        dataToTagClassName,++        -- seq#+        seqHashName,++        -- Dynamic+        toDynName,++        -- Numeric stuff+        negateName, minusName, geName, eqName,+        mkRationalBase2Name, mkRationalBase10Name,++        -- Conversion functions+        rationalTyConName,+        ratioTyConName, ratioDataConName,+        fromRationalName, fromIntegerName,+        toIntegerName, toRationalName,+        fromIntegralName, realToFracName,++        -- Int# stuff+        divIntName, modIntName,++        -- String stuff+        fromStringName,++        -- Enum stuff+        enumFromName, enumFromThenName,+        enumFromThenToName, enumFromToName,++        -- Applicative stuff+        pureAName, apAName, thenAName,++        -- Functor stuff+        fmapName,++        -- Monad stuff+        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,+        returnMName, joinMName,++        -- MonadFail+        monadFailClassName, failMName,++        -- MonadFix+        monadFixClassName, mfixName,++        -- Arrow stuff+        arrAName, composeAName, firstAName,+        appAName, choiceAName, loopAName,++        -- Ix stuff+        ixClassName,++        -- Show stuff+        showClassName,++        -- Read stuff+        readClassName,++        -- Stable pointers+        newStablePtrName,++        -- GHC Extensions+        considerAccessibleName,++        -- Strings and lists+        unpackCStringName, unpackCStringUtf8Name,+        unpackCStringAppendName, unpackCStringAppendUtf8Name,+        unpackCStringFoldrName, unpackCStringFoldrUtf8Name,+        cstringLengthName,++        -- Overloaded lists+        isListClassName,+        fromListName,+        fromListNName,+        toListName,++        -- Non-empty lists+        nonEmptyTyConName,++        -- Overloaded record dot, record update+        getFieldName, setFieldName,++        -- List operations+        concatName, filterName, mapName,+        zipName, foldrName, buildName, augmentName, appendName,++        -- FFI primitive types that are not wired-in.+        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,+        int8TyConName, int16TyConName, int32TyConName, int64TyConName,+        word8TyConName, word16TyConName, word32TyConName, word64TyConName,+        jsvalTyConName,++        -- Others+        otherwiseIdName, inlineIdName,+        eqStringName, assertName,+        assertErrorName, traceName,+        printName,+        dollarName,++        -- ghc-bignum+        integerFromNaturalName,+        integerToNaturalClampName,+        integerToNaturalThrowName,+        integerToNaturalName,+        integerToWordName,+        integerToIntName,+        integerToWord64Name,+        integerToInt64Name,+        integerFromWordName,+        integerFromWord64Name,+        integerFromInt64Name,+        integerAddName,+        integerMulName,+        integerSubName,+        integerNegateName,+        integerAbsName,+        integerPopCountName,+        integerQuotName,+        integerRemName,+        integerDivName,+        integerModName,+        integerDivModName,+        integerQuotRemName,+        integerEncodeFloatName,+        integerEncodeDoubleName,+        integerGcdName,+        integerLcmName,+        integerAndName,+        integerOrName,+        integerXorName,+        integerComplementName,+        integerBitName,+        integerTestBitName,+        integerShiftLName,+        integerShiftRName,++        naturalToWordName,+        naturalPopCountName,+        naturalShiftRName,+        naturalShiftLName,+        naturalAddName,+        naturalSubName,+        naturalSubThrowName,+        naturalSubUnsafeName,+        naturalMulName,+        naturalQuotRemName,+        naturalQuotName,+        naturalRemName,+        naturalAndName,+        naturalAndNotName,+        naturalOrName,+        naturalXorName,+        naturalTestBitName,+        naturalBitName,+        naturalGcdName,+        naturalLcmName,+        naturalLog2Name,+        naturalLogBaseWordName,+        naturalLogBaseName,+        naturalPowModName,+        naturalSizeInBaseName,++        bignatEqName,++        -- Float/Double+        integerToFloatName,+        integerToDoubleName,+        naturalToFloatName,+        naturalToDoubleName,+        rationalToFloatName,+        rationalToDoubleName,++        -- Other classes+        monadPlusClassName,++        -- Type-level naturals+        knownNatClassName, knownSymbolClassName, knownCharClassName,++        -- Overloaded labels+        fromLabelClassOpName,++        -- Implicit Parameters+        ipClassName,++        -- Overloaded record fields+        hasFieldClassName,++        -- ExceptionContext+        exceptionContextTyConName,+        emptyExceptionContextName,++        -- Call Stacks+        callStackTyConName,+        emptyCallStackName, pushCallStackName,++        -- Source Locations+        srcLocDataConName,++        -- Annotation type checking+        toAnnotationWrapperName++        -- The SPEC type for SpecConstr+        , specTyConName++        -- The Either type+        , eitherTyConName, leftDataConName, rightDataConName++        -- The Void type+        , voidTyConName++        -- Plugins+        , pluginTyConName+        , frontendPluginTyConName++        -- Generics+        , genClassName, gen1ClassName+        , datatypeClassName, constructorClassName, selectorClassName++        -- Monad comprehensions+        , guardMName+        , liftMName+        , mzipName++        -- GHCi Sandbox+        , ghciIoClassName, ghciStepIoMName++        -- StaticPtr+        , makeStaticName+        , staticPtrTyConName+        , staticPtrDataConName, staticPtrInfoDataConName+        , fromStaticPtrName++        -- Fingerprint+        , fingerprintDataConName++        -- Custom type errors+        , errorMessageTypeErrorFamName+        , typeErrorTextDataConName+        , typeErrorAppendDataConName+        , typeErrorVAppendDataConName+        , typeErrorShowTypeDataConName++        -- "Unsatisfiable" constraint+        , unsatisfiableClassName+        , unsatisfiableIdName++        -- Unsafe coercion proofs+        , unsafeEqualityProofName+        , unsafeEqualityTyConName+        , unsafeReflDataConName+        , unsafeCoercePrimName++        , unsafeUnpackJSStringUtf8ShShName+    ]++genericTyConNames :: [Name]+genericTyConNames = [+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,+    compTyConName, rTyConName, dTyConName,+    cTyConName, sTyConName, rec0TyConName,+    d1TyConName, c1TyConName, s1TyConName,+    repTyConName, rep1TyConName, uRecTyConName,+    uAddrTyConName, uCharTyConName, uDoubleTyConName,+    uFloatTyConName, uIntTyConName, uWordTyConName,+    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+    rightAssociativeDataConName, notAssociativeDataConName,+    sourceUnpackDataConName, sourceNoUnpackDataConName,+    noSourceUnpackednessDataConName, sourceLazyDataConName,+    sourceStrictDataConName, noSourceStrictnessDataConName,+    decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+    metaDataDataConName, metaConsDataConName, metaSelDataConName+  ]++{-+************************************************************************+*                                                                      *+\subsection{Module names}+*                                                                      *+************************************************************************+++--MetaHaskell Extension Add a new module here+-}++gHC_PRIM, gHC_PRIM_PANIC,+    gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT,+    gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module+gHC_PRIM           = mkGhcInternalModule (fsLit "GHC.Internal.Prim")   -- Primitive types and values+gHC_PRIM_PANIC     = mkGhcInternalModule (fsLit "GHC.Internal.Prim.Panic")+gHC_TYPES          = mkGhcInternalModule (fsLit "GHC.Internal.Types")+gHC_MAGIC          = mkGhcInternalModule (fsLit "GHC.Internal.Magic")+gHC_MAGIC_DICT     = mkGhcInternalModule (fsLit "GHC.Internal.Magic.Dict")+gHC_CSTRING        = mkGhcInternalModule (fsLit "GHC.Internal.CString")+gHC_CLASSES        = mkGhcInternalModule (fsLit "GHC.Internal.Classes")+gHC_PRIMOPWRAPPERS = mkGhcInternalModule (fsLit "GHC.Internal.PrimopWrappers")+gHC_INTERNAL_TUPLE = mkGhcInternalModule (fsLit "GHC.Internal.Tuple")++gHC_INTERNAL_CONTROL_MONAD_ZIP :: Module+gHC_INTERNAL_CONTROL_MONAD_ZIP  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Zip")++gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module+gHC_INTERNAL_NUM_INTEGER            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Integer")+gHC_INTERNAL_NUM_NATURAL            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Natural")+gHC_INTERNAL_NUM_BIGNAT             = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.BigNat")++gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,+    gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING,+    gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE,+    gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER,+    gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE,+    gHC_INTERNAL_EXCEPTION_CONTEXT,+    gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception,+    gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL,+    gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC,+    gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS,+    gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX,  gHC_INTERNAL_MONAD_FAIL,+    gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST,+    gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL,+    gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL,+    gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR,+    gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module+gHC_INTERNAL_BASE                   = mkGhcInternalModule (fsLit "GHC.Internal.Base")+gHC_INTERNAL_ENUM                   = mkGhcInternalModule (fsLit "GHC.Internal.Enum")+gHC_INTERNAL_GHCI                   = mkGhcInternalModule (fsLit "GHC.Internal.GHCi")+gHC_INTERNAL_GHCI_HELPERS           = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers")+gHC_INTERNAL_SHOW                   = mkGhcInternalModule (fsLit "GHC.Internal.Show")+gHC_INTERNAL_READ                   = mkGhcInternalModule (fsLit "GHC.Internal.Read")+gHC_INTERNAL_NUM                    = mkGhcInternalModule (fsLit "GHC.Internal.Num")+gHC_INTERNAL_MAYBE                  = mkGhcInternalModule (fsLit "GHC.Internal.Maybe")+gHC_INTERNAL_LIST                   = mkGhcInternalModule (fsLit "GHC.Internal.List")+gHC_INTERNAL_DATA_EITHER            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either")+gHC_INTERNAL_DATA_STRING            = mkGhcInternalModule (fsLit "GHC.Internal.Data.String")+gHC_INTERNAL_DATA_FOLDABLE          = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable")+gHC_INTERNAL_DATA_TRAVERSABLE       = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable")+gHC_INTERNAL_CONC                   = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc")+gHC_INTERNAL_IO                     = mkGhcInternalModule (fsLit "GHC.Internal.IO")+gHC_INTERNAL_IO_Exception           = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception")+gHC_INTERNAL_ST                     = mkGhcInternalModule (fsLit "GHC.Internal.ST")+gHC_INTERNAL_IX                     = mkGhcInternalModule (fsLit "GHC.Internal.Ix")+gHC_INTERNAL_STABLE                 = mkGhcInternalModule (fsLit "GHC.Internal.Stable")+gHC_INTERNAL_PTR                    = mkGhcInternalModule (fsLit "GHC.Internal.Ptr")+gHC_INTERNAL_ERR                    = mkGhcInternalModule (fsLit "GHC.Internal.Err")+gHC_INTERNAL_REAL                   = mkGhcInternalModule (fsLit "GHC.Internal.Real")+gHC_INTERNAL_FLOAT                  = mkGhcInternalModule (fsLit "GHC.Internal.Float")+gHC_INTERNAL_TOP_HANDLER            = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler")+gHC_INTERNAL_SYSTEM_IO              = mkGhcInternalModule (fsLit "GHC.Internal.System.IO")+gHC_INTERNAL_DYNAMIC                = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic")+gHC_INTERNAL_TYPEABLE               = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable")+gHC_INTERNAL_TYPEABLE_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal")+gHC_INTERNAL_DATA_DATA              = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data")+gHC_INTERNAL_READ_PREC              = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec")+gHC_INTERNAL_LEX                    = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex")+gHC_INTERNAL_INT                    = mkGhcInternalModule (fsLit "GHC.Internal.Int")+gHC_INTERNAL_WORD                   = mkGhcInternalModule (fsLit "GHC.Internal.Word")+gHC_INTERNAL_MONAD                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad")+gHC_INTERNAL_MONAD_FIX              = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix")+gHC_INTERNAL_MONAD_FAIL             = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail")+gHC_INTERNAL_ARROW                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow")+gHC_INTERNAL_DESUGAR                = mkGhcInternalModule (fsLit "GHC.Internal.Desugar")+gHC_INTERNAL_RANDOM                 = mkGhcInternalModule (fsLit "GHC.Internal.System.Random")+gHC_INTERNAL_EXTS                   = mkGhcInternalModule (fsLit "GHC.Internal.Exts")+gHC_INTERNAL_IS_LIST                = mkGhcInternalModule (fsLit "GHC.Internal.IsList")+gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")+gHC_INTERNAL_EXCEPTION_CONTEXT      = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")+gHC_INTERNAL_GENERICS               = mkGhcInternalModule (fsLit "GHC.Internal.Generics")+gHC_INTERNAL_TYPEERROR              = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")+gHC_INTERNAL_TYPELITS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")+gHC_INTERNAL_TYPELITS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal")+gHC_INTERNAL_TYPENATS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats")+gHC_INTERNAL_TYPENATS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal")+gHC_INTERNAL_DATA_COERCE            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce")+gHC_INTERNAL_DEBUG_TRACE            = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace")+gHC_INTERNAL_UNSAFE_COERCE          = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce")+gHC_INTERNAL_FOREIGN_C_CONSTPTR     = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr")+gHC_INTERNAL_JS_PRIM                = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim")+gHC_INTERNAL_WASM_PRIM_TYPES        = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")++gHC_INTERNAL_SRCLOC :: Module+gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc")++gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module+gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack")+gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types")++gHC_INTERNAL_STATICPTR :: Module+gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr")++gHC_INTERNAL_STATICPTR_INTERNAL :: Module+gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal")++gHC_INTERNAL_FINGERPRINT_TYPE :: Module+gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type")++gHC_INTERNAL_OVER_LABELS :: Module+gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels")++gHC_INTERNAL_RECORDS :: Module+gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records")++rOOT_MAIN :: Module+rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation++mkInteractiveModule :: String -> Module+-- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9'+mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n))++pRELUDE_NAME, mAIN_NAME :: ModuleName+pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")+mAIN_NAME      = mkModuleNameFS (fsLit "Main")++mkGhcInternalModule :: FastString -> Module+mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m)++mkGhcInternalModule_ :: ModuleName -> Module+mkGhcInternalModule_ m = mkModule ghcInternalUnit m++mkThisGhcModule :: FastString -> Module+mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)++mkThisGhcModule_ :: ModuleName -> Module+mkThisGhcModule_ m = mkModule thisGhcUnit m++mkMainModule :: FastString -> Module+mkMainModule m = mkModule mainUnit (mkModuleNameFS m)++mkMainModule_ :: ModuleName -> Module+mkMainModule_ m = mkModule mainUnit m++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++main_RDR_Unqual    :: RdrName+main_RDR_Unqual = mkUnqual varName (fsLit "main")+        -- We definitely don't want an Orig RdrName, because+        -- main might, in principle, be imported into module Main++eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,+    ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName+eq_RDR                  = nameRdrName eqName+ge_RDR                  = nameRdrName geName+le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")+lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")+gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")+compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")+ltTag_RDR               = nameRdrName  ordLTDataConName+eqTag_RDR               = nameRdrName  ordEQDataConName+gtTag_RDR               = nameRdrName  ordGTDataConName++map_RDR, append_RDR :: RdrName+map_RDR                 = nameRdrName mapName+append_RDR              = nameRdrName appendName++foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR+    :: RdrName+foldr_RDR               = nameRdrName foldrName+build_RDR               = nameRdrName buildName+returnM_RDR             = nameRdrName returnMName+bindM_RDR               = nameRdrName bindMName+failM_RDR               = nameRdrName failMName++left_RDR, right_RDR :: RdrName+left_RDR                = nameRdrName leftDataConName+right_RDR               = nameRdrName rightDataConName++fromEnum_RDR, toEnum_RDR, toEnumError_RDR, succError_RDR, predError_RDR, enumIntToWord_RDR :: RdrName+fromEnum_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum")+toEnum_RDR              = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum")+toEnumError_RDR         = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnumError")+succError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succError")+predError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "predError")+enumIntToWord_RDR       = varQual_RDR gHC_INTERNAL_ENUM (fsLit "enumIntToWord")++enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName+enumFrom_RDR            = nameRdrName enumFromName+enumFromTo_RDR          = nameRdrName enumFromToName+enumFromThen_RDR        = nameRdrName enumFromThenName+enumFromThenTo_RDR      = nameRdrName enumFromThenToName++times_RDR, plus_RDR :: RdrName+times_RDR               = varQual_RDR  gHC_INTERNAL_NUM (fsLit "*")+plus_RDR                = varQual_RDR gHC_INTERNAL_NUM (fsLit "+")++compose_RDR :: RdrName+compose_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit ".")++not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+    and_RDR, range_RDR, inRange_RDR, index_RDR,+    unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName+and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")+not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")+dataToTag_RDR           = varQual_RDR gHC_MAGIC (fsLit "dataToTag#")+succ_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ")+pred_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred")+minBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound")+maxBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound")+range_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "range")+inRange_RDR             = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange")+index_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "index")+unsafeIndex_RDR         = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex")+unsafeRangeSize_RDR     = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize")++readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,+    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName+readList_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readList")+readListDefault_RDR     = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault")+readListPrec_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec")+readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault")+readPrec_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec")+parens_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "parens")+choose_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "choose")+lexP_RDR                = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP")+expectP_RDR             = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP")++readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName+readField_RDR           = varQual_RDR gHC_INTERNAL_READ (fsLit "readField")+readFieldHash_RDR       = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash")+readSymField_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField")++punc_RDR, ident_RDR, symbol_RDR :: RdrName+punc_RDR                = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc")+ident_RDR               = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident")+symbol_RDR              = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol")++step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName+step_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "step")+alt_RDR                 = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "+++")+reset_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "reset")+prec_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "prec")+pfail_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "pfail")++showsPrec_RDR, shows_RDR, showString_RDR,+    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName+showsPrec_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec")+shows_RDR               = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows")+showString_RDR          = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString")+showSpace_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace")+showCommaSpace_RDR      = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace")+showParen_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen")++error_RDR :: RdrName+error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error")++-- Generics (constructors and functions)+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,+  prodDataCon_RDR, comp1DataCon_RDR,+  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,+  from_RDR, from1_RDR, to_RDR, to1_RDR,+  datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,+  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,+  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,+  rightAssocDataCon_RDR, notAssocDataCon_RDR,+  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,+  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,+  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,+  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName++u1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1")+par1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")+rec1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")+k1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")+m1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1")++l1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1")+r1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1")++prodDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:")+comp1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1")++unPar1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")  (fsLit "unPar1")+unRec1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")  (fsLit "unRec1")+unK1_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")    (fsLit "unK1")+unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1")++from_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from")+from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1")+to_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to")+to1_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1")++datatypeName_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName")+moduleName_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName")+packageName_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName")+isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype")+selName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName")+conName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName")+conFixity_RDR     = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity")+conIsRecord_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord")++prefixDataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix")+infixDataCon_RDR      = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix")+leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName+rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName+notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName++uAddrDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")+uCharDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")+uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble")+uFloatDataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")+uIntDataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")+uWordDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")++uAddrHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")+uCharHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")   (fsLit "uChar#")+uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#")+uFloatHash_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")+uIntHash_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")    (fsLit "uInt#")+uWordHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")   (fsLit "uWord#")++fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,+    foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,+    mappend_RDR :: RdrName+fmap_RDR                = nameRdrName fmapName+replace_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$")+pure_RDR                = nameRdrName pureAName+ap_RDR                  = nameRdrName apAName+liftA2_RDR              = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2")+foldable_foldr_RDR      = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldr")+foldMap_RDR             = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldMap")+null_RDR                = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "null")+all_RDR                 = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "all")+traverse_RDR            = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "traverse")+mempty_RDR              = nameRdrName memptyName+mappend_RDR             = nameRdrName mappendName++----------------------+varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR+    :: Module -> FastString -> RdrName+varQual_RDR  mod str = mkOrig mod (mkOccNameFS varName str)+tcQual_RDR   mod str = mkOrig mod (mkOccNameFS tcName str)+clsQual_RDR  mod str = mkOrig mod (mkOccNameFS clsName str)+dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)++fieldQual_RDR :: Module -> FastString -> FastString -> RdrName+fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str)++{-+************************************************************************+*                                                                      *+\subsection{Known-key names}+*                                                                      *+************************************************************************++Many of these Names are not really "built in", but some parts of the+compiler (notably the deriving mechanism) need to mention their names,+and it's convenient to write them all down in one place.+-}++wildCardName :: Name+wildCardName = mkSystemVarName wildCardKey (fsLit "wild")++runMainIOName, runRWName :: Name+runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey+runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey++orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name+orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey+ordLTDataConName     = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey+ordEQDataConName     = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey+ordGTDataConName     = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey++specTyConName :: Name+specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey++eitherTyConName, leftDataConName, rightDataConName :: Name+eitherTyConName   = tcQual  gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey+leftDataConName   = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left")   leftDataConKey+rightDataConName  = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right")  rightDataConKey++voidTyConName :: Name+voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey++-- Generics (types)+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,+  compTyConName, rTyConName, dTyConName,+  cTyConName, sTyConName, rec0TyConName,+  d1TyConName, c1TyConName, s1TyConName,+  repTyConName, rep1TyConName, uRecTyConName,+  uAddrTyConName, uCharTyConName, uDoubleTyConName,+  uFloatTyConName, uIntTyConName, uWordTyConName,+  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+  rightAssociativeDataConName, notAssociativeDataConName,+  sourceUnpackDataConName, sourceNoUnpackDataConName,+  noSourceUnpackednessDataConName, sourceLazyDataConName,+  sourceStrictDataConName, noSourceStrictnessDataConName,+  decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+  metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name++v1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey+u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey+par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey+rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey+k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey+m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey++sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey+prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey+compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey++rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey+dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey+cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey+sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey++rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey+d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey+c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey+s1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey++repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey+rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey++uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey+uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey+uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey+uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey+uFloatTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey+uIntTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey+uWordTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey++prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI")  prefixIDataConKey+infixIDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI")   infixIDataConKey+leftAssociativeDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey+rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey+notAssociativeDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey++sourceUnpackDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey+sourceNoUnpackDataConName       = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey+noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey+sourceLazyDataConName           = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey+sourceStrictDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey+noSourceStrictnessDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey+decidedLazyDataConName          = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey+decidedStrictDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey+decidedUnpackDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey++metaDataDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData")  metaDataDataConKey+metaConsDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons")  metaConsDataConKey+metaSelDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel")   metaSelDataConKey++-- Primitive Int+divIntName, modIntName :: Name+divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey+modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey++-- Base strings Strings+unpackCStringName, unpackCStringFoldrName,+    unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,+    unpackCStringAppendName, unpackCStringAppendUtf8Name,+    eqStringName, cstringLengthName :: Name+cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey+eqStringName            = varQual gHC_INTERNAL_BASE (fsLit "eqString")  eqStringIdKey++unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey+unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey++unpackCStringUtf8Name       = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey+unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey+unpackCStringFoldrUtf8Name  = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey+++-- The 'inline' function+inlineIdName :: Name+inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey++-- Base classes (Eq, Ord, Functor)+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name+eqClassName       = clsQual gHC_CLASSES (fsLit "Eq")      eqClassKey+eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey+ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey+geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey+functorClassName  = clsQual gHC_INTERNAL_BASE    (fsLit "Functor") functorClassKey+fmapName          = varQual gHC_INTERNAL_BASE    (fsLit "fmap")    fmapClassOpKey++-- Class Monad+monadClassName, thenMName, bindMName, returnMName :: Name+monadClassName     = clsQual gHC_INTERNAL_BASE (fsLit "Monad")  monadClassKey+thenMName          = varQual gHC_INTERNAL_BASE (fsLit ">>")     thenMClassOpKey+bindMName          = varQual gHC_INTERNAL_BASE (fsLit ">>=")    bindMClassOpKey+returnMName        = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey++-- Class MonadFail+monadFailClassName, failMName :: Name+monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey+failMName          = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail")      failMClassOpKey++-- Class Applicative+applicativeClassName, pureAName, apAName, thenAName :: Name+applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey+apAName              = varQual gHC_INTERNAL_BASE (fsLit "<*>")         apAClassOpKey+pureAName            = varQual gHC_INTERNAL_BASE (fsLit "pure")        pureAClassOpKey+thenAName            = varQual gHC_INTERNAL_BASE (fsLit "*>")          thenAClassOpKey++-- Classes (Foldable, Traversable)+foldableClassName, traversableClassName :: Name+foldableClassName     = clsQual  gHC_INTERNAL_DATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey+traversableClassName  = clsQual  gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey++-- Classes (Semigroup, Monoid)+semigroupClassName, sappendName :: Name+semigroupClassName = clsQual gHC_INTERNAL_BASE       (fsLit "Semigroup") semigroupClassKey+sappendName        = varQual gHC_INTERNAL_BASE       (fsLit "<>")        sappendClassOpKey+monoidClassName, memptyName, mappendName, mconcatName :: Name+monoidClassName    = clsQual gHC_INTERNAL_BASE       (fsLit "Monoid")    monoidClassKey+memptyName         = varQual gHC_INTERNAL_BASE       (fsLit "mempty")    memptyClassOpKey+mappendName        = varQual gHC_INTERNAL_BASE       (fsLit "mappend")   mappendClassOpKey+mconcatName        = varQual gHC_INTERNAL_BASE       (fsLit "mconcat")   mconcatClassOpKey++++-- AMP additions++joinMName, alternativeClassName :: Name+joinMName            = varQual gHC_INTERNAL_BASE (fsLit "join")        joinMIdKey+alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey++--+joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,+    alternativeClassKey :: Unique+joinMIdKey          = mkPreludeMiscIdUnique 750+apAClassOpKey       = mkPreludeMiscIdUnique 751 -- <*>+pureAClassOpKey     = mkPreludeMiscIdUnique 752+thenAClassOpKey     = mkPreludeMiscIdUnique 753+alternativeClassKey = mkPreludeMiscIdUnique 754+++-- Functions for GHC extensions+considerAccessibleName :: Name+considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey++-- Random GHC.Internal.Base functions+fromStringName, otherwiseIdName, foldrName, buildName, augmentName,+    mapName, appendName, assertName,+    dollarName :: Name+dollarName        = varQual gHC_INTERNAL_BASE (fsLit "$")          dollarIdKey+otherwiseIdName   = varQual gHC_INTERNAL_BASE (fsLit "otherwise")  otherwiseIdKey+foldrName         = varQual gHC_INTERNAL_BASE (fsLit "foldr")      foldrIdKey+buildName         = varQual gHC_INTERNAL_BASE (fsLit "build")      buildIdKey+augmentName       = varQual gHC_INTERNAL_BASE (fsLit "augment")    augmentIdKey+mapName           = varQual gHC_INTERNAL_BASE (fsLit "map")        mapIdKey+appendName        = varQual gHC_INTERNAL_BASE (fsLit "++")         appendIdKey+assertName        = varQual gHC_INTERNAL_BASE (fsLit "assert")     assertIdKey+fromStringName    = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey++-- Module GHC.Internal.Num+numClassName, fromIntegerName, minusName, negateName :: Name+numClassName      = clsQual gHC_INTERNAL_NUM (fsLit "Num")         numClassKey+fromIntegerName   = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey+minusName         = varQual gHC_INTERNAL_NUM (fsLit "-")           minusClassOpKey+negateName        = varQual gHC_INTERNAL_NUM (fsLit "negate")      negateClassOpKey++---------------------------------+-- ghc-bignum+---------------------------------+integerFromNaturalName+   , integerToNaturalClampName+   , integerToNaturalThrowName+   , integerToNaturalName+   , integerToWordName+   , integerToIntName+   , integerToWord64Name+   , integerToInt64Name+   , integerFromWordName+   , integerFromWord64Name+   , integerFromInt64Name+   , integerAddName+   , integerMulName+   , integerSubName+   , integerNegateName+   , integerAbsName+   , integerPopCountName+   , integerQuotName+   , integerRemName+   , integerDivName+   , integerModName+   , integerDivModName+   , integerQuotRemName+   , integerEncodeFloatName+   , integerEncodeDoubleName+   , integerGcdName+   , integerLcmName+   , integerAndName+   , integerOrName+   , integerXorName+   , integerComplementName+   , integerBitName+   , integerTestBitName+   , integerShiftLName+   , integerShiftRName+   , naturalToWordName+   , naturalPopCountName+   , naturalShiftRName+   , naturalShiftLName+   , naturalAddName+   , naturalSubName+   , naturalSubThrowName+   , naturalSubUnsafeName+   , naturalMulName+   , naturalQuotRemName+   , naturalQuotName+   , naturalRemName+   , naturalAndName+   , naturalAndNotName+   , naturalOrName+   , naturalXorName+   , naturalTestBitName+   , naturalBitName+   , naturalGcdName+   , naturalLcmName+   , naturalLog2Name+   , naturalLogBaseWordName+   , naturalLogBaseName+   , naturalPowModName+   , naturalSizeInBaseName+   , bignatEqName+   , bignatCompareName+   , bignatCompareWordName+   :: Name++bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name+bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT  (fsLit str) key+bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key+bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key++-- Types and DataCons+bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey+bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey+bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey++naturalToWordName         = bnnVarQual "naturalToWord#"            naturalToWordIdKey+naturalPopCountName       = bnnVarQual "naturalPopCount#"          naturalPopCountIdKey+naturalShiftRName         = bnnVarQual "naturalShiftR#"            naturalShiftRIdKey+naturalShiftLName         = bnnVarQual "naturalShiftL#"            naturalShiftLIdKey+naturalAddName            = bnnVarQual "naturalAdd"                naturalAddIdKey+naturalSubName            = bnnVarQual "naturalSub"                naturalSubIdKey+naturalSubThrowName       = bnnVarQual "naturalSubThrow"           naturalSubThrowIdKey+naturalSubUnsafeName      = bnnVarQual "naturalSubUnsafe"          naturalSubUnsafeIdKey+naturalMulName            = bnnVarQual "naturalMul"                naturalMulIdKey+naturalQuotRemName        = bnnVarQual "naturalQuotRem#"           naturalQuotRemIdKey+naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey+naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey+naturalAndName            = bnnVarQual "naturalAnd"                naturalAndIdKey+naturalAndNotName         = bnnVarQual "naturalAndNot"             naturalAndNotIdKey+naturalOrName             = bnnVarQual "naturalOr"                 naturalOrIdKey+naturalXorName            = bnnVarQual "naturalXor"                naturalXorIdKey+naturalTestBitName        = bnnVarQual "naturalTestBit#"           naturalTestBitIdKey+naturalBitName            = bnnVarQual "naturalBit#"               naturalBitIdKey+naturalGcdName            = bnnVarQual "naturalGcd"                naturalGcdIdKey+naturalLcmName            = bnnVarQual "naturalLcm"                naturalLcmIdKey+naturalLog2Name           = bnnVarQual "naturalLog2#"              naturalLog2IdKey+naturalLogBaseWordName    = bnnVarQual "naturalLogBaseWord#"       naturalLogBaseWordIdKey+naturalLogBaseName        = bnnVarQual "naturalLogBase#"           naturalLogBaseIdKey+naturalPowModName         = bnnVarQual "naturalPowMod"             naturalPowModIdKey+naturalSizeInBaseName     = bnnVarQual "naturalSizeInBase#"        naturalSizeInBaseIdKey++integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey+integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey+integerToNaturalThrowName = bniVarQual "integerToNaturalThrow"     integerToNaturalThrowIdKey+integerToNaturalName      = bniVarQual "integerToNatural"          integerToNaturalIdKey+integerToWordName         = bniVarQual "integerToWord#"            integerToWordIdKey+integerToIntName          = bniVarQual "integerToInt#"             integerToIntIdKey+integerToWord64Name       = bniVarQual "integerToWord64#"          integerToWord64IdKey+integerToInt64Name        = bniVarQual "integerToInt64#"           integerToInt64IdKey+integerFromWordName       = bniVarQual "integerFromWord#"          integerFromWordIdKey+integerFromWord64Name     = bniVarQual "integerFromWord64#"        integerFromWord64IdKey+integerFromInt64Name      = bniVarQual "integerFromInt64#"         integerFromInt64IdKey+integerAddName            = bniVarQual "integerAdd"                integerAddIdKey+integerMulName            = bniVarQual "integerMul"                integerMulIdKey+integerSubName            = bniVarQual "integerSub"                integerSubIdKey+integerNegateName         = bniVarQual "integerNegate"             integerNegateIdKey+integerAbsName            = bniVarQual "integerAbs"                integerAbsIdKey+integerPopCountName       = bniVarQual "integerPopCount#"          integerPopCountIdKey+integerQuotName           = bniVarQual "integerQuot"               integerQuotIdKey+integerRemName            = bniVarQual "integerRem"                integerRemIdKey+integerDivName            = bniVarQual "integerDiv"                integerDivIdKey+integerModName            = bniVarQual "integerMod"                integerModIdKey+integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey+integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey+integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey+integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey+integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey+integerLcmName            = bniVarQual "integerLcm"                integerLcmIdKey+integerAndName            = bniVarQual "integerAnd"                integerAndIdKey+integerOrName             = bniVarQual "integerOr"                 integerOrIdKey+integerXorName            = bniVarQual "integerXor"                integerXorIdKey+integerComplementName     = bniVarQual "integerComplement"         integerComplementIdKey+integerBitName            = bniVarQual "integerBit#"               integerBitIdKey+integerTestBitName        = bniVarQual "integerTestBit#"           integerTestBitIdKey+integerShiftLName         = bniVarQual "integerShiftL#"            integerShiftLIdKey+integerShiftRName         = bniVarQual "integerShiftR#"            integerShiftRIdKey++++---------------------------------+-- End of ghc-bignum+---------------------------------++-- GHC.Internal.Real types and classes+rationalTyConName, ratioTyConName, ratioDataConName, realClassName,+    integralClassName, realFracClassName, fractionalClassName,+    fromRationalName, toIntegerName, toRationalName, fromIntegralName,+    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name+rationalTyConName   = tcQual  gHC_INTERNAL_REAL (fsLit "Rational")     rationalTyConKey+ratioTyConName      = tcQual  gHC_INTERNAL_REAL (fsLit "Ratio")        ratioTyConKey+ratioDataConName    = dcQual  gHC_INTERNAL_REAL (fsLit ":%")           ratioDataConKey+realClassName       = clsQual gHC_INTERNAL_REAL (fsLit "Real")         realClassKey+integralClassName   = clsQual gHC_INTERNAL_REAL (fsLit "Integral")     integralClassKey+realFracClassName   = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac")     realFracClassKey+fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional")   fractionalClassKey+fromRationalName    = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey+toIntegerName       = varQual gHC_INTERNAL_REAL (fsLit "toInteger")    toIntegerClassOpKey+toRationalName      = varQual gHC_INTERNAL_REAL (fsLit "toRational")   toRationalClassOpKey+fromIntegralName    = varQual  gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey+realToFracName      = varQual  gHC_INTERNAL_REAL (fsLit "realToFrac")  realToFracIdKey+mkRationalBase2Name  = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey++-- GHC.Internal.Float classes+floatingClassName, realFloatClassName :: Name+floatingClassName  = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating")  floatingClassKey+realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey++-- other GHC.Internal.Float functions+integerToFloatName, integerToDoubleName,+  naturalToFloatName, naturalToDoubleName,+  rationalToFloatName, rationalToDoubleName :: Name+integerToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey+integerToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey+naturalToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey+naturalToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey+rationalToFloatName  = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey+rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey++-- Class Ix+ixClassName :: Name+ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey++-- Typeable representation types+trModuleTyConName+  , trModuleDataConName+  , trNameTyConName+  , trNameSDataConName+  , trNameDDataConName+  , trTyConTyConName+  , trTyConDataConName+  :: Name+trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey+trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey+trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey+trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey+trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey+trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey+trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey++kindRepTyConName+  , kindRepTyConAppDataConName+  , kindRepVarDataConName+  , kindRepAppDataConName+  , kindRepFunDataConName+  , kindRepTYPEDataConName+  , kindRepTypeLitSDataConName+  , kindRepTypeLitDDataConName+  :: Name+kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey+kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey+kindRepVarDataConName = dcQual gHC_TYPES          (fsLit "KindRepVar")     kindRepVarDataConKey+kindRepAppDataConName = dcQual gHC_TYPES          (fsLit "KindRepApp")     kindRepAppDataConKey+kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey+kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey+kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey+kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey++typeLitSortTyConName+  , typeLitSymbolDataConName+  , typeLitNatDataConName+  , typeLitCharDataConName+  :: Name+typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey+typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey+typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey+typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey++-- Class Typeable, and functions for constructing `Typeable` dictionaries+typeableClassName+  , typeRepTyConName+  , someTypeRepTyConName+  , someTypeRepDataConName+  , mkTrTypeName+  , mkTrConName+  , mkTrAppCheckedName+  , mkTrFunName+  , typeRepIdName+  , typeNatTypeRepName+  , typeSymbolTypeRepName+  , typeCharTypeRepName+  , trGhcPrimModuleName+  :: Name+typeableClassName     = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey+typeRepTyConName      = tcQual  gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey+someTypeRepTyConName   = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey+someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey+typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey+mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey+mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey+mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey+mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey+typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey+typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey+-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)+-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.+trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey++-- Typeable KindReps for some common cases+starKindRepName, starArrStarKindRepName,+  starArrStarArrStarKindRepName, constraintKindRepName :: Name+starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")          starKindRepKey+starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")      starArrStarKindRepKey+starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")    starArrStarArrStarKindRepKey+constraintKindRepName  = varQual gHC_TYPES         (fsLit "krep$Constraint") constraintKindRepKey++-- WithDict+withDictClassName :: Name+withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey++nonEmptyTyConName :: Name+nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey++-- DataToTag+dataToTagClassName :: Name+dataToTagClassName    = clsQual gHC_MAGIC      (fsLit "DataToTag") dataToTagClassKey++-- seq#+seqHashName :: Name+seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey++-- Custom type errors+errorMessageTypeErrorFamName+  , typeErrorTextDataConName+  , typeErrorAppendDataConName+  , typeErrorVAppendDataConName+  , typeErrorShowTypeDataConName+  :: Name++errorMessageTypeErrorFamName =+  tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey++typeErrorTextDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey++typeErrorAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey++typeErrorVAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey++typeErrorShowTypeDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey++-- "Unsatisfiable" constraint+unsatisfiableClassName, unsatisfiableIdName :: Name+unsatisfiableClassName =+  clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey+unsatisfiableIdName =+  varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey++-- Unsafe coercion proofs+unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,+  unsafeReflDataConName :: Name+unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey+unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey+unsafeReflDataConName   = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey+unsafeCoercePrimName    = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey++-- Dynamic+toDynName :: Name+toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey++-- Class Data+dataClassName :: Name+dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey++-- Error module+assertErrorName    :: Name+assertErrorName   = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey++-- GHC.Internal.Debug.Trace+traceName          :: Name+traceName         = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey++-- Enum module (Enum, Bounded)+enumClassName, enumFromName, enumFromToName, enumFromThenName,+    enumFromThenToName, boundedClassName :: Name+enumClassName      = clsQual gHC_INTERNAL_ENUM (fsLit "Enum")           enumClassKey+enumFromName       = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom")       enumFromClassOpKey+enumFromToName     = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey+enumFromThenName   = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey+enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey+boundedClassName   = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded")        boundedClassKey++-- List functions+concatName, filterName, zipName :: Name+concatName        = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey+filterName        = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey+zipName           = varQual gHC_INTERNAL_LIST (fsLit "zip")    zipIdKey++-- Overloaded lists+isListClassName, fromListName, fromListNName, toListName :: Name+isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_INTERNAL_IS_LIST (fsLit "toList")    toListClassOpKey++-- HasField class ops+getFieldName, setFieldName :: Name+getFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey+setFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey++-- Class Show+showClassName :: Name+showClassName   = clsQual gHC_INTERNAL_SHOW (fsLit "Show")      showClassKey++-- Class Read+readClassName :: Name+readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey++-- Classes Generic and Generic1, Datatype, Constructor and Selector+genClassName, gen1ClassName, datatypeClassName, constructorClassName,+  selectorClassName :: Name+genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey+gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey++datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey+constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey+selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey++genericClassNames :: [Name]+genericClassNames = [genClassName, gen1ClassName]++-- GHCi things+ghciIoClassName, ghciStepIoMName :: Name+ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey+ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey++-- IO things+ioTyConName, ioDataConName,+  thenIOName, bindIOName, returnIOName, failIOName :: Name+ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey+ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey+thenIOName        = varQual gHC_INTERNAL_BASE  (fsLit "thenIO")   thenIOIdKey+bindIOName        = varQual gHC_INTERNAL_BASE  (fsLit "bindIO")   bindIOIdKey+returnIOName      = varQual gHC_INTERNAL_BASE  (fsLit "returnIO") returnIOIdKey+failIOName        = varQual gHC_INTERNAL_IO    (fsLit "failIO")   failIOIdKey++-- IO things+printName :: Name+printName         = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey++-- Int, Word, and Addr things+int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name+int8TyConName     = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey+int16TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int16") int16TyConKey+int32TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int32") int32TyConKey+int64TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int64") int64TyConKey++-- Word module+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name+word8TyConName    = tcQual  gHC_INTERNAL_WORD (fsLit "Word8")  word8TyConKey+word16TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey+word32TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey+word64TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey++-- PrelPtr module+ptrTyConName, funPtrTyConName :: Name+ptrTyConName      = tcQual   gHC_INTERNAL_PTR (fsLit "Ptr")    ptrTyConKey+funPtrTyConName   = tcQual   gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey++-- Foreign objects and weak pointers+stablePtrTyConName, newStablePtrName :: Name+stablePtrTyConName    = tcQual   gHC_INTERNAL_STABLE (fsLit "StablePtr")    stablePtrTyConKey+newStablePtrName      = varQual  gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey++-- Recursive-do notation+monadFixClassName, mfixName :: Name+monadFixClassName  = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey+mfixName           = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix")     mfixIdKey++-- Arrow notation+arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name+arrAName           = varQual gHC_INTERNAL_ARROW (fsLit "arr")       arrAIdKey+composeAName       = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey+firstAName         = varQual gHC_INTERNAL_ARROW (fsLit "first")     firstAIdKey+appAName           = varQual gHC_INTERNAL_ARROW (fsLit "app")       appAIdKey+choiceAName        = varQual gHC_INTERNAL_ARROW (fsLit "|||")       choiceAIdKey+loopAName          = varQual gHC_INTERNAL_ARROW (fsLit "loop")      loopAIdKey++-- Monad comprehensions+guardMName, liftMName, mzipName :: Name+guardMName         = varQual gHC_INTERNAL_MONAD (fsLit "guard")    guardMIdKey+liftMName          = varQual gHC_INTERNAL_MONAD (fsLit "liftM")    liftMIdKey+mzipName           = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey+++-- Annotation type checking+toAnnotationWrapperName :: Name+toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey++-- Other classes, needed for type defaulting+monadPlusClassName, isStringClassName :: Name+monadPlusClassName  = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus")      monadPlusClassKey+isStringClassName   = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey++-- Type-level naturals+knownNatClassName :: Name+knownNatClassName     = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey+knownSymbolClassName :: Name+knownSymbolClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownCharClassName :: Name+knownCharClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey++-- Overloaded labels+fromLabelClassOpName :: Name+fromLabelClassOpName+ = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey++-- Implicit Parameters+ipClassName :: Name+ipClassName+  = clsQual gHC_CLASSES (fsLit "IP") ipClassKey++-- Overloaded record fields+hasFieldClassName :: Name+hasFieldClassName+ = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey++-- ExceptionContext+exceptionContextTyConName, emptyExceptionContextName :: Name+exceptionContextTyConName =+    tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey+emptyExceptionContextName+  = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey++-- Source Locations+callStackTyConName, emptyCallStackName, pushCallStackName,+  srcLocDataConName :: Name+callStackTyConName+  = tcQual gHC_INTERNAL_STACK_TYPES  (fsLit "CallStack") callStackTyConKey+emptyCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey+pushCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey+srcLocDataConName+  = dcQual gHC_INTERNAL_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey++-- plugins+pLUGINS :: Module+pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")+pluginTyConName :: Name+pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey+frontendPluginTyConName :: Name+frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey++-- Static pointers+makeStaticName :: Name+makeStaticName =+    varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey++staticPtrInfoTyConName :: Name+staticPtrInfoTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey++staticPtrInfoDataConName :: Name+staticPtrInfoDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey++staticPtrTyConName :: Name+staticPtrTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey++staticPtrDataConName :: Name+staticPtrDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey++fromStaticPtrName :: Name+fromStaticPtrName =+    varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey++fingerprintDataConName :: Name+fingerprintDataConName =+    dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey++constPtrConName :: Name+constPtrConName =+    tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey++jsvalTyConName :: Name+jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey++unsafeUnpackJSStringUtf8ShShName :: Name+unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey++{-+************************************************************************+*                                                                      *+\subsection{Local helpers}+*                                                                      *+************************************************************************++All these are original names; hence mkOrig+-}++{-# INLINE varQual #-}+{-# INLINE tcQual #-}+{-# INLINE clsQual #-}+{-# INLINE dcQual #-}+varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name+varQual  modu str unique = mk_known_key_name varName modu str unique+tcQual   modu str unique = mk_known_key_name tcName modu str unique+clsQual  modu str unique = mk_known_key_name clsName modu str unique+dcQual   modu str unique = mk_known_key_name dataName modu str unique++mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+{-# INLINE mk_known_key_name #-}+mk_known_key_name space modu str unique+  = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}+*                                                                      *+************************************************************************+--MetaHaskell extension hand allocate keys here+-}++boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,+    fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,+    functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,+    realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique+boundedClassKey         = mkPreludeClassUnique 1+enumClassKey            = mkPreludeClassUnique 2+eqClassKey              = mkPreludeClassUnique 3+floatingClassKey        = mkPreludeClassUnique 5+fractionalClassKey      = mkPreludeClassUnique 6+integralClassKey        = mkPreludeClassUnique 7+monadClassKey           = mkPreludeClassUnique 8+dataClassKey            = mkPreludeClassUnique 9+functorClassKey         = mkPreludeClassUnique 10+numClassKey             = mkPreludeClassUnique 11+ordClassKey             = mkPreludeClassUnique 12+readClassKey            = mkPreludeClassUnique 13+realClassKey            = mkPreludeClassUnique 14+realFloatClassKey       = mkPreludeClassUnique 15+realFracClassKey        = mkPreludeClassUnique 16+showClassKey            = mkPreludeClassUnique 17+ixClassKey              = mkPreludeClassUnique 18++typeableClassKey :: Unique+typeableClassKey        = mkPreludeClassUnique 20++withDictClassKey :: Unique+withDictClassKey        = mkPreludeClassUnique 21++dataToTagClassKey :: Unique+dataToTagClassKey       = mkPreludeClassUnique 23++monadFixClassKey :: Unique+monadFixClassKey        = mkPreludeClassUnique 28++monadFailClassKey :: Unique+monadFailClassKey       = mkPreludeClassUnique 29++monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique+monadPlusClassKey       = mkPreludeClassUnique 30+randomClassKey          = mkPreludeClassUnique 31+randomGenClassKey       = mkPreludeClassUnique 32++isStringClassKey :: Unique+isStringClassKey        = mkPreludeClassUnique 33++applicativeClassKey, foldableClassKey, traversableClassKey :: Unique+applicativeClassKey     = mkPreludeClassUnique 34+foldableClassKey        = mkPreludeClassUnique 35+traversableClassKey     = mkPreludeClassUnique 36++genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,+  selectorClassKey :: Unique+genClassKey   = mkPreludeClassUnique 37+gen1ClassKey  = mkPreludeClassUnique 38++datatypeClassKey    = mkPreludeClassUnique 39+constructorClassKey = mkPreludeClassUnique 40+selectorClassKey    = mkPreludeClassUnique 41++-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownNatClassNameKey :: Unique+knownNatClassNameKey = mkPreludeClassUnique 42++-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownSymbolClassNameKey :: Unique+knownSymbolClassNameKey = mkPreludeClassUnique 43++knownCharClassNameKey :: Unique+knownCharClassNameKey = mkPreludeClassUnique 44++ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 45++semigroupClassKey, monoidClassKey :: Unique+semigroupClassKey = mkPreludeClassUnique 47+monoidClassKey    = mkPreludeClassUnique 48++-- Implicit Parameters+ipClassKey :: Unique+ipClassKey = mkPreludeClassUnique 49++-- Overloaded record fields+hasFieldClassNameKey :: Unique+hasFieldClassNameKey = mkPreludeClassUnique 50+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES ClassUniques 200-299+-----------------------------------------------------++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}+*                                                                      *+************************************************************************+-}++addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,+    byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,+    doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey,+    intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,+    int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey,+    int64PrimTyConKey, int64TyConKey,+    integerTyConKey, naturalTyConKey,+    listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,+    weakPrimTyConKey, mutableArrayPrimTyConKey,+    mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,+    ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,+    stablePtrTyConKey, eqTyConKey, heqTyConKey,+    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,+    stringTyConKey,+    ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique+addrPrimTyConKey                        = mkPreludeTyConUnique  1+arrayPrimTyConKey                       = mkPreludeTyConUnique  3+boolTyConKey                            = mkPreludeTyConUnique  4+byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5+stringTyConKey                          = mkPreludeTyConUnique  6+charPrimTyConKey                        = mkPreludeTyConUnique  7+charTyConKey                            = mkPreludeTyConUnique  8+doublePrimTyConKey                      = mkPreludeTyConUnique  9+doubleTyConKey                          = mkPreludeTyConUnique 10+floatPrimTyConKey                       = mkPreludeTyConUnique 11+floatTyConKey                           = mkPreludeTyConUnique 12+fUNTyConKey                             = mkPreludeTyConUnique 13+intPrimTyConKey                         = mkPreludeTyConUnique 14+intTyConKey                             = mkPreludeTyConUnique 15+int8PrimTyConKey                        = mkPreludeTyConUnique 16+int8TyConKey                            = mkPreludeTyConUnique 17+int16PrimTyConKey                       = mkPreludeTyConUnique 18+int16TyConKey                           = mkPreludeTyConUnique 19+int32PrimTyConKey                       = mkPreludeTyConUnique 20+int32TyConKey                           = mkPreludeTyConUnique 21+int64PrimTyConKey                       = mkPreludeTyConUnique 22+int64TyConKey                           = mkPreludeTyConUnique 23+integerTyConKey                         = mkPreludeTyConUnique 24+naturalTyConKey                         = mkPreludeTyConUnique 25++listTyConKey                            = mkPreludeTyConUnique 26+foreignObjPrimTyConKey                  = mkPreludeTyConUnique 27+maybeTyConKey                           = mkPreludeTyConUnique 28+weakPrimTyConKey                        = mkPreludeTyConUnique 29+mutableArrayPrimTyConKey                = mkPreludeTyConUnique 30+mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31+orderingTyConKey                        = mkPreludeTyConUnique 32+mVarPrimTyConKey                        = mkPreludeTyConUnique 33+-- ioPortPrimTyConKey (34) was killed+ratioTyConKey                           = mkPreludeTyConUnique 35+rationalTyConKey                        = mkPreludeTyConUnique 36+realWorldTyConKey                       = mkPreludeTyConUnique 37+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38+stablePtrTyConKey                       = mkPreludeTyConUnique 39+eqTyConKey                              = mkPreludeTyConUnique 40+heqTyConKey                             = mkPreludeTyConUnique 41++ctArrowTyConKey                       = mkPreludeTyConUnique 42+ccArrowTyConKey                       = mkPreludeTyConUnique 43+tcArrowTyConKey                       = mkPreludeTyConUnique 44++statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,+    mutVarPrimTyConKey, ioTyConKey,+    wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,+    word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,+    word64PrimTyConKey, word64TyConKey,+    kindConKey, boxityConKey,+    typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,+    eqReprPrimTyConKey, eqPhantPrimTyConKey,+    compactPrimTyConKey, stackSnapshotPrimTyConKey,+    promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique+statePrimTyConKey                       = mkPreludeTyConUnique 50+stableNamePrimTyConKey                  = mkPreludeTyConUnique 51+stableNameTyConKey                      = mkPreludeTyConUnique 52+eqPrimTyConKey                          = mkPreludeTyConUnique 53+eqReprPrimTyConKey                      = mkPreludeTyConUnique 54+eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55+mutVarPrimTyConKey                      = mkPreludeTyConUnique 56+ioTyConKey                              = mkPreludeTyConUnique 57+wordPrimTyConKey                        = mkPreludeTyConUnique 59+wordTyConKey                            = mkPreludeTyConUnique 60+word8PrimTyConKey                       = mkPreludeTyConUnique 61+word8TyConKey                           = mkPreludeTyConUnique 62+word16PrimTyConKey                      = mkPreludeTyConUnique 63+word16TyConKey                          = mkPreludeTyConUnique 64+word32PrimTyConKey                      = mkPreludeTyConUnique 65+word32TyConKey                          = mkPreludeTyConUnique 66+word64PrimTyConKey                      = mkPreludeTyConUnique 67+word64TyConKey                          = mkPreludeTyConUnique 68+kindConKey                              = mkPreludeTyConUnique 72+boxityConKey                            = mkPreludeTyConUnique 73+typeConKey                              = mkPreludeTyConUnique 74+threadIdPrimTyConKey                    = mkPreludeTyConUnique 75+bcoPrimTyConKey                         = mkPreludeTyConUnique 76+ptrTyConKey                             = mkPreludeTyConUnique 77+funPtrTyConKey                          = mkPreludeTyConUnique 78+tVarPrimTyConKey                        = mkPreludeTyConUnique 79+compactPrimTyConKey                     = mkPreludeTyConUnique 80+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81+promptTagPrimTyConKey                   = mkPreludeTyConUnique 82++eitherTyConKey :: Unique+eitherTyConKey                          = mkPreludeTyConUnique 84++voidTyConKey :: Unique+voidTyConKey                            = mkPreludeTyConUnique 85++nonEmptyTyConKey :: Unique+nonEmptyTyConKey                        = mkPreludeTyConUnique 86++dictTyConKey :: Unique+dictTyConKey                            = mkPreludeTyConUnique 87++-- Kind constructors+liftedTypeKindTyConKey, unliftedTypeKindTyConKey,+  tYPETyConKey, cONSTRAINTTyConKey,+  liftedRepTyConKey, unliftedRepTyConKey,+  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,+  vecCountTyConKey, vecElemTyConKey,+  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89+tYPETyConKey                            = mkPreludeTyConUnique 91+cONSTRAINTTyConKey                      = mkPreludeTyConUnique 92+constraintKindTyConKey                  = mkPreludeTyConUnique 93+levityTyConKey                          = mkPreludeTyConUnique 94+runtimeRepTyConKey                      = mkPreludeTyConUnique 95+vecCountTyConKey                        = mkPreludeTyConUnique 96+vecElemTyConKey                         = mkPreludeTyConUnique 97+liftedRepTyConKey                       = mkPreludeTyConUnique 98+unliftedRepTyConKey                     = mkPreludeTyConUnique 99+zeroBitRepTyConKey                         = mkPreludeTyConUnique 100+zeroBitTypeTyConKey                        = mkPreludeTyConUnique 101++pluginTyConKey, frontendPluginTyConKey :: Unique+pluginTyConKey                          = mkPreludeTyConUnique 102+frontendPluginTyConKey                  = mkPreludeTyConUnique 103++trTyConTyConKey, trModuleTyConKey, trNameTyConKey,+  kindRepTyConKey, typeLitSortTyConKey :: Unique+trTyConTyConKey                         = mkPreludeTyConUnique 104+trModuleTyConKey                        = mkPreludeTyConUnique 105+trNameTyConKey                          = mkPreludeTyConUnique 106+kindRepTyConKey                         = mkPreludeTyConUnique 107+typeLitSortTyConKey                     = mkPreludeTyConUnique 108++-- Generics (Unique keys)+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,+  compTyConKey, rTyConKey, dTyConKey,+  cTyConKey, sTyConKey, rec0TyConKey,+  d1TyConKey, c1TyConKey, s1TyConKey,+  repTyConKey, rep1TyConKey, uRecTyConKey,+  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,+  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique++v1TyConKey    = mkPreludeTyConUnique 135+u1TyConKey    = mkPreludeTyConUnique 136+par1TyConKey  = mkPreludeTyConUnique 137+rec1TyConKey  = mkPreludeTyConUnique 138+k1TyConKey    = mkPreludeTyConUnique 139+m1TyConKey    = mkPreludeTyConUnique 140++sumTyConKey   = mkPreludeTyConUnique 141+prodTyConKey  = mkPreludeTyConUnique 142+compTyConKey  = mkPreludeTyConUnique 143++rTyConKey = mkPreludeTyConUnique 144+dTyConKey = mkPreludeTyConUnique 146+cTyConKey = mkPreludeTyConUnique 147+sTyConKey = mkPreludeTyConUnique 148++rec0TyConKey  = mkPreludeTyConUnique 149+d1TyConKey    = mkPreludeTyConUnique 151+c1TyConKey    = mkPreludeTyConUnique 152+s1TyConKey    = mkPreludeTyConUnique 153++repTyConKey  = mkPreludeTyConUnique 155+rep1TyConKey = mkPreludeTyConUnique 156++uRecTyConKey    = mkPreludeTyConUnique 157+uAddrTyConKey   = mkPreludeTyConUnique 158+uCharTyConKey   = mkPreludeTyConUnique 159+uDoubleTyConKey = mkPreludeTyConUnique 160+uFloatTyConKey  = mkPreludeTyConUnique 161+uIntTyConKey    = mkPreludeTyConUnique 162+uWordTyConKey   = mkPreludeTyConUnique 163++-- "Unsatisfiable" constraint+unsatisfiableClassNameKey :: Unique+unsatisfiableClassNameKey = mkPreludeTyConUnique 170++anyTyConKey :: Unique+anyTyConKey = mkPreludeTyConUnique 171++zonkAnyTyConKey :: Unique+zonkAnyTyConKey = mkPreludeTyConUnique 172++-- Custom user type-errors+errorMessageTypeErrorFamKey :: Unique+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181++coercibleTyConKey :: Unique+coercibleTyConKey = mkPreludeTyConUnique 183++proxyPrimTyConKey :: Unique+proxyPrimTyConKey = mkPreludeTyConUnique 184++specTyConKey :: Unique+specTyConKey = mkPreludeTyConUnique 185++smallArrayPrimTyConKey        = mkPreludeTyConUnique  187+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188++staticPtrTyConKey  :: Unique+staticPtrTyConKey  = mkPreludeTyConUnique 189++staticPtrInfoTyConKey :: Unique+staticPtrInfoTyConKey = mkPreludeTyConUnique 190++callStackTyConKey :: Unique+callStackTyConKey = mkPreludeTyConUnique 191++-- Typeables+typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique+typeRepTyConKey       = mkPreludeTyConUnique 192+someTypeRepTyConKey   = mkPreludeTyConUnique 193+someTypeRepDataConKey = mkPreludeTyConUnique 194+++typeSymbolAppendFamNameKey :: Unique+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195++-- Unsafe equality+unsafeEqualityTyConKey :: Unique+unsafeEqualityTyConKey = mkPreludeTyConUnique 196++-- Linear types+multiplicityTyConKey :: Unique+multiplicityTyConKey = mkPreludeTyConUnique 197++unrestrictedFunTyConKey :: Unique+unrestrictedFunTyConKey = mkPreludeTyConUnique 198++multMulTyConKey :: Unique+multMulTyConKey = mkPreludeTyConUnique 199++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES TyConUniques 200-299+-----------------------------------------------------++----------------------- SIMD ------------------------+--      USES TyConUniques 300-399+-----------------------------------------------------++#include "primop-vector-uniques.hs-incl"++------------- Type-level Symbol, Nat, Char ----------+--      USES TyConUniques 400-499+-----------------------------------------------------+typeSymbolKindConNameKey, typeCharKindConNameKey,+  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,+  typeNatSubTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey+  , typeLeqCharTyFamNameKey+  , typeNatDivTyFamNameKey+  , typeNatModTyFamNameKey+  , typeNatLogTyFamNameKey+  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey+  , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey+  , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey+  :: Unique+typeSymbolKindConNameKey  = mkPreludeTyConUnique 400+typeCharKindConNameKey    = mkPreludeTyConUnique 401+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 402+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 403+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 404+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 405+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 407+typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 408+typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 409+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 410+typeNatModTyFamNameKey  = mkPreludeTyConUnique 411+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 412+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414+typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415+typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416+constPtrTyConKey = mkPreludeTyConUnique 417++jsvalTyConKey = mkPreludeTyConUnique 418++exceptionContextTyConKey = mkPreludeTyConUnique 420++unsafeUnpackJSStringUtf8ShShKey  = mkPreludeMiscIdUnique 805++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}+*                                                                      *+************************************************************************+-}++charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,+    floatDataConKey, intDataConKey, nilDataConKey,+    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,+    word8DataConKey, ioDataConKey, heqDataConKey,+    eqDataConKey, nothingDataConKey, justDataConKey :: Unique++charDataConKey                          = mkPreludeDataConUnique  1+consDataConKey                          = mkPreludeDataConUnique  2+doubleDataConKey                        = mkPreludeDataConUnique  3+falseDataConKey                         = mkPreludeDataConUnique  4+floatDataConKey                         = mkPreludeDataConUnique  5+intDataConKey                           = mkPreludeDataConUnique  6+nothingDataConKey                       = mkPreludeDataConUnique  7+justDataConKey                          = mkPreludeDataConUnique  8+eqDataConKey                            = mkPreludeDataConUnique  9+nilDataConKey                           = mkPreludeDataConUnique 10+ratioDataConKey                         = mkPreludeDataConUnique 11+word8DataConKey                         = mkPreludeDataConUnique 12+stableNameDataConKey                    = mkPreludeDataConUnique 13+trueDataConKey                          = mkPreludeDataConUnique 14+wordDataConKey                          = mkPreludeDataConUnique 15+ioDataConKey                            = mkPreludeDataConUnique 16+heqDataConKey                           = mkPreludeDataConUnique 18++-- Generic data constructors+crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique+crossDataConKey                         = mkPreludeDataConUnique 20+inlDataConKey                           = mkPreludeDataConUnique 21+inrDataConKey                           = mkPreludeDataConUnique 22+genUnitDataConKey                       = mkPreludeDataConUnique 23++leftDataConKey, rightDataConKey :: Unique+leftDataConKey                          = mkPreludeDataConUnique 25+rightDataConKey                         = mkPreludeDataConUnique 26++ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique+ordLTDataConKey                         = mkPreludeDataConUnique 27+ordEQDataConKey                         = mkPreludeDataConUnique 28+ordGTDataConKey                         = mkPreludeDataConUnique 29++mkDictDataConKey :: Unique+mkDictDataConKey                        = mkPreludeDataConUnique 30++coercibleDataConKey :: Unique+coercibleDataConKey                     = mkPreludeDataConUnique 32++staticPtrDataConKey :: Unique+staticPtrDataConKey                     = mkPreludeDataConUnique 33++staticPtrInfoDataConKey :: Unique+staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34++fingerprintDataConKey :: Unique+fingerprintDataConKey                   = mkPreludeDataConUnique 35++srcLocDataConKey :: Unique+srcLocDataConKey                        = mkPreludeDataConUnique 37++trTyConDataConKey, trModuleDataConKey,+  trNameSDataConKey, trNameDDataConKey,+  trGhcPrimModuleKey :: Unique+trTyConDataConKey                       = mkPreludeDataConUnique 41+trModuleDataConKey                      = mkPreludeDataConUnique 43+trNameSDataConKey                       = mkPreludeDataConUnique 45+trNameDDataConKey                       = mkPreludeDataConUnique 46+trGhcPrimModuleKey                      = mkPreludeDataConUnique 47++typeErrorTextDataConKey,+  typeErrorAppendDataConKey,+  typeErrorVAppendDataConKey,+  typeErrorShowTypeDataConKey+  :: Unique+typeErrorTextDataConKey                 = mkPreludeDataConUnique 50+typeErrorAppendDataConKey               = mkPreludeDataConUnique 51+typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52+typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53++prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,+    rightAssociativeDataConKey, notAssociativeDataConKey,+    sourceUnpackDataConKey, sourceNoUnpackDataConKey,+    noSourceUnpackednessDataConKey, sourceLazyDataConKey,+    sourceStrictDataConKey, noSourceStrictnessDataConKey,+    decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,+    metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique+prefixIDataConKey                       = mkPreludeDataConUnique 54+infixIDataConKey                        = mkPreludeDataConUnique 55+leftAssociativeDataConKey               = mkPreludeDataConUnique 56+rightAssociativeDataConKey              = mkPreludeDataConUnique 57+notAssociativeDataConKey                = mkPreludeDataConUnique 58+sourceUnpackDataConKey                  = mkPreludeDataConUnique 59+sourceNoUnpackDataConKey                = mkPreludeDataConUnique 60+noSourceUnpackednessDataConKey          = mkPreludeDataConUnique 61+sourceLazyDataConKey                    = mkPreludeDataConUnique 62+sourceStrictDataConKey                  = mkPreludeDataConUnique 63+noSourceStrictnessDataConKey            = mkPreludeDataConUnique 64+decidedLazyDataConKey                   = mkPreludeDataConUnique 65+decidedStrictDataConKey                 = mkPreludeDataConUnique 66+decidedUnpackDataConKey                 = mkPreludeDataConUnique 67+metaDataDataConKey                      = mkPreludeDataConUnique 68+metaConsDataConKey                      = mkPreludeDataConUnique 69+metaSelDataConKey                       = mkPreludeDataConUnique 70++vecRepDataConKey, sumRepDataConKey,+  tupleRepDataConKey, boxedRepDataConKey :: Unique+vecRepDataConKey                        = mkPreludeDataConUnique 71+tupleRepDataConKey                      = mkPreludeDataConUnique 72+sumRepDataConKey                        = mkPreludeDataConUnique 73+boxedRepDataConKey                      = mkPreludeDataConUnique 74++boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique+-- A promoted data constructors (i.e. a TyCon) has+-- the same key as the data constructor itself+boxedRepDataConTyConKey = boxedRepDataConKey+tupleRepDataConTyConKey = tupleRepDataConKey++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- Includes all nullary-data-constructor reps. Does not+-- include BoxedRep, VecRep, SumRep, TupleRep.+runtimeRepSimpleDataConKeys :: [Unique]+runtimeRepSimpleDataConKeys+  = map mkPreludeDataConUnique [75..87]++liftedDataConKey,unliftedDataConKey :: Unique+liftedDataConKey = mkPreludeDataConUnique 88+unliftedDataConKey = mkPreludeDataConUnique 89++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecCount+vecCountDataConKeys :: [Unique]+vecCountDataConKeys = map mkPreludeDataConUnique [90..95]++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecElem+vecElemDataConKeys :: [Unique]+vecElemDataConKeys = map mkPreludeDataConUnique [96..105]++-- Typeable things+kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,+    kindRepFunDataConKey, kindRepTYPEDataConKey,+    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey+    :: Unique+kindRepTyConAppDataConKey = mkPreludeDataConUnique 106+kindRepVarDataConKey      = mkPreludeDataConUnique 107+kindRepAppDataConKey      = mkPreludeDataConUnique 108+kindRepFunDataConKey      = mkPreludeDataConUnique 109+kindRepTYPEDataConKey     = mkPreludeDataConUnique 110+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112++typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique+typeLitSymbolDataConKey   = mkPreludeDataConUnique 113+typeLitNatDataConKey      = mkPreludeDataConUnique 114+typeLitCharDataConKey     = mkPreludeDataConUnique 115++-- Unsafe equality+unsafeReflDataConKey :: Unique+unsafeReflDataConKey      = mkPreludeDataConUnique 116++-- Multiplicity++oneDataConKey, manyDataConKey :: Unique+oneDataConKey = mkPreludeDataConUnique 117+manyDataConKey = mkPreludeDataConUnique 118++-- ghc-bignum+integerISDataConKey, integerINDataConKey, integerIPDataConKey,+   naturalNSDataConKey, naturalNBDataConKey :: Unique+integerISDataConKey       = mkPreludeDataConUnique 120+integerINDataConKey       = mkPreludeDataConUnique 121+integerIPDataConKey       = mkPreludeDataConUnique 122+naturalNSDataConKey       = mkPreludeDataConUnique 123+naturalNBDataConKey       = mkPreludeDataConUnique 124+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES DataUniques 200-250+-----------------------------------------------------+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}+*                                                                      *+************************************************************************+-}++wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey,+    buildIdKey, foldrIdKey, recSelErrorIdKey,+    seqIdKey, eqStringIdKey,+    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,+    impossibleErrorIdKey, impossibleConstraintErrorIdKey,+    patErrorIdKey, voidPrimIdKey,+    realWorldPrimIdKey, recConErrorIdKey,+    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,+    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,+    typeErrorIdKey, divIntIdKey, modIntIdKey,+    absentSumFieldErrorIdKey, cstringLengthIdKey+    :: Unique++wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]+absentErrorIdKey               = mkPreludeMiscIdUnique  1+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2+augmentIdKey                   = mkPreludeMiscIdUnique  3+appendIdKey                    = mkPreludeMiscIdUnique  4+buildIdKey                     = mkPreludeMiscIdUnique  5+foldrIdKey                     = mkPreludeMiscIdUnique  6+recSelErrorIdKey               = mkPreludeMiscIdUnique  7+seqIdKey                       = mkPreludeMiscIdUnique  8+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9+eqStringIdKey                  = mkPreludeMiscIdUnique 10+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14+patErrorIdKey                  = mkPreludeMiscIdUnique 15+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16+recConErrorIdKey               = mkPreludeMiscIdUnique 17++unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20++unpackCStringIdKey            = mkPreludeMiscIdUnique 21+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23++voidPrimIdKey                 = mkPreludeMiscIdUnique 24+typeErrorIdKey                = mkPreludeMiscIdUnique 25+divIntIdKey                   = mkPreludeMiscIdUnique 26+modIntIdKey                   = mkPreludeMiscIdUnique 27+cstringLengthIdKey            = mkPreludeMiscIdUnique 28++concatIdKey, filterIdKey, zipIdKey,+    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,+    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,+    otherwiseIdKey, assertIdKey :: Unique+concatIdKey                   = mkPreludeMiscIdUnique 31+filterIdKey                   = mkPreludeMiscIdUnique 32+zipIdKey                      = mkPreludeMiscIdUnique 33+bindIOIdKey                   = mkPreludeMiscIdUnique 34+returnIOIdKey                 = mkPreludeMiscIdUnique 35+newStablePtrIdKey             = mkPreludeMiscIdUnique 36+printIdKey                    = mkPreludeMiscIdUnique 37+failIOIdKey                   = mkPreludeMiscIdUnique 38+nullAddrIdKey                 = mkPreludeMiscIdUnique 39+voidArgIdKey                  = mkPreludeMiscIdUnique 40+otherwiseIdKey                = mkPreludeMiscIdUnique 43+assertIdKey                   = mkPreludeMiscIdUnique 44++leftSectionKey, rightSectionKey :: Unique+leftSectionKey                = mkPreludeMiscIdUnique 45+rightSectionKey               = mkPreludeMiscIdUnique 46++rootMainKey, runMainKey :: Unique+rootMainKey                   = mkPreludeMiscIdUnique 101+runMainKey                    = mkPreludeMiscIdUnique 102++thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique+thenIOIdKey                   = mkPreludeMiscIdUnique 103+lazyIdKey                     = mkPreludeMiscIdUnique 104+assertErrorIdKey              = mkPreludeMiscIdUnique 105+oneShotKey                    = mkPreludeMiscIdUnique 106+runRWKey                      = mkPreludeMiscIdUnique 107++traceKey :: Unique+traceKey                      = mkPreludeMiscIdUnique 108++nospecIdKey :: Unique+nospecIdKey                   = mkPreludeMiscIdUnique 109++inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique+inlineIdKey                   = mkPreludeMiscIdUnique 120+-- see below++mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique+mapIdKey                = mkPreludeMiscIdUnique 121+dollarIdKey             = mkPreludeMiscIdUnique 123+coercionTokenIdKey      = mkPreludeMiscIdUnique 124+considerAccessibleIdKey = mkPreludeMiscIdUnique 125+noinlineIdKey           = mkPreludeMiscIdUnique 126+noinlineConstraintIdKey = mkPreludeMiscIdUnique 127++integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique+integerToFloatIdKey    = mkPreludeMiscIdUnique 128+integerToDoubleIdKey   = mkPreludeMiscIdUnique 129+naturalToFloatIdKey    = mkPreludeMiscIdUnique 130+naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131++rationalToFloatIdKey, rationalToDoubleIdKey :: Unique+rationalToFloatIdKey   = mkPreludeMiscIdUnique 132+rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133++seqHashKey             = mkPreludeMiscIdUnique 134++coerceKey :: Unique+coerceKey                     = mkPreludeMiscIdUnique 157++{-+Certain class operations from Prelude classes.  They get their own+uniques so we can look them up easily when we want to conjure them up+during type checking.+-}++-- Just a placeholder for unbound variables produced by the renamer:+unboundKey :: Unique+unboundKey                    = mkPreludeMiscIdUnique 158++fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,+    enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,+    enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,+    bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey+    :: Unique+fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160+minusClassOpKey               = mkPreludeMiscIdUnique 161+fromRationalClassOpKey        = mkPreludeMiscIdUnique 162+enumFromClassOpKey            = mkPreludeMiscIdUnique 163+enumFromThenClassOpKey        = mkPreludeMiscIdUnique 164+enumFromToClassOpKey          = mkPreludeMiscIdUnique 165+enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166+eqClassOpKey                  = mkPreludeMiscIdUnique 167+geClassOpKey                  = mkPreludeMiscIdUnique 168+negateClassOpKey              = mkPreludeMiscIdUnique 169+bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)+thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)+fmapClassOpKey                = mkPreludeMiscIdUnique 173+returnMClassOpKey             = mkPreludeMiscIdUnique 174++-- Recursive do notation+mfixIdKey :: Unique+mfixIdKey       = mkPreludeMiscIdUnique 175++-- MonadFail operations+failMClassOpKey :: Unique+failMClassOpKey = mkPreludeMiscIdUnique 176++-- fromLabel+fromLabelClassOpKey :: Unique+fromLabelClassOpKey = mkPreludeMiscIdUnique 177++-- Arrow notation+arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,+    loopAIdKey :: Unique+arrAIdKey       = mkPreludeMiscIdUnique 180+composeAIdKey   = mkPreludeMiscIdUnique 181 -- >>>+firstAIdKey     = mkPreludeMiscIdUnique 182+appAIdKey       = mkPreludeMiscIdUnique 183+choiceAIdKey    = mkPreludeMiscIdUnique 184 --  |||+loopAIdKey      = mkPreludeMiscIdUnique 185++fromStringClassOpKey :: Unique+fromStringClassOpKey          = mkPreludeMiscIdUnique 186++-- Annotation type checking+toAnnotationWrapperIdKey :: Unique+toAnnotationWrapperIdKey      = mkPreludeMiscIdUnique 187++-- Conversion functions+fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique+fromIntegralIdKey    = mkPreludeMiscIdUnique 190+realToFracIdKey      = mkPreludeMiscIdUnique 191+toIntegerClassOpKey  = mkPreludeMiscIdUnique 192+toRationalClassOpKey = mkPreludeMiscIdUnique 193++-- Monad comprehensions+guardMIdKey, liftMIdKey, mzipIdKey :: Unique+guardMIdKey     = mkPreludeMiscIdUnique 194+liftMIdKey      = mkPreludeMiscIdUnique 195+mzipIdKey       = mkPreludeMiscIdUnique 196++-- GHCi+ghciStepIoMClassOpKey :: Unique+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197++-- Overloaded lists+isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique+isListClassKey = mkPreludeMiscIdUnique 198+fromListClassOpKey = mkPreludeMiscIdUnique 199+fromListNClassOpKey = mkPreludeMiscIdUnique 500+toListClassOpKey = mkPreludeMiscIdUnique 501++proxyHashKey :: Unique+proxyHashKey = mkPreludeMiscIdUnique 502++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES IdUniques 200-499+-----------------------------------------------------++-- Used to make `Typeable` dictionaries+mkTyConKey+  , mkTrTypeKey+  , mkTrConKey+  , mkTrAppCheckedKey+  , mkTrFunKey+  , typeNatTypeRepKey+  , typeSymbolTypeRepKey+  , typeCharTypeRepKey+  , typeRepIdKey+  :: Unique+mkTyConKey            = mkPreludeMiscIdUnique 503+mkTrTypeKey           = mkPreludeMiscIdUnique 504+mkTrConKey            = mkPreludeMiscIdUnique 505+mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506+typeNatTypeRepKey     = mkPreludeMiscIdUnique 507+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508+typeCharTypeRepKey    = mkPreludeMiscIdUnique 509+typeRepIdKey          = mkPreludeMiscIdUnique 510+mkTrFunKey            = mkPreludeMiscIdUnique 511++-- KindReps for common cases+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique+starKindRepKey               = mkPreludeMiscIdUnique 520+starArrStarKindRepKey        = mkPreludeMiscIdUnique 521+starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522+constraintKindRepKey         = mkPreludeMiscIdUnique 523++-- Dynamic+toDynIdKey :: Unique+toDynIdKey            = mkPreludeMiscIdUnique 530+++heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique+eqSCSelIdKey        = mkPreludeMiscIdUnique 551+heqSCSelIdKey       = mkPreludeMiscIdUnique 552+coercibleSCSelIdKey = mkPreludeMiscIdUnique 553++sappendClassOpKey :: Unique+sappendClassOpKey = mkPreludeMiscIdUnique 554++memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique+memptyClassOpKey  = mkPreludeMiscIdUnique 555+mappendClassOpKey = mkPreludeMiscIdUnique 556+mconcatClassOpKey = mkPreludeMiscIdUnique 557++emptyCallStackKey, pushCallStackKey :: Unique+emptyCallStackKey = mkPreludeMiscIdUnique 558+pushCallStackKey  = mkPreludeMiscIdUnique 559++fromStaticPtrClassOpKey :: Unique+fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560++makeStaticKey :: Unique+makeStaticKey = mkPreludeMiscIdUnique 561++emptyExceptionContextKey :: Unique+emptyExceptionContextKey = mkPreludeMiscIdUnique 562++-- Unsafe coercion proofs+unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique+unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570+unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571++-- HasField class ops+getFieldClassOpKey, setFieldClassOpKey :: Unique+getFieldClassOpKey = mkPreludeMiscIdUnique 572+setFieldClassOpKey = mkPreludeMiscIdUnique 573++-- "Unsatisfiable" constraints+unsatisfiableIdNameKey :: Unique+unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580++------------------------------------------------------+-- ghc-bignum uses 600-699 uniques+------------------------------------------------------++integerFromNaturalIdKey+   , integerToNaturalClampIdKey+   , integerToNaturalThrowIdKey+   , integerToNaturalIdKey+   , integerToWordIdKey+   , integerToIntIdKey+   , integerToWord64IdKey+   , integerToInt64IdKey+   , integerAddIdKey+   , integerMulIdKey+   , integerSubIdKey+   , integerNegateIdKey+   , integerAbsIdKey+   , integerPopCountIdKey+   , integerQuotIdKey+   , integerRemIdKey+   , integerDivIdKey+   , integerModIdKey+   , integerDivModIdKey+   , integerQuotRemIdKey+   , integerEncodeFloatIdKey+   , integerEncodeDoubleIdKey+   , integerGcdIdKey+   , integerLcmIdKey+   , integerAndIdKey+   , integerOrIdKey+   , integerXorIdKey+   , integerComplementIdKey+   , integerBitIdKey+   , integerTestBitIdKey+   , integerShiftLIdKey+   , integerShiftRIdKey+   , integerFromWordIdKey+   , integerFromWord64IdKey+   , integerFromInt64IdKey+   , naturalToWordIdKey+   , naturalPopCountIdKey+   , naturalShiftRIdKey+   , naturalShiftLIdKey+   , naturalAddIdKey+   , naturalSubIdKey+   , naturalSubThrowIdKey+   , naturalSubUnsafeIdKey+   , naturalMulIdKey+   , naturalQuotRemIdKey+   , naturalQuotIdKey+   , naturalRemIdKey+   , naturalAndIdKey+   , naturalAndNotIdKey+   , naturalOrIdKey+   , naturalXorIdKey+   , naturalTestBitIdKey+   , naturalBitIdKey+   , naturalGcdIdKey+   , naturalLcmIdKey+   , naturalLog2IdKey+   , naturalLogBaseWordIdKey+   , naturalLogBaseIdKey+   , naturalPowModIdKey+   , naturalSizeInBaseIdKey+   , bignatEqIdKey+   , bignatCompareIdKey+   , bignatCompareWordIdKey+   :: Unique++integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600+integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601+integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602+integerToNaturalIdKey      = mkPreludeMiscIdUnique 603+integerToWordIdKey         = mkPreludeMiscIdUnique 604+integerToIntIdKey          = mkPreludeMiscIdUnique 605+integerToWord64IdKey       = mkPreludeMiscIdUnique 606+integerToInt64IdKey        = mkPreludeMiscIdUnique 607+integerAddIdKey            = mkPreludeMiscIdUnique 608+integerMulIdKey            = mkPreludeMiscIdUnique 609+integerSubIdKey            = mkPreludeMiscIdUnique 610+integerNegateIdKey         = mkPreludeMiscIdUnique 611+integerAbsIdKey            = mkPreludeMiscIdUnique 618+integerPopCountIdKey       = mkPreludeMiscIdUnique 621+integerQuotIdKey           = mkPreludeMiscIdUnique 622+integerRemIdKey            = mkPreludeMiscIdUnique 623+integerDivIdKey            = mkPreludeMiscIdUnique 624+integerModIdKey            = mkPreludeMiscIdUnique 625+integerDivModIdKey         = mkPreludeMiscIdUnique 626+integerQuotRemIdKey        = mkPreludeMiscIdUnique 627+integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630+integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631+integerGcdIdKey            = mkPreludeMiscIdUnique 632+integerLcmIdKey            = mkPreludeMiscIdUnique 633+integerAndIdKey            = mkPreludeMiscIdUnique 634+integerOrIdKey             = mkPreludeMiscIdUnique 635+integerXorIdKey            = mkPreludeMiscIdUnique 636+integerComplementIdKey     = mkPreludeMiscIdUnique 637+integerBitIdKey            = mkPreludeMiscIdUnique 638+integerTestBitIdKey        = mkPreludeMiscIdUnique 639+integerShiftLIdKey         = mkPreludeMiscIdUnique 640+integerShiftRIdKey         = mkPreludeMiscIdUnique 641+integerFromWordIdKey       = mkPreludeMiscIdUnique 642+integerFromWord64IdKey     = mkPreludeMiscIdUnique 643+integerFromInt64IdKey      = mkPreludeMiscIdUnique 644++naturalToWordIdKey         = mkPreludeMiscIdUnique 650+naturalPopCountIdKey       = mkPreludeMiscIdUnique 659+naturalShiftRIdKey         = mkPreludeMiscIdUnique 660+naturalShiftLIdKey         = mkPreludeMiscIdUnique 661+naturalAddIdKey            = mkPreludeMiscIdUnique 662+naturalSubIdKey            = mkPreludeMiscIdUnique 663+naturalSubThrowIdKey       = mkPreludeMiscIdUnique 664+naturalSubUnsafeIdKey      = mkPreludeMiscIdUnique 665+naturalMulIdKey            = mkPreludeMiscIdUnique 666+naturalQuotRemIdKey        = mkPreludeMiscIdUnique 669+naturalQuotIdKey           = mkPreludeMiscIdUnique 670+naturalRemIdKey            = mkPreludeMiscIdUnique 671+naturalAndIdKey            = mkPreludeMiscIdUnique 672+naturalAndNotIdKey         = mkPreludeMiscIdUnique 673+naturalOrIdKey             = mkPreludeMiscIdUnique 674+naturalXorIdKey            = mkPreludeMiscIdUnique 675+naturalTestBitIdKey        = mkPreludeMiscIdUnique 676+naturalBitIdKey            = mkPreludeMiscIdUnique 677+naturalGcdIdKey            = mkPreludeMiscIdUnique 678+naturalLcmIdKey            = mkPreludeMiscIdUnique 679+naturalLog2IdKey           = mkPreludeMiscIdUnique 680+naturalLogBaseWordIdKey    = mkPreludeMiscIdUnique 681+naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682+naturalPowModIdKey         = mkPreludeMiscIdUnique 683+naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684++bignatEqIdKey              = mkPreludeMiscIdUnique 691+bignatCompareIdKey         = mkPreludeMiscIdUnique 692+bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693+++------------------------------------------------------+-- ghci optimization for big rationals 700-749 uniques+------------------------------------------------------++-- Creating rationals at runtime.+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique+mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique++{-+************************************************************************+*                                                                      *+\subsection[Class-std-groups]{Standard groups of Prelude classes}+*                                                                      *+************************************************************************++NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@+even though every numeric class has these two as a superclass,+because the list of ambiguous dictionaries hasn't been simplified.+-}++numericClassKeys :: [Unique]+numericClassKeys =+        [ numClassKey+        , realClassKey+        , integralClassKey+        ]+        ++ fractionalClassKeys++fractionalClassKeys :: [Unique]+fractionalClassKeys =+        [ fractionalClassKey+        , floatingClassKey+        , realFracClassKey+        , realFloatClassKey+        ]++-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4),+-- and are: "classes defined in the Prelude or a standard library"+standardClassKeys :: [Unique]+standardClassKeys = derivableClassKeys ++ numericClassKeys+                  ++ [randomClassKey, randomGenClassKey,+                      functorClassKey,+                      monadClassKey, monadPlusClassKey, monadFailClassKey,+                      semigroupClassKey, monoidClassKey,+                      isStringClassKey,+                      applicativeClassKey, foldableClassKey,+                      traversableClassKey, alternativeClassKey+                     ]++{-+@derivableClassKeys@ is also used in checking \tr{deriving} constructs+(@GHC.Tc.Deriv@).+-}++derivableClassKeys :: [Unique]+derivableClassKeys+  = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,+      boundedClassKey, showClassKey, readClassKey ]+++-- These are the "interactive classes" that are consulted when doing+-- defaulting. Does not include Num or IsString, which have special+-- handling.+interactiveClassNames :: [Name]+interactiveClassNames+  = [ showClassName, eqClassName, ordClassName, foldableClassName+    , traversableClassName ]++interactiveClassKeys :: [Unique]+interactiveClassKeys = map getUnique interactiveClassNames
+ GHC/Builtin/Names/TH.hs view
@@ -0,0 +1,1212 @@+-- %************************************************************************+-- %*                                                                   *+--              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, fieldName )+import GHC.Types.Name.Reader( RdrName, nameRdrName )+import GHC.Types.Unique ( 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, mkNameG_fldName,+    mkNameLName,+    mkNameSName, mkNameQName,+    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,+    typePName, invisPName, orPName,+    -- 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,+    typeEName, forallEName, forallVisEName, constrainedEName,+    -- FieldExp+    fieldExpName,+    -- Body+    guardedBName, normalBName,+    -- Guard+    normalGEName, patGEName,+    -- Stmt+    bindSName, letSName, noBindSName, parSName, recSName,+    -- Dec+    funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,+    classDName, instanceWithOverlapDName,+    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,+    pragInlDName, pragOpaqueDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    defaultSigDName, defaultDName,+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,+    dataInstDName, newtypeInstDName, tySynInstDName,+    infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,+    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,+    plainBndrTVName, kindedBndrTVName,+    -- Specificity+    specifiedSpecName, inferredSpecName,+    -- Visibility+    bndrReqName, bndrInvisName,+    -- 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,+    -- NamespaceSpecifier+    noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,+    dataNamespaceSpecifierDataConName,+    -- 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, tyVarBndrVisTyConName,+    clauseTyConName,+    patQTyConName, funDepTyConName, decsQTyConName,+    ruleBndrTyConName, tySynEqnTyConName,+    roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,+    overlapTyConName, derivClauseTyConName, derivStrategyTyConName,+    modNameTyConName,++    -- Quasiquoting+    quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName]++thSyn, thLib, qqLib, liftLib :: Module+thSyn = mkTHModule (fsLit "GHC.Internal.TH.Syntax")+thLib = mkTHModule (fsLit "GHC.Internal.TH.Lib")+qqLib = mkTHModule (fsLit "GHC.Internal.TH.Quote")+liftLib = mkTHModule (fsLit "GHC.Internal.TH.Lift")++mkTHModule :: FastString -> Module+mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m)++libFun, libTc, thFun, thTc, thCls, thCon, liftFun :: 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+liftFun = mk_known_key_name varName liftLib++thFld :: FastString -> FastString -> Unique -> Name+thFld con = mk_known_key_name (fieldName con) thSyn++qqFld :: FastString -> Unique -> Name+qqFld = mk_known_key_name (fieldName (fsLit "QuasiQuoter")) qqLib++-------------------- TH.Syntax -----------------------+liftClassName :: Name+liftClassName = mk_known_key_name clsName liftLib (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, quasiQuoterTyConName :: 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+quasiQuoterTyConName   = mk_known_key_name tcName qqLib (fsLit "QuasiQuoter") quasiQuoterTyConKey++returnQName, bindQName, sequenceQName, newNameName, liftName,+    mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,+    unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name+returnQName    = thFun (fsLit "returnQ")   returnQIdKey+bindQName      = thFun (fsLit "bindQ")     bindQIdKey+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey+newNameName    = thFun (fsLit "newName")   newNameIdKey+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+mkNameG_fldName= thFun (fsLit "mkNameG_fld") mkNameG_fldIdKey+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey+mkNameQName    = thFun (fsLit "mkNameQ")    mkNameQIdKey+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey+mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey+unTypeName     = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey+unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey+unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey+liftName       = liftFun (fsLit "lift")      liftIdKey+liftStringName = liftFun (fsLit "liftString")  liftStringIdKey+liftTypedName = liftFun (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, typePName, invisPName, orPName :: 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+orPName    = libFun (fsLit "orP")    orPIdKey+typePName  = libFun (fsLit "typeP")  typePIdKey+invisPName = libFun (fsLit "invisP") invisPIdKey++-- 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, typeEName,+    forallEName, forallVisEName, constrainedEName :: 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+typeEName             = libFun (fsLit "typeE")             typeEIdKey+forallEName           = libFun (fsLit "forallE")           forallEIdKey+forallVisEName        = libFun (fsLit "forallVisE")        forallVisEIdKey+constrainedEName      = libFun (fsLit "constrainedE")      constrainedEIdKey++-- 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, typeDataDName, tySynDName, classDName,+    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName, pragRuleDName,+    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,+    openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName,+    infixRWithSpecDName, infixNWithSpecDName, 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+typeDataDName                    = libFun (fsLit "typeDataD")                    typeDataDIdKey+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+pragSpecEDName                   = libFun (fsLit "pragSpecED")                   pragSpecEDIdKey+pragSpecInlEDName                = libFun (fsLit "pragSpecInlED")                pragSpecInlEDIdKey+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey+pragSCCFunDName                  = libFun (fsLit "pragSCCFunD")                  pragSCCFunDKey+pragSCCFunNamedDName             = libFun (fsLit "pragSCCFunNamedD")             pragSCCFunNamedDKey+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+infixLWithSpecDName              = libFun (fsLit "infixLWithSpecD")              infixLWithSpecDIdKey+infixRWithSpecDName              = libFun (fsLit "infixRWithSpecD")              infixRWithSpecDIdKey+infixNWithSpecDName              = libFun (fsLit "infixNWithSpecD")              infixNWithSpecDIdKey+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++plainBndrTVName, kindedBndrTVName :: Name+plainBndrTVName  = libFun (fsLit "plainBndrTV")  plainBndrTVIdKey+kindedBndrTVName = libFun (fsLit "kindedBndrTV") kindedBndrTVIdKey++-- data Specificity = ...+specifiedSpecName, inferredSpecName :: Name+specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey+inferredSpecName  = libFun (fsLit "inferredSpec")  inferredSpecKey++-- data BndrVis = ...+bndrReqName, bndrInvisName :: Name+bndrReqName   = libFun (fsLit "bndrReq")   bndrReqKey+bndrInvisName = libFun (fsLit "bndrInvis") bndrInvisKey++-- 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, tyVarBndrVisTyConName,+    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+tyVarBndrVisTyConName  = libTc (fsLit "TyVarBndrVis")  tyVarBndrVisTyConKey+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey++-- quasiquoting+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name+quoteExpName  = qqFld (fsLit "quoteExp")  quoteExpKey+quotePatName  = qqFld (fsLit "quotePat")  quotePatKey+quoteDecName  = qqFld (fsLit "quoteDec")  quoteDecKey+quoteTypeName = qqFld (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++-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConName,+  typeNamespaceSpecifierDataConName,+  dataNamespaceSpecifierDataConName :: Name+noNamespaceSpecifierDataConName =+  thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey+typeNamespaceSpecifierDataConName =+  thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey+dataNamespaceSpecifierDataConName =+  thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey++{- *********************************************************************+*                                                                      *+                     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, tyVarBndrVisTyConKey,+    decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,+    funDepTyConKey, predTyConKey,+    predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,+    roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,+    overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,+    modNameTyConKey, quasiQuoterTyConKey :: 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+tyVarBndrVisTyConKey    = mkPreludeTyConUnique 240+quasiQuoterTyConKey     = mkPreludeTyConUnique 241++{- *********************************************************************+*                                                                      *+                     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++-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConKey,+  typeNamespaceSpecifierDataConKey,+  dataNamespaceSpecifierDataConKey :: Unique+noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213+typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214+dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215+{- *********************************************************************+*                                                                      *+                     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_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: 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+mkNameQIdKey         = mkPreludeMiscIdUnique 217+mkNameG_fldIdKey     = mkPreludeMiscIdUnique 218+++-- 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, typePIdKey, invisPIdKey, orPIdKey :: 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+typePIdKey        = mkPreludeMiscIdUnique 255+invisPIdKey       = mkPreludeMiscIdUnique 256+orPIdKey          = mkPreludeMiscIdUnique 257++-- 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, typeEIdKey, forallEIdKey,+    forallVisEIdKey, constrainedEIdKey :: 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+typeEIdKey             = mkPreludeMiscIdUnique 306+forallEIdKey           = mkPreludeMiscIdUnique 802+forallVisEIdKey        = mkPreludeMiscIdUnique 803+constrainedEIdKey      = mkPreludeMiscIdUnique 804++-- type FieldExp = ...+fieldExpIdKey :: Unique+fieldExpIdKey       = mkPreludeMiscIdUnique 307++-- data Body = ...+guardedBIdKey, normalBIdKey :: Unique+guardedBIdKey     = mkPreludeMiscIdUnique 308+normalBIdKey      = mkPreludeMiscIdUnique 309++-- data Guard = ...+normalGEIdKey, patGEIdKey :: Unique+normalGEIdKey     = mkPreludeMiscIdUnique 310+patGEIdKey        = mkPreludeMiscIdUnique 311++-- data Stmt = ...+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique+bindSIdKey       = mkPreludeMiscIdUnique 312+letSIdKey        = mkPreludeMiscIdUnique 313+noBindSIdKey     = mkPreludeMiscIdUnique 314+parSIdKey        = mkPreludeMiscIdUnique 315+recSIdKey        = mkPreludeMiscIdUnique 316++-- 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,+    infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,+    roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,+    implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,+    typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey,+    pragSpecEDIdKey, pragSpecInlEDIdKey :: 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+infixLWithSpecDIdKey              = mkPreludeMiscIdUnique 342+infixRWithSpecDIdKey              = mkPreludeMiscIdUnique 343+infixNWithSpecDIdKey              = 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+typeDataDIdKey                    = mkPreludeMiscIdUnique 355+pragSCCFunDKey                    = mkPreludeMiscIdUnique 356+pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357+pragSpecEDIdKey                   = mkPreludeMiscIdUnique 358+pragSpecInlEDIdKey                = mkPreludeMiscIdUnique 359++-- 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++plainBndrTVIdKey, kindedBndrTVIdKey :: Unique+plainBndrTVIdKey       = mkPreludeMiscIdUnique 484+kindedBndrTVIdKey      = mkPreludeMiscIdUnique 485++-- 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++-- data BndrVis = ...+bndrReqKey, bndrInvisKey :: Unique+bndrReqKey   = mkPreludeMiscIdUnique 800  -- TODO (int-index): make up some room in the 5** numberspace?+bndrInvisKey = mkPreludeMiscIdUnique 801++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName+lift_RDR     = nameRdrName liftName+liftTyped_RDR = nameRdrName liftTypedName+unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
+ GHC/Builtin/PrimOps.hs view
@@ -0,0 +1,931 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PrimOp]{Primitive operations (machine-level)}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Builtin.PrimOps (+        PrimOp(..), PrimOpVecCat(..), allThePrimOps,+        primOpType, primOpSig, primOpResultType,+        primOpTag, maxPrimOpTag, primOpOcc,+        primOpWrapperId,+        pprPrimOp,++        tagToEnumKey,++        primOpOutOfLine, primOpCodeSize,+        primOpOkForSpeculation, primOpOkToDiscard,+        primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations,+        primOpIsDiv, primOpIsReallyInline,++        PrimOpEffect(..), primOpEffect,++        getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),++        PrimCall(..)+    ) where++import GHC.Prelude++import GHC.Builtin.Types.Prim+import GHC.Builtin.Types+import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )+import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS )++import GHC.Core.TyCon    ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) )+import GHC.Core.Type++import GHC.Cmm.Type++import GHC.Types.Demand+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.RepType ( tyConPrimRep )+import GHC.Types.Basic+import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) )+import GHC.Types.SrcLoc  ( wiredInSrcSpan )+import GHC.Types.ForeignCall ( CLabelString )+import GHC.Types.Unique  ( Unique )++import GHC.Unit.Types    ( Unit )++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Data.FastString++{-+************************************************************************+*                                                                      *+\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)}+*                                                                      *+************************************************************************++These are in \tr{state-interface.verb} order.+-}++-- supplies:+-- data PrimOp = ...+#include "primop-data-decl.hs-incl"++-- supplies+-- primOpTag :: PrimOp -> Int+#include "primop-tag.hs-incl"+primOpTag _ = error "primOpTag: unknown primop"+++instance Eq PrimOp where+    op1 == op2 = primOpTag op1 == primOpTag op2++instance Ord PrimOp where+    op1 <  op2 =  primOpTag op1 < primOpTag op2+    op1 <= op2 =  primOpTag op1 <= primOpTag op2+    op1 >= op2 =  primOpTag op1 >= primOpTag op2+    op1 >  op2 =  primOpTag op1 > primOpTag op2+    op1 `compare` op2 | op1 < op2  = LT+                      | op1 == op2 = EQ+                      | otherwise  = GT++instance Outputable PrimOp where+    ppr op = pprPrimOp op++data PrimOpVecCat = IntVec+                  | WordVec+                  | FloatVec++-- An @Enum@-derived list would be better; meanwhile... (ToDo)++allThePrimOps :: [PrimOp]+allThePrimOps =+#include "primop-list.hs-incl"++tagToEnumKey :: Unique+tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp)++{-+************************************************************************+*                                                                      *+\subsection[PrimOp-info]{The essential info about each @PrimOp@}+*                                                                      *+************************************************************************+-}++data PrimOpInfo+  = Compare     OccName         -- string :: T -> T -> Int#+                Type+  | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T+                [TyVarBinder]+                [Type]+                Type++mkCompare :: FastString -> Type -> PrimOpInfo+mkCompare str ty = Compare (mkVarOccFS str) ty++mkGenPrimOp :: FastString -> [TyVarBinder] -> [Type] -> Type -> PrimOpInfo+mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty++{-+************************************************************************+*                                                                      *+\subsubsection{Strictness}+*                                                                      *+************************************************************************++Not all primops are strict!+-}++primOpStrictness :: PrimOp -> Arity -> DmdSig+        -- See Demand.DmdSig for discussion of what the results+        -- The arity should be the arity of the primop; that's why+        -- this function isn't exported.+#include "primop-strictness.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection{Fixity}+*                                                                      *+************************************************************************+-}++primOpFixity :: PrimOp -> Maybe Fixity+#include "primop-fixity.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection{Docs}+*                                                                      *+************************************************************************++See Note [GHC.Prim Docs] in GHC.Builtin.Utils+-}++primOpDocs :: [(FastString, String)]+#include "primop-docs.hs-incl"++primOpDeprecations :: [(OccName, FastString)]+#include "primop-deprecations.hs-incl"++{-+************************************************************************+*                                                                      *+\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops}+*                                                                      *+************************************************************************++@primOpInfo@ gives all essential information (from which everything+else, notably a type, can be constructed) for each @PrimOp@.+-}++primOpInfo :: PrimOp -> PrimOpInfo+#include "primop-primop-info.hs-incl"+primOpInfo _ = error "primOpInfo: unknown primop"++{-+Here are a load of comments from the old primOp info:++A @Word#@ is an unsigned @Int#@.++@decodeFloat#@ is given w/ Integer-stuff (it's similar).++@decodeDouble#@ is given w/ Integer-stuff (it's similar).++Decoding of floating-point numbers is sorta Integer-related.  Encoding+is done with plain ccalls now (see PrelNumExtra.hs).++A @Weak@ Pointer is created by the @mkWeak#@ primitive:++        mkWeak# :: k -> v -> f -> State# RealWorld+                        -> (# State# RealWorld, Weak# v #)++In practice, you'll use the higher-level++        data Weak v = Weak# v+        mkWeak :: k -> v -> IO () -> IO (Weak v)++The following operation dereferences a weak pointer.  The weak pointer+may have been finalized, so the operation returns a result code which+must be inspected before looking at the dereferenced value.++        deRefWeak# :: Weak# v -> State# RealWorld ->+                        (# State# RealWorld, v, Int# #)++Only look at v if the Int# returned is /= 0 !!++The higher-level op is++        deRefWeak :: Weak v -> IO (Maybe v)++Weak pointers can be finalized early by using the finalize# operation:++        finalizeWeak# :: Weak# v -> State# RealWorld ->+                           (# State# RealWorld, Int#, IO () #)++The Int# returned is either++        0 if the weak pointer has already been finalized, or it has no+          finalizer (the third component is then invalid).++        1 if the weak pointer is still alive, with the finalizer returned+          as the third component.++A {\em stable name/pointer} is an index into a table of stable name+entries.  Since the garbage collector is told about stable pointers,+it is safe to pass a stable pointer to external systems such as C+routines.++\begin{verbatim}+makeStablePtr#  :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #)+freeStablePtr   :: StablePtr# a -> State# RealWorld -> State# RealWorld+deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #)+eqStablePtr#    :: StablePtr# a -> StablePtr# a -> Int#+\end{verbatim}++It may seem a bit surprising that @makeStablePtr#@ is a @IO@+operation since it doesn't (directly) involve IO operations.  The+reason is that if some optimisation pass decided to duplicate calls to+@makeStablePtr#@ and we only pass one of the stable pointers over, a+massive space leak can result.  Putting it into the IO monad+prevents this.  (Another reason for putting them in a monad is to+ensure correct sequencing wrt the side-effecting @freeStablePtr@+operation.)++An important property of stable pointers is that if you call+makeStablePtr# twice on the same object you get the same stable+pointer back.++Note that we can implement @freeStablePtr#@ using @_ccall_@ (and,+besides, it's not likely to be used from Haskell) so it's not a+primop.++Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR]++Stable Names+~~~~~~~~~~~~++A stable name is like a stable pointer, but with three important differences:++        (a) You can't deRef one to get back to the original object.+        (b) You can convert one to an Int.+        (c) You don't need to 'freeStableName'++The existence of a stable name doesn't guarantee to keep the object it+points to alive (unlike a stable pointer), hence (a).++Invariants:++        (a) makeStableName always returns the same value for a given+            object (same as stable pointers).++        (b) if two stable names are equal, it implies that the objects+            from which they were created were the same.++        (c) stableNameToInt always returns the same Int for a given+            stable name.+++These primops are pretty weird.++        tagToEnum# :: Int -> a    (result type must be an enumerated type)++The constraints aren't currently checked by the front end, but the+code generator will fall over if they aren't satisfied.++************************************************************************+*                                                                      *+            Which PrimOps are out-of-line+*                                                                      *+************************************************************************++Some PrimOps need to be called out-of-line because they either need to+perform a heap check or they block.+-}++primOpOutOfLine :: PrimOp -> Bool+#include "primop-out-of-line.hs-incl"++{-+************************************************************************+*                                                                      *+            Failure and side effects+*                                                                      *+************************************************************************+++Note [Exceptions: asynchronous, synchronous, and unchecked]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are three very different sorts of things in GHC-Haskell that are+sometimes called exceptions:++* Haskell exceptions:++  These are ordinary exceptions that users can raise with the likes+  of 'throw' and handle with the likes of 'catch'.  They come in two+  very different flavors:++  * Asynchronous exceptions:+    * These can arise at nearly any time, and may have nothing to do+      with the code being executed.+    * The compiler itself mostly doesn't need to care about them.+    * Examples: a signal from another process, running out of heap or stack+    * Even pure code can receive asynchronous exceptions; in this+      case, executing the same code again may lead to different+      results, because the exception may not happen next time.+    * See rts/RaiseAsync.c for the gory details of how they work.++  * Synchronous exceptions:+    * These are produced by the code being executed, most commonly via+      a call to the `raise#` or `raiseIO#` primops.+    * At run-time, if a piece of pure code raises a synchronous+      exception, it will always raise the same synchronous exception+      if it is run again (and not interrupted by an asynchronous+      exception).+    * In particular, if an updatable thunk does some work and then+      raises a synchronous exception, it is safe to overwrite it with+      a thunk that /immediately/ raises the same exception.+    * Although we are careful not to discard synchronous exceptions, we+      are very liberal about re-ordering them with respect to most other+      operations.  See the paper "A semantics for imprecise exceptions"+      as well as Note [Precise exceptions and strictness analysis] in+      GHC.Types.Demand.++* Unchecked exceptions:++  * These are nasty failures like seg-faults or primitive Int# division+    by zero.  They differ from Haskell exceptions in that they are+    un-recoverable and typically bring execution to an immediate halt.+  * We generally treat unchecked exceptions as undefined behavior, on+    the assumption that the programmer never intends to crash the+    program in this way.  Thus we have no qualms about replacing a+    division-by-zero with a recoverable Haskell exception or+    discarding an indexArray# operation whose result is unused.+++Note [Classifying primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each primop has an associated 'PrimOpEffect', based on what that+primop can or cannot do at runtime.  This classification is++* Recorded in the 'effect' field in primops.txt.pp, and+* Exposed to the compiler via the 'primOpEffect' function in this module.++See Note [Transformations affected by primop effects] for how we make+use of this categorisation.++The meanings of the four constructors of 'PrimOpEffect' are as+follows, in decreasing order of permissiveness:++* ReadWriteEffect+    A primop is marked ReadWriteEffect if it can+    - read or write to the world (I/O), or+    - read or write to a mutable data structure (e.g. readMutVar#).++    Every such primop uses State# tokens for sequencing, with a type like:+      Inputs -> State# s -> (# State# s, Outputs #)+    The state token threading expresses ordering, but duplicating even+    a read-only effect would defeat this.  (See "duplication" under+    Note [Transformations affected by primop effects] for details.)++    Note that operations like `indexArray#` that read *immutable*+    data structures do not need such special sequencing-related care,+    and are therefore not marked ReadWriteEffect.++* ThrowsException+    A primop is marked ThrowsException if+    - it is not marked ReadWriteEffect, and+    - it may diverge or throw a synchronous Haskell exception+      even when used in a "correct" and well-specified way.++    See also Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include raise#, raiseIO#, dataToTagLarge#, and seq#.++    Note that whether an exception is considered precise or imprecise+    does not matter for the purposes of the PrimOpEffect flag.++* CanFail+    A primop is marked CanFail if+    - it is not marked ReadWriteEffect or ThrowsException, and+    - it can trigger a (potentially-unchecked) exception when used incorrectly.++    See Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include quotWord# and indexIntArray#, which can fail with+    division-by-zero and a segfault respectively.++    A correct use of a CanFail primop is usually surrounded by a test+    that screens out the bad cases such as a zero divisor or an+    out-of-bounds array index.  We must take care never to move a+    CanFail primop outside the scope of such a test.++* NoEffect+    A primop is marked NoEffect if it does not belong to any of the+    other three categories.  We can very aggressively shuffle these+    operations around without fear of changing a program's meaning.++    Perhaps surprisingly, this aggressive shuffling imposes another+    restriction: The tricky NoEffect primop uncheckedShiftLWord32# has+    an undefined result when the provided shift amount is not between+    0 and 31.  Thus, a call like `uncheckedShiftLWord32# x 95#` is+    obviously invalid.  But since uncheckedShiftLWord32# is marked+    NoEffect, we may float such an invalid call out of a dead branch+    and speculatively evaluate it.++    In particular, we cannot safely rewrite such an invalid call to a+    runtime error; we must emit code that produces a valid Word32#.+    (If we're lucky, Core Lint may complain that the result of such a+    rewrite violates the let-can-float invariant (#16742), but the+    rewrite is always wrong!)  See also Note [Guarding against silly shifts]+    in GHC.Core.Opt.ConstantFold.++    Marking uncheckedShiftLWord32# as CanFail instead of NoEffect+    would give us the freedom to rewrite such invalid calls to runtime+    errors, but would get in the way of optimization: When speculatively+    executing a bit-shift prevents the allocation of a thunk, that's a+    big win.+++Note [Transformations affected by primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The PrimOpEffect properties have the following effect on program+transformations.  The summary table is followed by details.  See also+Note [Classifying primop effects] for exactly what each column means.++                    NoEffect    CanFail    ThrowsException    ReadWriteEffect+Discard                YES        YES            NO                 NO+Defer (float in)       YES        YES           SAFE               SAFE+Speculate (float out)  YES        NO             NO                 NO+Duplicate              YES        YES            YES                NO++(SAFE means we could perform the transformation but do not.)++* Discarding:   case (a `op` b) of _ -> rhs  ===>   rhs+    You should not discard a ReadWriteEffect primop; e.g.+       case (writeIntArray# a i v s of (# _, _ #) -> True+    One could argue in favor of discarding this, since the returned+    State# token is not used.  But in practice unsafePerformIO can+    easily produce similar code, and programmers sometimes write this+    kind of stuff by hand (#9390).  So we (conservatively) never discard+    a ReadWriteEffect primop.++      Digression: We could try to track read-only effects separately+      from write effects to allow the former to be discarded.  But in+      fact we want a more general rewrite for read-only operations:+        case readOp# state# of (# newState#, _unused_result #) -> body+        ==> case state# of newState# -> body+      Such a rewrite is not yet implemented, but would have to be done+      in a different place anyway.++    Discarding a ThrowsException primop would also discard any exception+    it might have thrown.  For `raise#` or `raiseIO#` this would defeat+    the whole point of the primop, while for `dataToTagLarge#` or `seq#`+    this would make programs unexpectly lazier.++    However, it's fine to discard a CanFail primop.  For example+       case (indexIntArray# a i) of _ -> True+    We can discard indexIntArray# here; this came up in #5658.  Notice+    that CanFail primops like indexIntArray# can only trigger an+    exception when used incorrectly, i.e. a call that might not succeed+    is undefined behavior anyway.++* Deferring (float-in):+    See Note [Floating primops] in GHC.Core.Opt.FloatIn.++    In the absence of data dependencies (including state token threading),+    we reserve the right to re-order the following things arbitrarily:+      * Side effects+      * Imprecise exceptions+      * Divergent computations (infinite loops)+    This lets us safely float almost any primop *inwards*, but not+    inside a (multi-shot) lambda.  (See "Duplication" below.)++    However, the main reason to float-in a primop application would be+    to discard it (by floating it into some but not all branches of a+    case), so we actually only float-in NoEffect and CanFail operations.+    See also Note [Floating primops] in GHC.Core.Opt.FloatIn.++    (This automatically side-steps the question of precise exceptions, which+    mustn't be re-ordered arbitrarily but need at least ThrowsException.)++* Speculation (strict float-out):+    You must not float a CanFail primop *outwards* lest it escape the+    dynamic scope of a run-time validity test.  Example:+      case d ># 0# of+        True  -> case x /# d of r -> r +# 1+        False -> 0+    Here we must not float the case outwards to give+      case x/# d of r ->+      case d ># 0# of+        True  -> r +# 1+        False -> 0+    Otherwise, if this block is reached when d is zero, it will crash.+    Exactly the same reasoning applies to ThrowsException primops.++    Nor can you float out a ReadWriteEffect primop.  For example:+       if blah then case writeMutVar# v True s0 of (# s1 #) -> s1+               else s0+    Notice that s0 is mentioned in both branches of the 'if', but+    only one of these two will actually be consumed.  But if we+    float out to+      case writeMutVar# v True s0 of (# s1 #) ->+      if blah then s1 else s0+    the writeMutVar will be performed in both branches, which is+    utterly wrong.++    What about a read-only operation that cannot fail, like+    readMutVar#?  In principle we could safely float these out.  But+    there are not very many such operations and it's not clear if+    there are real-world programs that would benefit from this.++* Duplication:+    You cannot duplicate a ReadWriteEffect primop.  You might wonder+    how this can occur given the state token threading, but just look+    at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get something like this+        p = case readMutVar# s v of+              (# s', r #) -> (State# s', r)+        s' = case p of (s', r) -> s'+        r  = case p of (s', r) -> r++    (All these bindings are boxed.)  If we inline p at its two call+    sites, we get a catastrophe: because the read is performed once when+    s' is demanded, and once when 'r' is demanded, which may be much+    later.  Utterly wrong.  #3207 is real example of this happening.+    Floating p into a multi-shot lambda would be wrong for the same reason.++    However, it's fine to duplicate a CanFail or ThrowsException primop.++++Note [Implementation: how PrimOpEffect affects transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we ensure that floating/duplication/discarding are done right+in the simplifier?++Several predicates on primops test this flag:+  primOpOkToDiscard      <=> effect < ThrowsException+  primOpOkForSpeculation <=> effect == NoEffect && not (out_of_line)+  primOpIsCheap          <=> cheap  -- ...defaults to primOpOkForSpeculation+    [[But note that the raise# family and seq# are also considered cheap in+      GHC.Core.Utils.exprIsCheap by way of being work-free]]++  * The discarding mentioned above happens in+    GHC.Core.Opt.Simplify.Iteration, specifically in rebuildCase,+    where it is guarded by exprOkToDiscard, which in turn checks+    primOpOkToDiscard.++  * The "no-float-out" thing is achieved by ensuring that we never+    let-bind a saturated primop application unless it has NoEffect.+    The RHS of a let-binding (which can float in and out freely)+    satisfies exprOkForSpeculation; this is the let-can-float+    invariant.  And exprOkForSpeculation is false of a saturated+    primop application unless it has NoEffect.++  * So primops that aren't NoEffect will appear only as the+    scrutinees of cases, and that's why the FloatIn pass is capable+    of floating case bindings inwards.++  * Duplication via inlining and float-in of (lifted) let-binders is+    controlled via primOpIsWorkFree and primOpIsCheap, by making+    ReadWriteEffect things (among others) not-cheap!  (The test+    PrimOpEffect_Sanity will complain if any ReadWriteEffect primop+    is considered either work-free or cheap.)  Additionally, a+    case binding is only floated inwards if its scrutinee is ok-to-discard.+-}++primOpEffect :: PrimOp -> PrimOpEffect+#include "primop-effects.hs-incl"++data PrimOpEffect+  -- See Note [Classifying primop effects]+  = NoEffect+  | CanFail+  | ThrowsException+  | ReadWriteEffect+  deriving (Eq, Ord)++primOpOkForSpeculation :: PrimOp -> Bool+  -- See Note [Classifying primop effects]+  -- See comments with GHC.Core.Utils.exprOkForSpeculation+  -- primOpOkForSpeculation => primOpOkToDiscard+primOpOkForSpeculation op+  = primOpEffect op == NoEffect && not (primOpOutOfLine op)+    -- I think the "out of line" test is because out of line things can+    -- be expensive (eg sine, cosine), and so we may not want to speculate them++primOpOkToDiscard :: PrimOp -> Bool+primOpOkToDiscard op+  = primOpEffect op < ThrowsException++primOpIsWorkFree :: PrimOp -> Bool+#include "primop-is-work-free.hs-incl"++primOpIsCheap :: PrimOp -> Bool+-- See Note [Classifying primop effects]+#include "primop-is-cheap.hs-incl"+-- In March 2001, we changed this to+--      primOpIsCheap op = False+-- thereby making *no* primops seem cheap.  But this killed eta+-- expansion on case (x ==# y) of True -> \s -> ...+-- which is bad.  In particular a loop like+--      doLoop n = loop 0+--     where+--         loop i | i == n    = return ()+--                | otherwise = bar i >> loop (i+1)+-- allocated a closure every time round because it doesn't eta expand.+--+-- The problem that originally gave rise to the change was+--      let x = a +# b *# c in x +# x+-- were we don't want to inline x. But primopIsCheap doesn't control+-- that (it's primOpIsWorkFree that does) so the problem doesn't occur+-- even if primOpIsCheap sometimes says 'True'.+++-- | True of dyadic operators that can fail only if the second arg is zero!+--+-- This function probably belongs in an automagically generated file.. but it's+-- such a special case I thought I'd leave it here for now.+primOpIsDiv :: PrimOp -> Bool+primOpIsDiv op = case op of++  IntQuotOp       -> True+  Int8QuotOp      -> True+  Int16QuotOp     -> True+  Int32QuotOp     -> True+  Int64QuotOp     -> True++  IntRemOp        -> True+  Int8RemOp       -> True+  Int16RemOp      -> True+  Int32RemOp      -> True+  Int64RemOp      -> True++  IntQuotRemOp    -> True+  Int8QuotRemOp   -> True+  Int16QuotRemOp  -> True+  Int32QuotRemOp  -> True+  -- Int64QuotRemOp doesn't exist (yet)++  WordQuotOp      -> True+  Word8QuotOp     -> True+  Word16QuotOp    -> True+  Word32QuotOp    -> True+  Word64QuotOp    -> True++  WordRemOp       -> True+  Word8RemOp      -> True+  Word16RemOp     -> True+  Word32RemOp     -> True+  Word64RemOp     -> True++  WordQuotRemOp   -> True+  Word8QuotRemOp  -> True+  Word16QuotRemOp -> True+  Word32QuotRemOp -> True+  -- Word64QuotRemOp doesn't exist (yet)++  WordQuotRem2Op  -> True++  FloatDivOp      -> True+  DoubleDivOp     -> True+  _               -> False++++{-+************************************************************************+*                                                                      *+               PrimOp code size+*                                                                      *+************************************************************************++primOpCodeSize+~~~~~~~~~~~~~~+Gives an indication of the code size of a primop, for the purposes of+calculating unfolding sizes; see GHC.Core.Unfold.sizeExpr.+-}++primOpCodeSize :: PrimOp -> Int+#include "primop-code-size.hs-incl"++primOpCodeSizeDefault :: Int+primOpCodeSizeDefault = 1+  -- GHC.Core.Unfold.primOpSize already takes into account primOpOutOfLine+  -- and adds some further costs for the args in that case.++primOpCodeSizeForeignCall :: Int+primOpCodeSizeForeignCall = 4++{-+************************************************************************+*                                                                      *+               PrimOp types+*                                                                      *+************************************************************************+-}++primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead+primOpType op+  = case primOpInfo op of+    Compare _occ ty -> compare_fun_ty ty++    GenPrimOp _occ tyvars arg_tys res_ty ->+        mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)++primOpResultType :: PrimOp -> Type+primOpResultType op+  = case primOpInfo op of+    Compare _occ _ty -> intPrimTy+    GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty++primOpOcc :: PrimOp -> OccName+primOpOcc op = case primOpInfo op of+               Compare   occ _     -> occ+               GenPrimOp occ _ _ _ -> occ++{- Note [Primop wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~++To support (limited) use of primops in GHCi genprimopcode generates the+GHC.PrimopWrappers module. This module contains a "primop wrapper"+binding for each primop. These are standard Haskell functions mirroring the+types of the primops they wrap. For instance, in the case of plusInt# we would+have:++    module GHC.PrimopWrappers where+    import GHC.Prim as P++    plusInt# :: Int# -> Int# -> Int#+    plusInt# a b = P.plusInt# a b++The Id for the wrapper of a primop can be found using+'GHC.Builtin.PrimOps.primOpWrapperId'. However, GHCi does not use this mechanism+to link primops; it rather does a rather hacky symbol lookup (see+GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed?++Note that these wrappers aren't *quite* as expressive as their unwrapped+brethren, in that they may exhibit less representation polymorphism.+For instance, consider the case of mkWeakNoFinalizer#, which has type:++    mkWeakNoFinalizer# :: forall (r :: RuntimeRep) (k :: TYPE r) (v :: Type).+                          k -> v+                       -> State# RealWorld+                       -> (# State# RealWorld, Weak# v #)++Naively we could generate a wrapper of the form,+++    mkWeakNoFinalizer# k v s = GHC.Prim.mkWeakNoFinalizer# k v s++However, this would require that 'k' bind the representation-polymorphic key,+which is disallowed by our representation polymorphism validity checks+(see Note [Representation polymorphism invariants] in GHC.Core).+Consequently, we give the wrapper the simpler, less polymorphic type++    mkWeakNoFinalizer# :: forall (k :: Type) (v :: Type).+                          k -> v+                       -> State# RealWorld+                       -> (# State# RealWorld, Weak# v #)++This simplification tends to be good enough for GHCi uses given that there are+few representation-polymorphic primops, and we do little simplification+on interpreted code anyways.++TODO: This behavior is actually wrong; a program becomes ill-typed upon+replacing a real primop occurrence with one of its wrapper due to the fact that+the former has an additional type binder. Hmmm....++Note [Eta expanding primops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++STG requires that primop applications be saturated. This makes code generation+significantly simpler since otherwise we would need to define a calling+convention for curried applications that can accommodate representation+polymorphism.++To ensure saturation, CorePrep eta expands all primop applications as+described in Note [Eta expansion of hasNoBinding things in CorePrep] in+GHC.Core.Prep.++Historical Note:++For a short period around GHC 8.8 we rewrote unsaturated primop applications to+rather use the primop's wrapper (see Note [Primop wrappers] in+GHC.Builtin.PrimOps) instead of eta expansion. This was because at the time+CoreTidy would try to predict the CAFfyness of bindings that would be produced+by CorePrep for inclusion in interface files. Eta expanding during CorePrep+proved to be very difficult to predict, leading to nasty inconsistencies in+CAFfyness determinations (see #16846).++Thankfully, we now no longer try to predict CAFfyness but rather compute it on+GHC STG (see Note [SRTs] in GHC.Cmm.Info.Build) and inject it into the interface+file after code generation (see TODO: Refer to whatever falls out of #18096).+This is much simpler and avoids the potential for inconsistency, allowing us to+return to the somewhat simpler eta expansion approach for unsaturated primops.++See #18079.+-}++-- | Returns the 'Id' of the wrapper associated with the given 'PrimOp'.+-- See Note [Primop wrappers].+primOpWrapperId :: PrimOp -> Id+primOpWrapperId op = mkVanillaGlobalWithInfo name ty info+  where+    info = setCafInfo vanillaIdInfo NoCafRefs+    name = mkExternalName uniq gHC_PRIMOPWRAPPERS (primOpOcc op) wiredInSrcSpan+    uniq = mkPrimOpWrapperUnique (primOpTag op)+    ty   = primOpType op++isComparisonPrimOp :: PrimOp -> Bool+isComparisonPrimOp op = case primOpInfo op of+                          Compare {}   -> True+                          GenPrimOp {} -> False++-- primOpSig is like primOpType but gives the result split apart:+-- (type variables, argument types, result type)+-- It also gives arity, strictness info++primOpSig :: PrimOp -> ([TyVarBinder], [Type], Type, Arity, DmdSig)+primOpSig op+  = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity)+  where+    arity = length arg_tys+    (tyvars, arg_tys, res_ty)+      = case (primOpInfo op) of+        Compare   _occ ty                    -> ([],     [ty,ty], intPrimTy)+        GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )++data PrimOpResultInfo+  = ReturnsVoid+  | ReturnsPrim     PrimRep+  | ReturnsTuple++-- Some PrimOps need not return a manifest primitive or algebraic value+-- (i.e. they might return a polymorphic value).  These PrimOps *must*+-- be out of line, or the code generator won't work.++getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo+getPrimOpResultInfo op+  = case (primOpInfo op) of+      Compare _ _                         -> ReturnsPrim IntRep+      GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of+                                               [] -> ReturnsVoid+                                               [rep] -> ReturnsPrim rep+                                               _ -> pprPanic "getPrimOpResultInfo" (ppr op)+                         | isUnboxedTupleTyCon tc -> ReturnsTuple+                         | otherwise      -> pprPanic "getPrimOpResultInfo" (ppr op)+                         where+                           tc = tyConAppTyCon ty+                        -- All primops return a tycon-app result+                        -- The tycon can be an unboxed tuple or sum, though,+                        -- which gives rise to a ReturnAlg++{-+We do not currently make use of whether primops are commutable.++We used to try to move constants to the right hand side for strength+reduction.+-}++{-+commutableOp :: PrimOp -> Bool+#include "primop-commutable.hs-incl"+-}++-- Utils:++compare_fun_ty :: Type -> Type+compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy++-- Output stuff:++pprPrimOp  :: IsLine doc => PrimOp -> doc+pprPrimOp other_op = pprOccName (primOpOcc other_op)+{-# SPECIALIZE pprPrimOp :: PrimOp -> SDoc #-}+{-# SPECIALIZE pprPrimOp :: PrimOp -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++{-+************************************************************************+*                                                                      *+\subsubsection[PrimCall]{User-imported primitive calls}+*                                                                      *+************************************************************************+-}++data PrimCall = PrimCall CLabelString Unit++instance Outputable PrimCall where+  ppr (PrimCall lbl pkgId)+        = text "__primcall" <+> ppr pkgId <+> ppr lbl++-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it+-- isn't DataToTagOp which are two primops that evaluate their argument+-- hence induce thread/stack/heap changes.+primOpIsReallyInline :: PrimOp -> Bool+primOpIsReallyInline = \case+  DataToTagSmallOp -> False+  DataToTagLargeOp -> False+  p                -> not (primOpOutOfLine p)
+ GHC/Builtin/PrimOps.hs-boot view
@@ -0,0 +1,6 @@+module GHC.Builtin.PrimOps where++-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()++data PrimOp
+ GHC/Builtin/PrimOps/Casts.hs view
@@ -0,0 +1,211 @@+{-+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.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
+ GHC/Builtin/PrimOps/Ids.hs view
@@ -0,0 +1,175 @@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}++-- | PrimOp's Ids+module GHC.Builtin.PrimOps.Ids+  ( primOpId+  , allThePrimOpIds+  )+where++import GHC.Prelude++-- primop rules are attached to primop ids+import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)+import GHC.Core.TyCo.Rep ( scaledThing )+import GHC.Core.Type+import GHC.Core.Predicate( tyCoVarsOfTypeWellScoped )+import GHC.Core.FVs (mkRuleInfo)++import GHC.Builtin.PrimOps+import GHC.Builtin.Uniques+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim++import GHC.Types.Basic+import GHC.Types.Cpr+import GHC.Types.Demand+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.TyThing+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Set++import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType )++import GHC.Data.SmallArray++import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList )+++-- | Build a PrimOp Id+mkPrimOpId :: PrimOp -> Id+mkPrimOpId prim_op+  = id+  where+    (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op+    ty   = mkForAllTys tyvars (mkVisFunTysMany arg_tys res_ty)+    name = mkWiredInName gHC_PRIM (primOpOcc prim_op)+                         (mkPrimOpIdUnique (primOpTag prim_op))+                         (AnId id) UserSyntax+    id   = mkGlobalId (PrimOpId prim_op conc_tvs) name ty info++    conc_tvs = computePrimOpConcTyVarsFromType name tyvars arg_tys res_ty++    -- PrimOps don't ever construct a product, but we want to preserve bottoms+    cpr+      | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr+      | otherwise                                   = topCpr++    info = noCafIdInfo+           `setRuleInfo`           mkRuleInfo (maybeToList $ primOpRules name prim_op)+           `setArityInfo`          arity+           `setDmdSigInfo`         strict_sig+           `setCprSigInfo`         mkCprSig arity cpr+           `setInlinePragInfo`     neverInlinePragma+               -- We give PrimOps a NOINLINE pragma so that we don't+               -- get silly warnings from Desugar.dsRule (the inline_shadows_rule+               -- test) about a RULE conflicting with a possible inlining+               -- cf #7287++-- | Analyse the type of a primop to determine which of its outermost forall'd+-- type variables must be instantiated to concrete types when the primop is+-- instantiated.+--+-- These are the Levity and RuntimeRep kinded type-variables which appear in+-- negative position in the type of the primop.+computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars+computePrimOpConcTyVarsFromType nm tyvars arg_tys _res_ty = mkNameEnv concs+  where+    concs = [ (tyVarName kind_tv, ConcreteFRR frr_orig)+            | Bndr tv _af <- tyvars+            , kind_tv    <- tyCoVarsOfTypeWellScoped $ tyVarKind tv+            , neg_pos    <- maybeToList $ frr_tyvar_maybe kind_tv+            , let frr_orig = FixedRuntimeRepOrigin+                           { frr_type    = mkTyVarTy tv+                           , frr_context = FRRRepPolyId nm RepPolyPrimOp neg_pos+                           }+            ]++    -- As per Note [Levity and representation polymorphic primops]+    -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated+    -- to a primop by inspecting the type variable names.+    frr_tyvar_maybe tv+      | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar+                  , levity1TyVar, levity2TyVar ]+      = listToMaybe $+          mapMaybe (\ (i,arg) -> mkArgPos i <$> positiveKindPos_maybe tv arg)+            (zip [1..] arg_tys)+      | otherwise+      = Nothing+      -- Compute whether the type variable occurs in the kind of a type variable+      -- in positive position in one of the argument types of the primop.++-- | Does this type variable appear in a kind in a negative position in the+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg)+negativeKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then Nothing else Result <$> negativeKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, scaled_ty)+      = mkArgPos pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty)+    -- (assumes we don't have any function types nested inside other types)++-- | Does this type variable appear in a kind in a positive position in the+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos)+positiveKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then finish res else Result <$> positiveKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, scaled_ty)+      = mkArgPos pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty)+    -- (assumes we don't have any function types nested inside other types)+    finish ty+      | tv `elemVarSet` tyCoVarsOfType (typeKind ty)+      = Just Top+      | otherwise+      = Nothing++-------------------------------------------------------------+-- Cache of PrimOp's Ids+-------------------------------------------------------------++-- | A cache of the PrimOp Ids, indexed by PrimOp tag (0 indexed)+primOpIds :: SmallArray Id+{-# NOINLINE primOpIds #-}+primOpIds = listToArray (maxPrimOpTag+1) primOpTag mkPrimOpId allThePrimOps++-- | Get primop id.+--+-- Retrieve it from `primOpIds` cache.+primOpId :: PrimOp -> Id+{-# INLINE primOpId #-}+primOpId op = indexSmallArray primOpIds (primOpTag op)++-- | All the primop ids, as a list+allThePrimOpIds :: [Id]+{-# INLINE allThePrimOpIds #-}+allThePrimOpIds = map (indexSmallArray primOpIds) [0..maxPrimOpTag]
+ GHC/Builtin/Types.hs view
@@ -0,0 +1,2948 @@+{-+(c) The GRASP Project, Glasgow University, 1994-1998++Wired-in knowledge about {\em non-primitive} types+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module is about types that can be defined in Haskell, but which+--   must be wired into the compiler nonetheless.  C.f module "GHC.Builtin.Types.Prim"+module GHC.Builtin.Types (+        -- * Helper functions defined here+        mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the+                            -- built-in functions for evaluation.++        mkWiredInIdName,    -- used in GHC.Types.Id.Make++        -- * All wired in things+        wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe,+        isTupleTyOrigName_maybe, isSumTyOrigName_maybe,+        isInfiniteFamilyOrigName_maybe,++        -- * Bool+        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,+        trueDataCon,  trueDataConId,  true_RDR,+        falseDataCon, falseDataConId, false_RDR,+        promotedFalseDataCon, promotedTrueDataCon,++        -- * Ordering+        orderingTyCon,+        ordLTDataCon, ordLTDataConId,+        ordEQDataCon, ordEQDataConId,+        ordGTDataCon, ordGTDataConId,+        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,++        -- * Boxing primitive types+        boxingDataCon, BoxingInfo(..),++        -- * Char+        charTyCon, charDataCon, charTyCon_RDR,+        charTy, stringTy, charTyConName, stringTyCon_RDR,++        -- * Double+        doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,++        -- * Float+        floatTyCon, floatDataCon, floatTy, floatTyConName,++        -- * Int+        intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,+        intTy,++        -- * Word+        wordTyCon, wordDataCon, wordTyConName, wordTy,++        -- * Word8+        word8TyCon, word8DataCon, word8Ty,++        -- * List+        listTyCon, listTyCon_RDR, listTyConName, listTyConKey,+        nilDataCon, nilDataConName, nilDataConKey,+        consDataCon_RDR, consDataCon, consDataConName,+        promotedNilDataCon, promotedConsDataCon,+        mkListTy, mkPromotedListTy, extractPromotedList,++        -- * Maybe+        maybeTyCon, maybeTyConName,+        nothingDataCon, nothingDataConName, promotedNothingDataCon,+        justDataCon, justDataConName, promotedJustDataCon,+        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,++        -- * Tuples+        mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,+        tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,+        promotedTupleDataCon,+        unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,+        soloTyCon,+        soloDataConName,+        pairTyCon, mkPromotedPairTy, isPromotedPairType,+        unboxedUnitTy,+        unboxedUnitTyCon, unboxedUnitDataCon,+        unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName,+        unboxedTupleKind, unboxedSumKind,+        mkConstraintTupleTy,++        -- ** Constraint tuples+        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,+        cTupleDataCon, cTupleDataConName, cTupleDataConNames,+        cTupleSelId, cTupleSelIdName,++        -- * Any+        anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,++        -- * Recovery TyCon+        makeRecoveryTyCon,++        -- * Sums+        mkSumTy, sumTyCon, sumDataCon,+        unboxedSumTyConName, unboxedSumDataConName,++        -- * Kinds+        typeSymbolKindCon, typeSymbolKind,+        isLiftedTypeKindTyConName,+        typeToTypeKind,+        liftedRepTyCon, unliftedRepTyCon,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,+        constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,+        constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,+        constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,+        liftedRepTyConName, unliftedRepTyConName,++        -- * Equality predicates+        heqTyCon, heqTyConName, heqClass, heqDataCon,+        eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,+        coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,++        -- * RuntimeRep and friends+        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,++        boxedRepDataConTyCon,+        runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,++        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,++        -- * Levity+        levityTyCon, levityTy,+        liftedDataConTyCon, unliftedDataConTyCon,+        liftedDataConTy,    unliftedDataConTy,++        intRepDataConTy,+        int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+        wordRepDataConTy,+        word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+        addrRepDataConTy,+        floatRepDataConTy, doubleRepDataConTy,++        vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+        vec64DataConTy,++        int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+        int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+        word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,++        doubleElemRepDataConTy,++        -- * Multiplicity and friends+        multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,+        multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,+        oneDataConTyCon, manyDataConTyCon,+        multMulTyCon,++        unrestrictedFunTyCon, unrestrictedFunTyConName,++        -- * Bignum+        integerTy, integerTyCon, integerTyConName,+        integerISDataCon, integerISDataConName,+        integerIPDataCon, integerIPDataConName,+        integerINDataCon, integerINDataConName,+        naturalTy, naturalTyCon, naturalTyConName,+        naturalNSDataCon, naturalNSDataConName,+        naturalNBDataCon, naturalNBDataConName,++         pretendNameIsInScope,+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )++-- friends:+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Uniques++-- others:+import GHC.Core( Expr(Type), mkConApp )+import GHC.Core.Coercion.Axiom+import GHC.Core.Type+import GHC.Types.Id+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Class     ( Class, mkClass )+import GHC.Core.Map.Type  ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )+import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) )++import GHC.Types.TyThing+import GHC.Types.SourceText+import GHC.Types.Var ( VarBndr (Bndr), tyVarName )+import GHC.Types.RepType+import GHC.Types.Name.Reader+import GHC.Types.Name as Name+import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv )+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique.Set++import {-# SOURCE #-} GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum )+import {-# SOURCE #-} GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars )++import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )+import GHC.Unit.Module        ( Module )++import Data.Maybe+import Data.Array+import GHC.Data.FastString+import GHC.Data.BooleanFormula ( mkAnd )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex)++import Data.Foldable+import Data.List        ( intersperse )+import Numeric          ( showInt )++import Data.Word (Word8)+import Control.Applicative ((<|>))++alpha_tyvar :: [TyVar]+alpha_tyvar = [alphaTyVar]++alpha_ty :: [Type]+alpha_ty = [alphaTy]++{-+Note [Wired-in Types and Type Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This module include a lot of wired-in types and type constructors. Here,+these are presented in a tabular format to make it easier to find the+wired-in type identifier corresponding to a known Haskell type. Data+constructors are nested under their corresponding types with two spaces+of indentation.++Identifier              Type    Haskell name          Notes+----------------------------------------------------------------------------+liftedTypeKindTyCon     TyCon   GHC.Types.Type        Synonym for: TYPE LiftedRep+unliftedTypeKindTyCon   TyCon   GHC.Types.Type        Synonym for: TYPE UnliftedRep+liftedRepTyCon          TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Lifted+unliftedRepTyCon        TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Unlifted+levityTyCon             TyCon   GHC.Types.Levity      Data type+  liftedDataConTyCon    TyCon   GHC.Types.Lifted      Data constructor+  unliftedDataConTyCon  TyCon   GHC.Types.Unlifted    Data constructor+vecCountTyCon           TyCon   GHC.Types.VecCount    Data type+  vec2DataConTy         Type    GHC.Types.Vec2        Data constructor+  vec4DataConTy         Type    GHC.Types.Vec4        Data constructor+  vec8DataConTy         Type    GHC.Types.Vec8        Data constructor+  vec16DataConTy        Type    GHC.Types.Vec16       Data constructor+  vec32DataConTy        Type    GHC.Types.Vec32       Data constructor+  vec64DataConTy        Type    GHC.Types.Vec64       Data constructor+runtimeRepTyCon         TyCon   GHC.Types.RuntimeRep  Data type+  boxedRepDataConTyCon  TyCon   GHC.Types.BoxedRep    Data constructor+  intRepDataConTy       Type    GHC.Types.IntRep      Data constructor+  doubleRepDataConTy    Type    GHC.Types.DoubleRep   Data constructor+  floatRepDataConTy     Type    GHC.Types.FloatRep    Data constructor+boolTyCon               TyCon   GHC.Types.Bool        Data type+  trueDataCon           DataCon GHC.Types.True        Data constructor+  falseDataCon          DataCon GHC.Types.False       Data constructor+  promotedTrueDataCon   TyCon   GHC.Types.True        Data constructor+  promotedFalseDataCon  TyCon   GHC.Types.False       Data constructor++************************************************************************+*                                                                      *+\subsection{Wired in type constructors}+*                                                                      *+************************************************************************++If you change which things are wired in, make sure you change their+names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc++-}+++-- This list is used only to define GHC.Builtin.Utils.knownKeyNames. That in turn+-- is used to initialise the name environment carried around by the renamer.+-- This means that if we look up the name of a TyCon (or its implicit binders)+-- that occurs in this list that name will be assigned the wired-in key we+-- define here.+--+-- Because of their infinite nature, this list excludes+--   * Tuples of all sorts (boxed, unboxed, constraint) (mkTupleTyCon)+--   * Unboxed sums (sumTyCon)+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names+--+-- See also Note [Known-key names]+wiredInTyCons :: [TyCon]++wiredInTyCons = map (dataConTyCon . snd) boxingDataCons+             ++ [ anyTyCon+                , zonkAnyTyCon+                , boolTyCon+                , charTyCon+                , stringTyCon+                , doubleTyCon+                , floatTyCon+                , intTyCon+                , wordTyCon+                , listTyCon+                , orderingTyCon+                , maybeTyCon+                , heqTyCon+                , eqTyCon+                , coercibleTyCon+                , typeSymbolKindCon+                , runtimeRepTyCon+                , levityTyCon+                , vecCountTyCon+                , vecElemTyCon+                , constraintKindTyCon+                , liftedTypeKindTyCon+                , unliftedTypeKindTyCon+                , unrestrictedFunTyCon+                , multiplicityTyCon+                , naturalTyCon+                , integerTyCon+                , liftedRepTyCon+                , unliftedRepTyCon+                , zeroBitRepTyCon+                , zeroBitTypeTyCon+                ]++mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name+mkWiredInTyConName built_in modu fs unique tycon+  = mkWiredInName modu (mkTcOccFS fs) unique+                  (ATyCon tycon)        -- Relevant TyCon+                  built_in++mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name+mkWiredInDataConName built_in modu fs unique datacon+  = mkWiredInName modu (mkDataOccFS fs) unique+                  (AConLike (RealDataCon datacon))    -- Relevant DataCon+                  built_in++mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name+mkWiredInIdName mod fs uniq id+ = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+eqTyConName, eqDataConName, eqSCSelIdName :: Name+eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConKey   eqTyCon+eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon+eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId++eqTyCon_RDR :: RdrName+eqTyCon_RDR = nameRdrName eqTyConName++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+heqTyConName, heqDataConName, heqSCSelIdName :: Name+heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId++-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs+coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name+coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon+coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId++charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name+charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char")   charTyConKey charTyCon+charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#")     charDataConKey charDataCon+stringTyConName   = mkWiredInTyConName   UserSyntax gHC_INTERNAL_BASE  (fsLit "String") stringTyConKey stringTyCon+intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int")    intTyConKey   intTyCon+intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#")     intDataConKey  intDataCon++boolTyConName, falseDataConName, trueDataConName :: Name+boolTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon+falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon+trueDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon++listTyConName, nilDataConName, consDataConName :: Name+listTyConName     = mkWiredInTyConName   UserSyntax    gHC_TYPES (fsLit "List") listTyConKey listTyCon+nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon+consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon++maybeTyConName, nothingDataConName, justDataConName :: Name+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe")+                                          maybeTyConKey maybeTyCon+nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing")+                                          nothingDataConKey nothingDataCon+justDataConName    = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just")+                                          justDataConKey justDataCon++wordTyConName, wordDataConName, word8DataConName :: Name+wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon+wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon+word8DataConName   = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon++floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name+floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon+floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")     floatDataConKey  floatDataCon+doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon+doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon++-- Any++{-+Note [Any types]+~~~~~~~~~~~~~~~~+The type constructors `Any` and `ZonkAny` are closed type families declared thus:++    type family Any     :: forall k.        k where { }+    type family ZonkAny :: forall k. Nat -> k where { }++They are used when we want a type of a particular kind, but we don't really care+what that type is.  The leading example is this: `ZonkAny` is used to instantiate+un-constrained type variables after type checking. For example, consider the+term (length [] :: Int), where++  length :: forall a. [a] -> Int+  []     :: forall a. [a]++We must type-apply `length` and `[]`, but to what type? It doesn't matter!+The typechecker will end up with++  length @alpha ([] @alpha)++where `alpha` is an un-constrained unification variable.  The "zonking" process zaps+that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is+arbitrary (see wrinkle (Any5) below).  This is done in `GHC.Tc.Zonk.Type.commitFlexi`.+So we end up with++  length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))++`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see+wrinkle (Any4).++Wrinkles:++(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may+   need to use `ZonkAny` to fill in a type variable of some kind other than *+   (see #959 for examples).++(Any2) They are /closed/ type families, with no instances.  For example, suppose that+   with  alpha :: '(k1, k2)  we add a given coercion+             g :: alpha ~ (Fst alpha, Snd alpha)+   and we zonked alpha = ZonkAny @(k1,k2) n.  Then, if `ZonkAny` was a /data/ type,+   we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one+   side and '(,) on the other. See also #9097 and #9636.++   See #25244 for a suggestion that we instead use an /open/ type family for which+   you cannot provide instances.  Probably the difference is not very important.++(Any3) They do not claim to be /data/ types, and that's important for+   the code generator, because the code gen may /enter/ a data value+   but never enters a function value.++(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/+   types (#24817).  Consider++     data SBool a where { STrue :: SBool True; SFalse :: SBool False }++     foo :: forall a b. (SBool a, SBool b)++     bar :: Bool+     bar = case foo @alpha @beta of+             (STrue, SFalse) -> True   -- This branch is not inaccessible!+             _               -> False++   Now, what are `alpha` and `beta`? If we zonk both of them to the same type+   `Any @Type`, the pattern-match checker will (wrongly) report that the first+   branch is inaccessible.  So we zonk them to two /different/ types:+       alpha :=  ZonkAny @Type 4   and   beta :=  ZonkAny @Type k 5+   (The actual numbers are arbitrary; they just need to differ.)++   The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and+   `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to+   make up a fresh type.++   If this example seems unconvincing (e.g. in this case foo must be bottom)+   see #24817 for larger but more compelling examples.++(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we+    don't have a name environment (e.g. see Rules.matchRule for one example)++(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that+    it is available to users.  For this reason it's treated like any other+    wired-in type:+      - has a fixed unique, anyTyConKey,+      - lives in the global name cache+    Currently `ZonkAny` is not available to users; but it could easily be.++(Any7) Properties of `Any`:+  * When `Any` is instantiated at a lifted type it is inhabited by at least one value,+    namely bottom.++  * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`.++  * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`.++  * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when+    the kinds of both the type and `Any` match.++  * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over+    `unsafeCoerce#` as they prevent accidentally coercing between types with kinds+    that don't match.++    See examples in ghc-prim:GHC.Types++(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,+    following the same rationale of supressing warning about the unit type.++    For example, consider (#25895):++     do { forever (return ()); blah }++    where forever :: forall a b. IO a -> IO b+    Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.+    But we certainly don't want to complain about a discarded do-binding.++The Any tycon used to be quite magic, but we have since been able to+implement it merely with an empty kind polymorphic type family. See #10886 for a+bit of history.+-}+++anyTyConName :: Name+anyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon++anyTyCon :: TyCon+-- See Note [Any types]+anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]+    res_kind = mkTyVarTy (binderVar kv)++anyTy :: Type+anyTy = mkTyConTy anyTyCon++anyTypeOfKind :: Kind -> Type+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]++zonkAnyTyConName :: Name+zonkAnyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon++zonkAnyTyCon :: TyCon+-- ZonkAnyTyCon :: forall k. Nat -> k+-- See Note [Any types]+zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName+                         [ mkNamedTyConBinder Specified kv+                         , mkAnonTyConBinder nat_kv ]+                         (mkTyVarTy kv)+                         Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]++-- | Make a fake, recovery 'TyCon' from an existing one.+-- Used when recovering from errors in type declarations+makeRecoveryTyCon :: TyCon -> TyCon+makeRecoveryTyCon tc+  = mkTcTyCon (tyConName tc)+              bndrs res_kind+              noTcTyConScopedTyVars+              True             -- Fully generalised+              flavour          -- Keep old flavour+  where+    flavour = tyConFlavour tc+    [kv] = mkTemplateKindVars [liftedTypeKind]+    (bndrs, res_kind)+       = case flavour of+           PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)+           _ -> (tyConBinders tc, tyConResKind tc)+        -- For data types we have already validated their kind, so it+        -- makes sense to keep it. For promoted data constructors we haven't,+        -- so we recover with kind (forall k. k).  Otherwise consider+        --     data T a where { MkT :: Show a => T a }+        -- If T is for some reason invalid, we don't want to fall over+        -- at (promoted) use-sites of MkT.++-- Kinds+typeSymbolKindConName :: Name+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon+++boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName+boolTyCon_RDR   = nameRdrName boolTyConName+false_RDR       = nameRdrName falseDataConName+true_RDR        = nameRdrName trueDataConName+intTyCon_RDR    = nameRdrName intTyConName+charTyCon_RDR   = nameRdrName charTyConName+stringTyCon_RDR = nameRdrName stringTyConName+intDataCon_RDR  = nameRdrName intDataConName+listTyCon_RDR   = nameRdrName listTyConName+consDataCon_RDR = nameRdrName consDataConName++{-+************************************************************************+*                                                                      *+\subsection{mkWiredInTyCon}+*                                                                      *+************************************************************************+-}++-- This function assumes that the types it creates have all parameters at+-- Representational role, and that there is no kind polymorphism.+pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon+pcTyCon name cType tyvars cons+  = mkAlgTyCon name+                (mkAnonTyConBinders tyvars)+                liftedTypeKind+                (map (const Representational) tyvars)+                cType+                []              -- No stupid theta+                (mkDataTyConRhs cons)+                (VanillaAlgTyCon (mkPrelTyConRepName name))+                False           -- Not in GADT syntax++pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon+pcDataCon n univs tys+  = pcRepPolyDataCon n univs noConcreteTyVars tys++pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars+                 -> [Type] -> TyCon -> DataCon+pcRepPolyDataCon n univs conc_tvs tys+  = pcDataConWithFixity False n+      univs+      []    -- no ex_tvs+      conc_tvs+      univs -- the univs are precisely the user-written tyvars+      []    -- No theta+      (map linear tys)++pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon+-- Used for data constructors whose arguments are all constraints.+-- Notably constraint tuples, Eq# etc.+pcDataConConstraint n univs theta+  = pcDataConWithFixity False n+      univs+      []           -- No ex_tvs+      noConcreteTyVars+      univs        -- The univs are precisely the user-written tyvars+      theta        -- All constraint arguments+      []           -- No value arguments++-- Used for RuntimeRep and friends; things with PromDataConInfo+pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon+pcSpecialDataCon dc_name arg_tys tycon rri+  = pcDataConWithFixity' False dc_name+                         (dataConWorkerUnique (nameUnique dc_name)) rri+                         [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon++pcDataConWithFixity :: Bool      -- ^ declared infix?+                    -> Name      -- ^ datacon name+                    -> [TyVar]   -- ^ univ tyvars+                    -> [TyCoVar] -- ^ ex tycovars+                    -> ConcreteTyVars+                                 -- ^ concrete tyvars+                    -> [TyCoVar] -- ^ user-written tycovars+                    -> ThetaType+                    -> [Scaled Type]    -- ^ args+                    -> TyCon+                    -> DataCon+pcDataConWithFixity infx n = pcDataConWithFixity' infx n+                                 (dataConWorkerUnique (nameUnique n)) NoPromInfo+-- The Name's unique is the first of two free uniques;+-- the first is used for the datacon itself,+-- the second is used for the "worker name"+--+-- To support this the mkPreludeDataConUnique function "allocates"+-- one DataCon unique per pair of Ints.++pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo+                     -> [TyVar] -> [TyCoVar]+                     -> ConcreteTyVars+                     -> [TyCoVar]+                     -> ThetaType -> [Scaled Type] -> TyCon -> DataCon+-- The Name should be in the DataName name space; it's the name+-- of the DataCon itself.+--+-- IMPORTANT NOTE:+--    if you try to wire-in a /GADT/ data constructor you will+--    find it hard (we did).  You will need wrapper and worker+--    Names, a DataConBoxer, DataConRep, EqSpec, etc.+--    Try hard not to wire-in GADT data types. You will live+--    to regret doing so (we do).++pcDataConWithFixity' declared_infix dc_name wrk_key rri+                     tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon+  = data_con+  where+    tag_map = mkTyConTagMap tycon+    -- This constructs the constructor Name to ConTag map once per+    -- constructor, which is quadratic. It's OK here, because it's+    -- only called for wired in data types that don't have a lot of+    -- constructors. It's also likely that GHC will lift tag_map, since+    -- we call pcDataConWithFixity' with static TyCons in the same module.+    -- See Note [Constructor tag allocation] and #14657+    data_con = mkDataCon dc_name declared_infix prom_info+                (map (const no_bang) arg_tys)+                (map (const HsLazy) arg_tys)+                (map (const NotMarkedStrict) arg_tys)+                []      -- No labelled fields+                tyvars ex_tyvars+                conc_tyvars+                (mkTyVarBinders Specified user_tyvars)+                []      -- No equality spec+                theta+                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))+                rri+                tycon+                (lookupNameEnv_NF tag_map dc_name)+                []      -- No stupid theta+                (mkDataConWorkId wrk_name data_con)+                NoDataConRep    -- Wired-in types are too simple to need wrappers++    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    wrk_name = mkDataConWorkerName data_con wrk_key++    prom_info = mkPrelTyConRepName dc_name++mkDataConWorkerName :: DataCon -> Unique -> Name+mkDataConWorkerName data_con wrk_key =+    mkWiredInName modu wrk_occ wrk_key+                  (AnId (dataConWorkId data_con)) UserSyntax+  where+    modu     = assert (isExternalName dc_name) $+               nameModule dc_name+    dc_name = dataConName data_con+    dc_occ  = nameOccName dc_name+    wrk_occ = mkDataConWorkerOcc dc_occ+++{-+************************************************************************+*                                                                      *+              Symbol+*                                                                      *+************************************************************************+-}++typeSymbolKindCon :: TyCon+-- data Symbol+typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []++typeSymbolKind :: Kind+typeSymbolKind = mkTyConTy typeSymbolKindCon+++{-+************************************************************************+*                                                                      *+                Stuff for dealing with tuples+*                                                                      *+************************************************************************++Note [How tuples work]+~~~~~~~~~~~~~~~~~~~~~~+* There are three families of tuple TyCons and corresponding+  DataCons, expressed by the type BasicTypes.TupleSort:+    data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple++* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon++* BoxedTuples+    - A wired-in type+    - Data type declarations in GHC.Tuple+    - The data constructors really have an info table++* UnboxedTuples+    - A wired-in type+    - Data type declarations in GHC.Types+      but no actual declaration and no info table++* ConstraintTuples+    - A wired-in type.+    - Declared as classes in GHC.Classes, e.g.+         class (c1,c2) => CTuple2 c1 c2+    - Given constraints: the superclasses automatically become available+    - Wanted constraints: there is a built-in instance+         instance (c1,c2) => CTuple2 c1 c2+      See GHC.Tc.Instance.Class.matchCTuple+    - Currently just go up to 64; beyond that+      you have to use manual nesting+    - Unlike BoxedTuples and UnboxedTuples, which only wire+      in type constructors and data constructors, ConstraintTuples also wire in+      superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are+      the selectors for the binary constraint tuple.+    - The parenthesis syntax for grouping constraints in contexts is not treated+      as a constraint tuple. The parser starts with a tuple type, then a+      postprocessing action extracts the individual constraints as a list and+      stores them in the context field of types like HsQualTy.++* In quite a lot of places things are restricted just to+  BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish+  E.g. tupleTyCon has a Boxity argument++* When looking up an OccName in the original-name cache+  (GHC.Types.Name.Cache.lookupOrigNameCache), we spot the tuple OccName to make+  sure we get the right wired-in name.++* Serialization to interface files works via the usual mechanism for known-key+  things: instead of serializing the OccName we just serialize the key. During+  deserialization we lookup the Name associated with the unique with the logic+  in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details.++See also Note [Known-key names] in GHC.Builtin.Names.++Note [One-tuples]+~~~~~~~~~~~~~~~~~+GHC supports both boxed and unboxed one-tuples:+ - Unboxed one-tuples are sometimes useful when returning a+   single value after CPR analysis+ - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when+   there is just one binder+Basically it keeps everything uniform.++However the /naming/ of the type/data constructors for one-tuples is a+bit odd:+  3-tuples:  Tuple3   (,,)#+  2-tuples:  Tuple2   (,)#+  1-tuples:  ??+  0-tuples:  Unit     ()#++Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#'+for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:+  data Unit = ()+  data Solo a = MkSolo a+  data Tuple2 a b = (a,b)++There is no way to write a boxed one-tuple in Haskell using tuple syntax.+They can, however, be written using other methods:++1. They can be written directly by importing them from GHC.Tuple.+2. They can be generated by way of Template Haskell or in `deriving` code.++There is nothing special about one-tuples in Core; in particular, they have no+custom pretty-printing, just using `Solo`.++See also Note [Flattening one-tuples] in GHC.Core.Make and+Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.++Note [isBuiltInOcc_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~+`isBuiltInOcc_maybe` matches and resolves names that are occurrences of built-in+syntax, i.e. unqualified names that can be unambiguously resolved even without+knowing what's currently in scope (such names also can't be imported, exported,+or redefined in another module).+More on that in Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache.++In GHC, there are two use cases for `isBuiltInOcc_maybe`:++1. Making TH's `mkName` work with built-in syntax,+   e.g. $(conT (mkName "[]")) is the same as []++2. Detecting bulit-in syntax in `infix` declarations,+   e.g. users can't write `infixl 6 :` (#15233)++The parser takes a shortcut and produces Exact RdrNames directly,+so it doesn't need to match on an OccName with isBuiltInOcc_maybe.++And here are the properties of `isBuiltInOcc_maybe`:++* The set of names recognized by `isBuiltInOcc_maybe` is essentialy the+  same as the set of names that the parser resolves to Exact RdrNames,+  e.g. "[]", "(,)", or "->".++  We could leave it at that, but we also recognize unboxed sum syntax+  "(#|#)" even though the parser can't handle it. This makes TH's `mkName`+  more permissive than the parser.++* The namespace of the input OccName is treated as a hint, not a+  requirement. For example,++    mkOccName dataName  ":"          maps to  consDataConName+    mkOccName tcClsName ":"   /also/ maps to  consDataConName++  The rationale behind this is that with DataKind or RequiredTypeArguments+  we may get an OccName with the wrong namespace and need to fallback to the+  other one.++* There is a `listTuplePuns :: Bool` parameter to account for the+  ListTuplePuns extension. It has /no/ effect on whether the predicate+  matches (i.e. if the result is Just or Nothing), but it can influence+  which name is returned (TyCon name or DataCon name). For example,++    isBuiltInOcc_maybe False (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe False (mkOccName tcClsName "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName tcClsName "[]")  ==  Just listTyConName++* There is no `Module` parameter because we are matching unqualified+  occurrences of built-in names. It is illegal to qualify built-in syntax,+  e.g. GHC.Types.(,) is a parse error.++* The /input/ to `isBuiltInOcc_maybe` needs to be built-in syntax for the+  predicate to match, but the /output/ is not necessarily built-in syntax.+  For example,++    1) input:   mkTcOcc "[]"          -- built-in syntax+       output:  Just listTyConName    -- user syntax (GHC.Types.List)++    2) input:   mkDataOcc "[]"        -- built-in syntax+       output:  Just nilDataConName   -- built-in syntax []++    3) input:   mkTcOcc "List"        -- user syntax+       output:  Nothing               -- no match++    4) input:   mkTcOcc "(,)"                       -- built-in syntax+       output:  Just (tupleTyConName BoxedTuple 2)  -- user syntax (GHC.Types.Tuple2)++    5) input:   mkTcOcc "(#|#)"               -- built-in syntax+       output:  Just (unboxedSumTyConName 2)  -- user syntax (GHC.Types.Sum2#)++  Therefore, `GHC.Types.Name.isBuiltInSyntax` may or may not hold for the name+  returned by `isBuiltInOcc_maybe`.+-}++-- | Match on built-in syntax as it occurs at use sites.+-- See Note [isBuiltInOcc_maybe]+isBuiltInOcc_maybe :: Bool -> OccName -> Maybe Name+isBuiltInOcc_maybe listTuplePuns occ+  | fs == "->" = Just unrestrictedFunTyConName+  | fs == "[]" = Just (pun listTyConName nilDataConName)+  | fs == ":"  = Just consDataConName+  | Just n <- (is_boxed_tup_syntax fs) = Just (tup_name Boxed n)+  | Just n <- (is_unboxed_tup_syntax fs) = Just (tup_name Unboxed n)+  | Just n <- (is_unboxed_sum_type_syntax fs) = Just (unboxedSumTyConName n)+  | Just (k, n) <- (is_unboxed_sum_data_syntax fs) = Just (unboxedSumDataConName k n)+  | otherwise = Nothing+  where+    fs = occNameFS occ+    ns = occNameSpace occ++    pun :: Name -> Name -> Name+    pun p n+      | listTuplePuns, isTcClsNameSpace ns = p+      | otherwise = n++    tup_name :: Boxity -> Arity -> Name+    tup_name boxity arity+      = pun (tyConName   (tupleTyCon   boxity arity))+            (dataConName (tupleDataCon boxity arity))++-- | Check if the OccName is an occurrence of built-in syntax.+--+-- This is a variant of `isBuiltInOcc_maybe` that returns a `Bool`.+-- See Note [isBuiltInOcc_maybe]+--+-- `isBuiltInOcc` holds for:+--   * function arrow `->`+--   * list syntax `[]`, `:`+--   * boxed tuple syntax `()`, `(,)`, `(,,)`, `(,,,)`, ...+--   * unboxed tuple syntax `(##)`, `(#,#)`, `(#,,#)`, ...+--   * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ...+--   * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ...+isBuiltInOcc :: OccName -> Bool+isBuiltInOcc = isJust . isBuiltInOcc_maybe listTuplePuns+  where+    listTuplePuns = False+      -- True/False here is inconsequential because ListTuplePuns doesn't affect+      -- whether isBuiltInOcc_maybe matches. See Note [isBuiltInOcc_maybe]++-- Match on original names of infinite families (tuples and sums).+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names+isInfiniteFamilyOrigName_maybe :: Module -> OccName -> Maybe Name+isInfiniteFamilyOrigName_maybe mod occ =++  -- Tuples, boxed and unboxed+  isTupleTyOrigName_maybe mod occ+  <|> isTupleDataOrigName_maybe mod occ++  -- Constraint tuples+  <|> isCTupleOrigName_maybe mod occ++  -- Unboxed sums+  <|> isSumTyOrigName_maybe mod occ+  <|> isSumDataOrigName_maybe mod occ++-- Check if the string has form "()", "(,)", "(,,)", etc,+-- and return the corresponding tuple arity.+is_boxed_tup_syntax :: FastString -> Maybe Arity+is_boxed_tup_syntax fs+  | fs == "()" = Just 0+  | n >= 2+  , SBS.unsafeIndex sbs 0     == 40  -- ord '('+  , SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  , sbs_all sbs 1 (n-1)          44  -- ord ','+  = Just (n-1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_boxed_tup_syntax _ = Nothing++-- Check if the string has form "(##)", "(# #)", (#,#)", "(#,,#)", etc,+-- and return the corresponding tuple arity.+is_unboxed_tup_syntax :: FastString -> Maybe Arity+is_unboxed_tup_syntax fs+  | fs == "(##)"  = Just 0+  | fs == "(# #)" = Just 1+  | sbs_unboxed sbs+  , sbs_all sbs 2 (n-2) 44  -- ord ','+  = Just (n-3)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_tup_syntax _ = Nothing++-- Check if the string has form "(#|#)", "(#||#)", (#|||#)", etc,+-- and return the corresponding sum arity.+is_unboxed_sum_type_syntax :: FastString -> Maybe Arity+is_unboxed_sum_type_syntax fs+  | sbs_unboxed sbs+  , Just k <- sbs_pipes sbs 2 (n-2)+  , k > 0+  = Just (k+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_type_syntax _ = Nothing++-- Check if the string has form "(#_|#)", "(#_||#)", (#|_|#)", etc,+-- and return the corresponding sum tag and sum arity.+is_unboxed_sum_data_syntax :: FastString -> Maybe (ConTag, Arity)+is_unboxed_sum_data_syntax fs+  | sbs_unboxed sbs+  , Just u <- SBS.elemIndex 95 sbs        -- ord '_'+  , Just k1 <- sbs_pipes sbs 2 u          -- pipes to the left  of '_'+  , Just k2 <- sbs_pipes sbs (u+1) (n-2)  -- pipes to the right of '_'+  = Just (k1+1, k1+k2+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_data_syntax _ = Nothing++-- (sbs_all sbs i n x) checks if all bytes in the slice [i..n) are equal to x.+sbs_all :: SBS.ShortByteString -> Int -> Int -> Word8 -> Bool+sbs_all !sbs !i !n !x+  | i < n     = SBS.unsafeIndex sbs i == x && sbs_all sbs (i+1) n x+  | otherwise = True++-- (sbs_pipes sbs i n) checks if all bytes in the slice [i..n) are equal to '|'+-- or ' ', and returns the number of encountered '|'.+sbs_pipes :: SBS.ShortByteString -> Int -> Int -> Maybe Int+sbs_pipes !sbs = go 0+  where+    go :: Int -> Int -> Int -> Maybe Int+    go !k !i !n+      | i < n =+        if | SBS.unsafeIndex sbs i == 124 -> go (k+1) (i+1) n -- ord '|'+           | SBS.unsafeIndex sbs i == 32  -> go k     (i+1) n -- ord ' '+           | otherwise                    -> Nothing+      | otherwise = Just k++-- (sbs_unboxed sbs) checks if the string starts with "(#" and ends with "#)".+sbs_unboxed :: SBS.ShortByteString -> Bool+sbs_unboxed !sbs =+  n >= 4 && SBS.unsafeIndex sbs 0     == 40  -- ord '('+         && SBS.unsafeIndex sbs 1     == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-2) == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Sum sbs) checks if the string has form "SumN#" or "SumNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_SUM_SIZE] range.+sbs_Sum :: SBS.ShortByteString -> Maybe Arity+sbs_Sum !sbs+  | n >= 3 && SBS.unsafeIndex sbs 0 == 83   -- ord 'S'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 109  -- ord 'm'+  , Just (Unboxed, arity) <- sbs_arity_boxity sbs 3+  , arity >= 2, arity <= mAX_SUM_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Tuple sbs) checks if the string has form "TupleN", "TupleNM", "TupleN#" or "TupleNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_TUPLE_SIZE] range.+sbs_Tuple :: SBS.ShortByteString -> Maybe (Boxity, Arity)+sbs_Tuple !sbs+  | n >= 5 && SBS.unsafeIndex sbs 0 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 3 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 4 == 101  -- ord 'e'+  , Just r@(_, arity) <- sbs_arity_boxity sbs 5+  , arity >= 2, arity <= mAX_TUPLE_SIZE+  = Just r+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_CTuple sbs) checks if the string has form "CTupleN" or "CTupleNM",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_CTUPLE_SIZE] range.+sbs_CTuple :: SBS.ShortByteString -> Maybe Arity+sbs_CTuple !sbs+  | n >= 6 && SBS.unsafeIndex sbs 0 == 67   -- ord 'C'+           && SBS.unsafeIndex sbs 1 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 2 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 3 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 4 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 5 == 101  -- ord 'e'+  , Just (Boxed, arity) <- sbs_arity_boxity sbs 6+  , arity >= 2, arity <= mAX_CTUPLE_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_arity_boxity sbs i) parses bytes from position `i` to the end,+-- matching single- and double-digit decimals numerals (i.e. from 0 to 99)+-- possibly followed by '#'. See Note [Small Ints parsing]+sbs_arity_boxity :: SBS.ShortByteString -> Int -> Maybe (Boxity, Arity)+sbs_arity_boxity !sbs !i =+  case n - i of  -- bytes to parse+    1 -> parse1 (SBS.unsafeIndex sbs i)+    2 -> parse2 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1))+    3 -> parse3 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) (SBS.unsafeIndex sbs (i+2))+    _ -> Nothing+  where+    n = SBS.length sbs -- O(1)++    is_digit :: Word8 -> Bool+    is_digit x = x >= 48 && x <= 57  -- between (ord '0') and (ord '9')++    from_digit :: Word8 -> Int+    from_digit x = fromIntegral (x - 48)++    -- single-digit number+    parse1 :: Word8 -> Maybe (Boxity, Arity)+    parse1 x1 | is_digit x1 = Just (Boxed, from_digit x1)+    parse1 _ = Nothing++    -- double-digit number, or a single-digit number followed by '#'+    parse2 :: Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse2 x1 35  -- ord '#'+      | is_digit x1 = Just (Unboxed, from_digit x1)+    parse2 x1 x2+      | is_digit x1, is_digit x2+      = Just (Boxed, from_digit x1 * 10 + from_digit x2)+    parse2 _ _ = Nothing++    -- double-digit number followed by '#'+    parse3 :: Word8 -> Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse3 x1 x2 35 -- ord '#'+      | is_digit x1, is_digit x2+      = Just (Unboxed, from_digit x1 * 10 + from_digit x2)+    parse3 _ _ _ = Nothing++-- Identify original names of boxed and unboxed tuple type constructors.+-- Examples:+--   0b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Unit")    =  Just <wired-in Name for 0-tuples>+--   1b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Solo")    =  Just <wired-in Name for 1-tuples>+--   2b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple2")  =  Just <wired-in Name for 2-tuples>+--   0u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Unit#")   =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Solo#")   =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple2#") =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--   64b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple64")  =  Just <wired-in Name for 64-tuples>+--   64u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple64#") =  Just <wired-in Name for unboxed 64-tuples>+--+-- Non-examples: "()", "(##)", "(,)", "(#,#)", "(,,)", "(#,,#)", etc.+-- As far as tuple /types/ are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "Tuple0", "Tuple0#", "Tuple1", and "Tuple1#".+-- These are merely type synonyms for "Unit", "Unit#", "Solo", and "Solo#".+isTupleTyOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleTyOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access++    match_occ_boxed+      | occ == occName unitTyConName = Just unitTyConName+      | occ == occName soloTyConName = Just soloTyConName+      | isTcClsNameSpace ns, Just (boxity@Boxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++    match_occ_unboxed+      | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName+      | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName+      | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++isTupleTyOrigName_maybe _ _ = Nothing++-- Identify original names of boxed and unboxed tuple data constructors.+-- Examples:+--   0b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "()")      =  Just <wired-in Name for 0-tuples>+--   1b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "MkSolo")  =  Just <wired-in Name for 1-tuples>+--   2b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "(,)")     =  Just <wired-in Name for 2-tuples>+--   ...+--   0u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(##)")    =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "MkSolo#") =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(#,#)")   =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--+-- Non-examples: Tuple<n> or Tuple<n>#, as this is the name format of tuple /type/ constructors.+isTupleDataOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleDataOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    match_occ_boxed+      | occ == occName soloDataConName = Just soloDataConName+      | isDataConNameSpace ns, Just n <- (is_boxed_tup_syntax fs)+      = Just (tupleDataConName Boxed n)+      | otherwise = Nothing+    match_occ_unboxed+      | occ == occName unboxedSoloDataConName = Just unboxedSoloDataConName+      | isDataConNameSpace ns, Just n <- (is_unboxed_tup_syntax fs)+      = Just (tupleDataConName Unboxed n)+      | otherwise = Nothing+    fs = occNameFS occ+    ns = occNameSpace occ+isTupleDataOrigName_maybe _ _ = Nothing++-- Identify original names of constraint tuples.+-- Examples:+--   0) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CUnit")    =  Just <wired-in Name for 0-ctuples>+--   1) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CSolo")    =  Just <wired-in Name for 1-ctuples>+--   2) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple2")  =  Just <wired-in Name for 2-ctuples>+--   ...+--   64) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple64")  =  Just <wired-in Name for 64-ctuples>+--+-- Non-examples: "()", "(,)", "(,,)", etc.+-- As far as constraint tuples are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "CTuple0" and "CTuple1".+-- These are merely type synonyms for "CUnit" and "CSolo".+isCTupleOrigName_maybe :: Module -> OccName -> Maybe Name+isCTupleOrigName_maybe mod occ+  | mod == gHC_CLASSES+  = match_occ+  where+    fs  = occNameFS occ+    sbs = fastStringToShortByteString fs   -- O(1) field access+    match_occ+      | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)  -- CUnit+      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)  -- CSolo++      | Just num <- sbs_CTuple sbs, num >= 2+      = Just $ cTupleTyConName num++      | otherwise = Nothing++isCTupleOrigName_maybe _ _ = Nothing++-- Identify original names of unboxed sum type constructors.+-- Examples:+--   2) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum2#") =  Just <wired-in Name for unboxed 2-sums>+--   3) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum3#") =  Just <wired-in Name for unboxed 3-sums>+--   4) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum4#") =  Just <wired-in Name for unboxed 4-sums>+--   ...+--   64) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum64#") =  Just <wired-in Name for unboxed 64-sums>+--+-- Non-examples: "(#|#)", "(#||#)", "(#|||#)", etc. These are not valid syntax.+-- Also non-examples: "Sum0#", "Sum1#". These do not exist.+isSumTyOrigName_maybe :: Module -> OccName -> Maybe Name+isSumTyOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isTcClsNameSpace ns+  , Just n <- sbs_Sum sbs+  , n >= 2+  = Just (tyConName (sumTyCon n))+  where+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access+isSumTyOrigName_maybe _ _ = Nothing++-- Identify original names of unboxed sum data constructors.+-- "(#_|#)", "(#_||#)", (#|_|#)"+--+-- Examples:+--   1/2) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_|#)")  =  Just <wired-in Name for 1st alt of unboxed 2-sums>+--   1/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_||#)") =  Just <wired-in Name for 1st alt of unboxed 3-sums>+--   2/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#|_|#)") =  Just <wired-in Name for 2nd alt of unboxed 3-sums>+--   ...+--+-- Non-examples: Sum<n>#, as this is the name format of unboxed sum /type/ constructors.+isSumDataOrigName_maybe :: Module -> OccName -> Maybe Name+isSumDataOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isDataConNameSpace ns+  , Just (k,n) <- (is_unboxed_sum_data_syntax fs)+  = Just (unboxedSumDataConName k n)+  where fs = occNameFS occ+        ns = occNameSpace occ+isSumDataOrigName_maybe _ _ = Nothing++{-+Note [Small Ints parsing]+~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, tuples in Haskell have a maximum arity of 64.+To parse strings of length 1 and 2 more efficiently, we+can utilize an ad-hoc solution that matches their characters.+This results in a speedup of up to 40 times compared to using+`readMaybe @Int` on my machine.+-}++mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax)+mkTupleOcc ns b ar = (mkOccName ns str, built_in)+  where (str, built_in) = mkTupleStr' ns b ar++mkCTupleOcc :: NameSpace -> Arity -> OccName+mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)++mkTupleStr :: Boxity -> NameSpace -> Arity -> String+mkTupleStr b ns ar = str+  where (str, _) = mkTupleStr' ns b ar++mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax)+mkTupleStr' ns Boxed 0+  | isDataConNameSpace ns = ("()", BuiltInSyntax)+  | otherwise             = ("Unit", UserSyntax)+mkTupleStr' ns Boxed 1+  | isDataConNameSpace ns = ("MkSolo", UserSyntax)  -- See Note [One-tuples]+  | otherwise             = ("Solo",   UserSyntax)+mkTupleStr' ns Boxed ar+  | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ showInt ar "", UserSyntax)+mkTupleStr' ns Unboxed 0+  | isDataConNameSpace ns = ("(##)",  BuiltInSyntax)+  | otherwise             = ("Unit#", UserSyntax)+mkTupleStr' ns Unboxed 1+  | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples]+  | otherwise             = ("Solo#",   UserSyntax)+mkTupleStr' ns Unboxed ar+  | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ show ar ++ "#", UserSyntax)++mkConstraintTupleStr :: Arity -> String+mkConstraintTupleStr 0 = "CUnit"+mkConstraintTupleStr 1 = "CSolo"+mkConstraintTupleStr ar = "CTuple" ++ show ar++commas :: Arity -> String+commas ar = replicate (ar-1) ','++cTupleTyCon :: Arity -> TyCon+cTupleTyCon i+  | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = fstOf3 (cTupleArr ! i)++cTupleTyConName :: Arity -> Name+cTupleTyConName a = tyConName (cTupleTyCon a)++cTupleTyConNames :: [Name]+cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleTyConKeys :: UniqueSet+cTupleTyConKeys = fromListUniqueSet $ map getUnique cTupleTyConNames++isCTupleTyConName :: Name -> Bool+isCTupleTyConName n+ = assertPpr (isExternalName n) (ppr n) $+   getUnique n `memberUniqueSet` cTupleTyConKeys++cTupleDataCon :: Arity -> DataCon+cTupleDataCon i+  | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = sndOf3 (cTupleArr ! i)++cTupleDataConName :: Arity -> Name+cTupleDataConName i = dataConName (cTupleDataCon i)++cTupleDataConNames :: [Name]+cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleSelId :: ConTag -- Superclass position+            -> Arity  -- Arity+            -> Id+cTupleSelId sc_pos arity+  | sc_pos > arity+  = panic ("cTupleSelId: index out of bounds: superclass position: "+           ++ show sc_pos ++ " > arity " ++ show arity)++  | sc_pos <= 0+  = panic ("cTupleSelId: Superclass positions start from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 1+  = panic ("cTupleSelId: Arity starts from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_CTUPLE_SIZE+  = thdOf3 (mk_ctuple arity) ! (sc_pos - 1)  -- Build one specially++  | otherwise+  = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1)++cTupleSelIdName :: ConTag -- Superclass position+                -> Arity  -- Arity+                -> Name+cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)++tupleTyCon :: Boxity -> Arity -> TyCon+tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially+tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)++tupleTyConName :: TupleSort -> Arity -> Name+tupleTyConName ConstraintTuple a = cTupleTyConName a+tupleTyConName BoxedTuple      a = tyConName (tupleTyCon Boxed a)+tupleTyConName UnboxedTuple    a = tyConName (tupleTyCon Unboxed a)++promotedTupleDataCon :: Boxity -> Arity -> TyCon+promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)++tupleDataCon :: Boxity -> Arity -> DataCon+tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one specially+tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)+tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)++tupleDataConName :: Boxity -> Arity -> Name+tupleDataConName sort i = dataConName (tupleDataCon sort i)++mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]++isPromotedPairType :: Type -> Maybe (Type, Type)+isPromotedPairType t+  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t+  , tc == promotedTupleDataCon Boxed 2+  = Just (x, y)+  | otherwise = Nothing++boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]++-- | Cached type constructors, data constructors, and superclass selectors for+-- constraint tuples. The outer array is indexed by the arity of the constraint+-- tuple and the inner array is indexed by the superclass position.+cTupleArr :: Array Int (TyCon, DataCon, Array Int Id)+cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]]++-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed+-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type+-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep+-- [IntRep, LiftedRep])@+unboxedTupleSumKind :: TyCon -> [Type] -> Kind+unboxedTupleSumKind tc rr_tys+  = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])++-- | Specialization of 'unboxedTupleSumKind' for tuples+unboxedTupleKind :: [Type] -> Kind+unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon++mk_tuple :: Boxity -> Int -> (TyCon,DataCon)+mk_tuple Boxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         BoxedTuple flavour++    tc_binders  = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)+    tc_res_kind = liftedTypeKind+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs     = binderVars tc_binders+    dc_arg_tys = mkTyVarTys dc_tvs+    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon++    boxity  = Boxed+    modu    = gHC_INTERNAL_TUPLE+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_tuple Unboxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         UnboxedTuple flavour++    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2])+    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tc_res_kind = unboxedTupleKind rr_tys+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs               = binderVars tc_binders+    (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs+    tuple_con            = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon+    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos)+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    boxity  = Unboxed+    modu    = gHC_TYPES+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)+mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)+  where+    tycon = mkClassTyCon tc_name binders roles+                         rhs klass+                         (mkPrelTyConRepName tc_name)++    klass     = mk_ctuple_class tycon sc_theta sc_sel_ids+    tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon++    binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)+    roles   = replicate arity Nominal+    rhs     = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}++    modu    = gHC_CLASSES+    tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq+                         (ATyCon tycon) UserSyntax+    dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkCTupleTyConUnique   arity+    dc_uniq = mkCTupleDataConUnique arity++    tvs            = binderVars binders+    sc_theta       = map mkTyVarTy tvs+    sc_sel_ids     = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]]+    sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids++    mk_sc_sel_id sc_pos =+      let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity+          sc_sel_id_occ  = mkCTupleOcc tcName arity+          sc_sel_id_name = mkWiredInIdName+                             gHC_CLASSES+                             (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))+                             sc_sel_id_uniq+                             sc_sel_id+          sc_sel_id      = mkDictSelId sc_sel_id_name klass++      in sc_sel_id++unitTyCon :: TyCon+unitTyCon = tupleTyCon Boxed 0++unitTyConName :: Name+unitTyConName = tyConName unitTyCon++unitTyConKey :: Unique+unitTyConKey = getUnique unitTyCon++unitDataCon :: DataCon+unitDataCon   = head (tyConDataCons unitTyCon)++unitDataConId :: Id+unitDataConId = dataConWorkId unitDataCon++soloTyCon :: TyCon+soloTyCon = tupleTyCon Boxed 1++soloTyConName :: Name+soloTyConName = tyConName soloTyCon++soloDataConName :: Name+soloDataConName = tupleDataConName Boxed 1++pairTyCon :: TyCon+pairTyCon = tupleTyCon Boxed 2++unboxedUnitTy :: Type+unboxedUnitTy = mkTyConTy unboxedUnitTyCon++unboxedUnitTyCon :: TyCon+unboxedUnitTyCon = tupleTyCon Unboxed 0++unboxedUnitTyConName :: Name+unboxedUnitTyConName = tyConName unboxedUnitTyCon++unboxedUnitDataCon :: DataCon+unboxedUnitDataCon = tupleDataCon Unboxed 0++unboxedSoloTyCon :: TyCon+unboxedSoloTyCon = tupleTyCon Unboxed 1++unboxedSoloTyConName :: Name+unboxedSoloTyConName = tyConName unboxedSoloTyCon++unboxedSoloDataConName :: Name+unboxedSoloDataConName = tupleDataConName Unboxed 1++{- *********************************************************************+*                                                                      *+      Unboxed sums+*                                                                      *+********************************************************************* -}++-- | OccName for n-ary unboxed sum type constructor.+mkSumTyConOcc :: Arity -> OccName+mkSumTyConOcc n = mkOccName tcName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = "Sum" ++ show n ++ "#"++-- | OccName for i-th alternative of n-ary unboxed sum data constructor.+mkSumDataConOcc :: ConTag -> Arity -> OccName+mkSumDataConOcc alt n = mkOccName dataName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"+    bars i = intersperse ' ' $ replicate i '|'++-- | Type constructor for n-ary unboxed sum.+sumTyCon :: Arity -> TyCon+sumTyCon arity+  | arity > mAX_SUM_SIZE+  = fst (mk_sum arity)  -- Build one specially++  | arity < 2+  = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")++  | otherwise+  = fst (unboxedSumArr ! arity)++unboxedSumTyConName :: Arity -> Name+unboxedSumTyConName arity = tyConName (sumTyCon arity)++-- | Data constructor for i-th alternative of a n-ary unboxed sum.+sumDataCon :: ConTag -- Alternative+           -> Arity  -- Arity+           -> DataCon+sumDataCon alt arity+  | alt > arity+  = panic ("sumDataCon: index out of bounds: alt: "+           ++ show alt ++ " > arity " ++ show arity)++  | alt <= 0+  = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 2+  = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_SUM_SIZE+  = snd (mk_sum arity) ! (alt - 1)  -- Build one specially++  | otherwise+  = snd (unboxedSumArr ! arity) ! (alt - 1)++unboxedSumDataConName :: ConTag -> Arity -> Name+unboxedSumDataConName alt arity = dataConName (sumDataCon alt arity)++-- | Cached type and data constructors for sums. The outer array is+-- indexed by the arity of the sum and the inner array is indexed by+-- the alternative.+unboxedSumArr :: Array Int (TyCon, Array Int DataCon)+unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]++-- | Specialization of 'unboxedTupleSumKind' for sums+unboxedSumKind :: [Type] -> Kind+unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon++-- | Create type constructor and data constructors for n-ary unboxed sum.+mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)+mk_sum arity = (tycon, sum_cons)+  where+    tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons)+                         UnboxedSumTyCon++    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tyvars = binderVars tc_binders++    tc_res_kind = unboxedSumKind rr_tys++    (rr_tvs, dc_arg_tvs) = splitAt arity tyvars+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs++    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos))+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq+                            (ATyCon tycon) UserSyntax++    sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]+    sum_con i =+      let dc = pcRepPolyDataCon dc_name+                  tyvars -- univ tyvars+                  conc_tvs+                  [dc_arg_tys !! i] -- arg types+                  tycon++          dc_name = mkWiredInName gHC_TYPES+                                  (mkSumDataConOcc i arity)+                                  (dc_uniq i)+                                  (AConLike (RealDataCon dc))+                                  BuiltInSyntax+      in dc++    tc_uniq   = mkSumTyConUnique   arity+    dc_uniq i = mkSumDataConUnique i arity++{-+************************************************************************+*                                                                      *+              Equality types and classes+*                                                                      *+********************************************************************* -}++-- See Note [The equality types story] in GHC.Builtin.Types.Prim+-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)+--+-- It's tempting to put functional dependencies on (~~), but it's not+-- necessary because the functional-dependency coverage check looks+-- through superclasses, and (~#) is handled in that check.++eqTyCon,   heqTyCon,   coercibleTyCon   :: TyCon+eqClass,   heqClass,   coercibleClass   :: Class+eqDataCon, heqDataCon, coercibleDataCon :: DataCon+eqSCSelId, heqSCSelId, coercibleSCSelId :: Id++(eqTyCon, eqClass, eqDataCon, eqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon eqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName eqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint eqDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Nominal, Nominal]+    rhs       = mkDataTyConRhs [datacon]+                -- rhs: a DataTyCon, not a UnaryClassTyCon!  Yes it has one+                --      field, but it has unboxed type (a ~# b),+                --      so the class must provide the box.++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])+    sc_sel_id   = mkDictSelId eqSCSelIdName klass++(heqTyCon, heqClass, heqDataCon, heqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon heqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName heqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint heqDataConName tvs [sc_pred] tycon++    -- Kind: forall k1 k2. k1 -> k2 -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    roles     = [Nominal, Nominal, Nominal, Nominal]+    rhs       = mkDataTyConRhs [datacon]++    tvs       = binderVars binders+    sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)+    sc_sel_id = mkDictSelId heqSCSelIdName klass++(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon coercibleTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName coercibleTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Representational, Representational]+    rhs       = mkDataTyConRhs [datacon]++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])+    sc_sel_id   = mkDictSelId coercibleSCSelIdName klass++mk_class :: TyCon -> PredType -> Id -> Class+mk_class tycon sc_pred sc_sel_id+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]+            [] [] (mkAnd []) tycon++mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class+mk_ctuple_class tycon sc_theta sc_sel_ids+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids+            [] [] (mkAnd []) tycon++{- *********************************************************************+*                                                                      *+                Multiplicity Polymorphism+*                                                                      *+********************************************************************* -}++{- Multiplicity polymorphism is implemented very similarly to representation+ polymorphism. We write in the multiplicity kind and the One and Many+ types which can appear in user programs. These are defined properly in GHC.Types.++data Multiplicity = One | Many+-}++multiplicityTyConName :: Name+multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")+                          multiplicityTyConKey multiplicityTyCon++oneDataConName, manyDataConName :: Name+oneDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon+manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon++multiplicityTy :: Type+multiplicityTy = mkTyConTy multiplicityTyCon++multiplicityTyCon :: TyCon+multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []+                            [oneDataCon, manyDataCon]++oneDataCon, manyDataCon :: DataCon+oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon+manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon++oneDataConTy, manyDataConTy :: Type+oneDataConTy = mkTyConTy oneDataConTyCon+manyDataConTy = mkTyConTy manyDataConTyCon++oneDataConTyCon, manyDataConTyCon :: TyCon+oneDataConTyCon = promoteDataCon oneDataCon+manyDataConTyCon = promoteDataCon manyDataCon++multMulTyConName :: Name+multMulTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon++multMulTyCon :: TyCon+multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing+                         (BuiltInSynFamTyCon trivialBuiltInFamily)+                         Nothing+                         NotInjective+  where+    binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]++------------------------+-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).+--              TYPE rep1 -> TYPE rep2 -> Type+-- type (->) = FUN 'Many+unrestrictedFunTyCon :: TyCon+unrestrictedFunTyCon+  = buildSynTyCon unrestrictedFunTyConName [] arrowKind []+                  (TyCoRep.TyConApp fUNTyCon [manyDataConTy])+  where+    arrowKind = mkTyConKind binders liftedTypeKind+    -- See also funTyCon+    binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)+              , Bndr runtimeRep2TyVar (NamedTCB Inferred) ]+              ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                            , mkTYPEapp runtimeRep2Ty ]++unrestrictedFunTyConName :: Name+unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")+                                              unrestrictedFunTyConKey unrestrictedFunTyCon+++{- *********************************************************************+*                                                                      *+      Type synonyms (all declared in ghc-prim:GHC.Types)++         type CONSTRAINT   :: RuntimeRep -> Type -- primitive; cONSTRAINTKind+         type Constraint   = CONSTRAINT LiftedRep  :: Type    -- constraintKind++         type TYPE         :: RuntimeRep -> Type  -- primitive; tYPEKind+         type Type         = TYPE LiftedRep   :: Type         -- liftedTypeKind+         type UnliftedType = TYPE UnliftedRep :: Type         -- unliftedTypeKind++         type LiftedRep    = BoxedRep Lifted   :: RuntimeRep  -- liftedRepTy+         type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep  -- unliftedRepTy++*                                                                      *+********************************************************************* -}++-- For these synonyms, see+-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and+-- Note [Using synonyms to compress types] in GHC.Core.Type++{- Note [Naked FunTy]+~~~~~~~~~~~~~~~~~~~~~+GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument+flag and arg/res types.  But when constructing the kinds of tYPETyCon and+cONSTRAINTTyCon we don't want to make these checks because+     TYPE :: RuntimeRep -> Type+i.e. TYPE :: RuntimeRep -> TYPE LiftedRep++so the check will loop infinitely.  Hence the use of a naked FunTy+constructor in tTYPETyCon and cONSTRAINTTyCon.+-}+++----------------------+-- type Constraint = CONSTRAINT LiftedRep+constraintKindTyCon :: TyCon+constraintKindTyCon+  = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy]++constraintKindTyConName :: Name+constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")+                                             constraintKindTyConKey constraintKindTyCon++constraintKind :: Kind+constraintKind = mkTyConTy constraintKindTyCon++----------------------+-- type Type = TYPE LiftedRep+liftedTypeKindTyCon :: TyCon+liftedTypeKindTyCon+  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]++liftedTypeKindTyConName :: Name+liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")+                                             liftedTypeKindTyConKey liftedTypeKindTyCon++liftedTypeKind, typeToTypeKind :: Type+liftedTypeKind = mkTyConTy liftedTypeKindTyCon+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind++----------------------+-- type UnliftedType = TYPE ('BoxedRep 'Unlifted)+unliftedTypeKindTyCon :: TyCon+unliftedTypeKindTyCon+  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy]++unliftedTypeKindTyConName :: Name+unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType")+                                                unliftedTypeKindTyConKey unliftedTypeKindTyCon++unliftedTypeKind :: Type+unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon+++{- *********************************************************************+*                                                                      *+      data Levity = Lifted | Unlifted+*                                                                      *+********************************************************************* -}++levityTyConName, liftedDataConName, unliftedDataConName :: Name+levityTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Levity")   levityTyConKey     levityTyCon+liftedDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted")   liftedDataConKey   liftedDataCon+unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon++levityTyCon :: TyCon+levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]++levityTy :: Type+levityTy = mkTyConTy levityTyCon++liftedDataCon, unliftedDataCon :: DataCon+liftedDataCon = pcSpecialDataCon liftedDataConName+    [] levityTyCon (Levity Lifted)+unliftedDataCon = pcSpecialDataCon unliftedDataConName+    [] levityTyCon (Levity Unlifted)++liftedDataConTyCon :: TyCon+liftedDataConTyCon = promoteDataCon liftedDataCon++unliftedDataConTyCon :: TyCon+unliftedDataConTyCon = promoteDataCon unliftedDataCon++liftedDataConTy :: Type+liftedDataConTy = mkTyConTy liftedDataConTyCon++unliftedDataConTy :: Type+unliftedDataConTy = mkTyConTy unliftedDataConTyCon+++{- *********************************************************************+*                                                                      *+    See Note [Wiring in RuntimeRep]+        data RuntimeRep = VecRep VecCount VecElem+                        | TupleRep [RuntimeRep]+                        | SumRep [RuntimeRep]+                        | BoxedRep Levity+                        | IntRep | Int8Rep | ...etc...+*                                                                      *+********************************************************************* -}++{- Note [Wiring in RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,+making it a pain to wire in. To ease the pain somewhat, we use lists of+the different bits, like Uniques, Names, DataCons. These lists must be+kept in sync with each other. The rule is this: use the order as declared+in GHC.Types. All places where such lists exist should contain a reference+to this Note, so a search for this Note's name should find all the lists.++See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.+-}++runtimeRepTyCon :: TyCon+runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []+    -- Here we list all the data constructors+    -- of the RuntimeRep data type+    (vecRepDataCon : tupleRepDataCon :+     sumRepDataCon : boxedRepDataCon :+     runtimeRepSimpleDataCons)++runtimeRepTy :: Type+runtimeRepTy = mkTyConTy runtimeRepTyCon++runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon++vecRepDataConName   = mk_runtime_rep_dc_name (fsLit "VecRep")   vecRepDataConKey   vecRepDataCon+tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon+sumRepDataConName   = mk_runtime_rep_dc_name (fsLit "SumRep")   sumRepDataConKey   sumRepDataCon+boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon++mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name+mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc++boxedRepDataCon :: DataCon+boxedRepDataCon = pcSpecialDataCon boxedRepDataConName+  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in RepType+    prim_rep_fun [lev]+      = case tyConAppTyCon_maybe lev of+          Just tc -> case tyConPromDataConInfo tc of+            Levity l -> [BoxedRep (Just l)]+            _        -> [BoxedRep Nothing]+          Nothing    -> [BoxedRep Nothing]+    prim_rep_fun args+      = pprPanic "boxedRepDataCon" (ppr args)+++boxedRepDataConTyCon :: TyCon+boxedRepDataConTyCon = promoteDataCon boxedRepDataCon++tupleRepDataCon :: DataCon+tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]+                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = concatMap (runtimeRepPrimRep doc) rr_tys+      where+        rr_tys = extractPromotedList rr_ty_list+        doc    = text "tupleRepDataCon" <+> ppr rr_tys+    prim_rep_fun args+      = pprPanic "tupleRepDataCon" (ppr args)++tupleRepDataConTyCon :: TyCon+tupleRepDataConTyCon = promoteDataCon tupleRepDataCon++sumRepDataCon :: DataCon+sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]+                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = map slotPrimRep (toList (ubxSumRepType prim_repss))+      where+        rr_tys     = extractPromotedList rr_ty_list+        doc        = text "sumRepDataCon" <+> ppr rr_tys+        prim_repss = map (runtimeRepPrimRep doc) rr_tys+    prim_rep_fun args+      = pprPanic "sumRepDataCon" (ppr args)++sumRepDataConTyCon :: TyCon+sumRepDataConTyCon = promoteDataCon sumRepDataCon++-- See Note [Wiring in RuntimeRep]+-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+runtimeRepSimpleDataCons :: [DataCon]+runtimeRepSimpleDataCons+  = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys+            [ (fsLit "IntRep",    IntRep)+            , (fsLit "Int8Rep",   Int8Rep)+            , (fsLit "Int16Rep",  Int16Rep)+            , (fsLit "Int32Rep",  Int32Rep)+            , (fsLit "Int64Rep",  Int64Rep)+            , (fsLit "WordRep",   WordRep)+            , (fsLit "Word8Rep",  Word8Rep)+            , (fsLit "Word16Rep", Word16Rep)+            , (fsLit "Word32Rep", Word32Rep)+            , (fsLit "Word64Rep", Word64Rep)+            , (fsLit "AddrRep",   AddrRep)+            , (fsLit "FloatRep",  FloatRep)+            , (fsLit "DoubleRep", DoubleRep) ]+  where+    mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon+    mk_runtime_rep_dc uniq (fs, primrep)+      = data_con+      where+        data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))+        dc_name  = mk_runtime_rep_dc_name fs uniq data_con++-- See Note [Wiring in RuntimeRep]+intRepDataConTy,+  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+  wordRepDataConTy,+  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+  addrRepDataConTy,+  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType+[intRepDataConTy,+   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+   wordRepDataConTy,+   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+   addrRepDataConTy,+   floatRepDataConTy, doubleRepDataConTy+   ]+  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons++----------------------+-- | @type ZeroBitRep = 'Tuple '[]+zeroBitRepTyCon :: TyCon+zeroBitRepTyCon+  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]++zeroBitRepTyConName :: Name+zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")+                                          zeroBitRepTyConKey  zeroBitRepTyCon++zeroBitRepTy :: RuntimeRepType+zeroBitRepTy = mkTyConTy zeroBitRepTyCon++----------------------+-- @type ZeroBitType = TYPE ZeroBitRep+zeroBitTypeTyCon :: TyCon+zeroBitTypeTyCon+  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]++zeroBitTypeTyConName :: Name+zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")+                                          zeroBitTypeTyConKey zeroBitTypeTyCon++zeroBitTypeKind :: Type+zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon++----------------------+-- | @type LiftedRep = 'BoxedRep 'Lifted@+liftedRepTyCon :: TyCon+liftedRepTyCon+  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]++liftedRepTyConName :: Name+liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")+                                        liftedRepTyConKey liftedRepTyCon++liftedRepTy :: RuntimeRepType+liftedRepTy = mkTyConTy liftedRepTyCon++----------------------+-- | @type UnliftedRep = 'BoxedRep 'Unlifted@+unliftedRepTyCon :: TyCon+unliftedRepTyCon+  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]++unliftedRepTyConName :: Name+unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep")+                                          unliftedRepTyConKey unliftedRepTyCon++unliftedRepTy :: RuntimeRepType+unliftedRepTy = mkTyConTy unliftedRepTyCon+++{- *********************************************************************+*                                                                      *+         VecCount, VecElem+*                                                                      *+********************************************************************* -}++vecCountTyConName :: Name+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon++vecElemTyConName :: Name+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon++vecRepDataCon :: DataCon+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon+                                                   , mkTyConTy vecElemTyCon ]+                                 runtimeRepTyCon+                                 (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [count, elem]+      | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)+      , VecElem  e <- tyConPromDataConInfo (tyConAppTyCon elem)+      = [VecRep n e]+    prim_rep_fun args+      = pprPanic "vecRepDataCon" (ppr args)++vecRepDataConTyCon :: TyCon+vecRepDataConTyCon = promoteDataCon vecRepDataCon++vecCountTyCon :: TyCon+vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons++-- See Note [Wiring in RuntimeRep]+vecCountDataCons :: [DataCon]+vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys+  where+    mk_vec_count_dc logN key = con+      where+        n = 2^(logN :: Int)+        name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con+        con = pcSpecialDataCon name [] vecCountTyCon (VecCount n)++-- See Note [Wiring in RuntimeRep]+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type+[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons++vecElemTyCon :: TyCon+vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons++-- See Note [Wiring in RuntimeRep]+vecElemDataCons :: [DataCon]+vecElemDataCons = zipWith3 mk_vec_elem_dc+  [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep"+  , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep"+  , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]+  [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep+  , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep+  , FloatElemRep, DoubleElemRep ]+    vecElemDataConKeys+  where+    mk_vec_elem_dc nameFs elemRep key = con+      where+        name = mk_runtime_rep_dc_name nameFs key con+        con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep)++-- See Note [Wiring in RuntimeRep]+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type+[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)+                                vecElemDataCons++{- *********************************************************************+*                                                                      *+     The boxed primitive types: Char, Int, etc+*                                                                      *+********************************************************************* -}++charTy :: Type+charTy = mkTyConTy charTyCon++charTyCon :: TyCon+charTyCon   = pcTyCon charTyConName+                   (Just (CType NoSourceText Nothing+                                  (NoSourceText,fsLit "HsChar")))+                   [] [charDataCon]+charDataCon :: DataCon+charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon++stringTy :: Type+stringTy = mkTyConTy stringTyCon++stringTyCon :: TyCon+-- We have this wired-in so that Haskell literal strings+-- get type String (in hsLitType), which in turn influences+-- inferred types and error messages+stringTyCon = buildSynTyCon stringTyConName+                            [] liftedTypeKind []+                            (mkListTy charTy)++intTy :: Type+intTy = mkTyConTy intTyCon++intTyCon :: TyCon+intTyCon = pcTyCon intTyConName+               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))+                 [] [intDataCon]+intDataCon :: DataCon+intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon++wordTy :: Type+wordTy = mkTyConTy wordTyCon++wordTyCon :: TyCon+wordTyCon = pcTyCon wordTyConName+            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))+               [] [wordDataCon]+wordDataCon :: DataCon+wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon++word8Ty :: Type+word8Ty = mkTyConTy word8TyCon++word8TyCon :: TyCon+word8TyCon = pcTyCon word8TyConName+                     (Just (CType NoSourceText Nothing+                            (NoSourceText, fsLit "HsWord8"))) []+                     [word8DataCon]+word8DataCon :: DataCon+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon++floatTy :: Type+floatTy = mkTyConTy floatTyCon++floatTyCon :: TyCon+floatTyCon   = pcTyCon floatTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText, fsLit "HsFloat"))) []+                      [floatDataCon]+floatDataCon :: DataCon+floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon++doubleTy :: Type+doubleTy = mkTyConTy doubleTyCon++doubleTyCon :: TyCon+doubleTyCon = pcTyCon doubleTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText,fsLit "HsDouble"))) []+                      [doubleDataCon]++doubleDataCon :: DataCon+doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon++{- *********************************************************************+*                                                                      *+              Boxing data constructors+*                                                                      *+********************************************************************* -}++{- Note [Boxing constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep+that "box" unlifted values into a (boxed, lifted) value of kind Type. For example++  type Int8Box :: TYPE Int8Rep -> Type+  data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a+    -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a++Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`.  We can also+package up a (lifted) Constraint as a value of kind Type.++There are a fixed number of RuntimeReps, so we only need a fixed number+of boxing types.  (For TupleRep we need to box recursively; not yet done,+see #22336.)++This is used:++* In desugaring, when we need to package up a bunch of values into a tuple,+  for example when desugaring arrows.  See Note [Big tuples] in GHC.Core.Make.++* In let-floating when we want to float an unlifted sub-expression.+  See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels++In this module we make wired-in data type declarations for all of+these boxing functions.  The goal is to define boxingDataCon_maybe.++Wrinkles+(W1) The runtime system has special treatment (e.g. commoning up during GC)+     for Int and Char values. See  Note [CHARLIKE and INTLIKE closures] and+     Note [Precomputed static closures] in the RTS.++     So we treat Int# and Char# specially, in specialBoxingDataCon_maybe+-}++data BoxingInfo b+  = BI_NoBoxNeeded   -- The type has kind Type, so there is nothing to do++  | BI_NoBoxAvailable  -- The type does not have kind Type, but sadly we+                       -- don't have a boxing data constructor either++  | BI_Box             -- The type does not have kind Type, and we do have a+                       -- boxing data constructor; here it is+      { bi_data_con   :: DataCon+      , bi_inst_con   :: Expr b+      , bi_boxed_type :: Type }+    -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int }+    --        recall: data Int = I# Int#+    --+    --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty+    --             , bi_boxed_type = Int8Box ty }+    --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a++boxingDataCon :: Type -> BoxingInfo b+-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that+--   will box it, and the type of the boxed thing, which /does/ now have kind Type.+-- See Note [Boxing constructors]+boxingDataCon ty+  | tcIsLiftedTypeKind kind+  = BI_NoBoxNeeded    -- Fast path for Type++  | Just box_con <- specialBoxingDataCon_maybe ty+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con []+           , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) }++  | Just box_con <- lookupTypeMap boxingDataConMap kind+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty]+           , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] }++  | otherwise+  = BI_NoBoxAvailable++  where+    kind = typeKind ty++specialBoxingDataCon_maybe :: Type -> Maybe DataCon+-- ^ See Note [Boxing constructors] wrinkle (W1)+specialBoxingDataCon_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, _) | tc `hasKey` intPrimTyConKey  -> Just intDataCon+                   | tc `hasKey` charPrimTyConKey -> Just charDataCon+      _ -> Nothing++boxingDataConMap :: TypeMap DataCon+-- See Note [Boxing constructors]+boxingDataConMap = foldl add emptyTypeMap boxingDataCons+  where+    add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con++boxingDataCons :: [(Kind, DataCon)]+-- The Kind is the kind of types for which the DataCon is the right boxing+boxingDataCons = zipWith mkBoxingDataCon+  (map mkBoxingTyConUnique [1..])+  [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")+  , (mkTYPEapp intRepDataConTy,  fsLit "IntBox",  fsLit "MkIntBox")++  , (mkTYPEapp floatRepDataConTy,  fsLit "FloatBox",  fsLit "MkFloatBox")+  , (mkTYPEapp doubleRepDataConTy,  fsLit "DoubleBox",  fsLit "MkDoubleBox")++  , (mkTYPEapp int8RepDataConTy,  fsLit "Int8Box",  fsLit "MkInt8Box")+  , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")+  , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")+  , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")++  , (mkTYPEapp word8RepDataConTy,  fsLit "Word8Box",   fsLit "MkWord8Box")+  , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box",  fsLit "MkWord16Box")+  , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box",  fsLit "MkWord32Box")+  , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box",  fsLit "MkWord64Box")++  , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")+  , (constraintKind,   fsLit "DictBox", fsLit "MkDictBox") ]++mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)+mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)+  = (kind, dc)+  where+    uniq_dc = boxingDataConUnique uniq_tc++    (tv:_) = mkTemplateTyVars (repeat kind)+    tc = pcTyCon tc_name Nothing [tv] [dc]+    tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc++    dc | isConstraintKind kind+       = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc+       | otherwise+       = pcDataCon           dc_name [tv] [mkTyVarTy tv] tc+    dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc++{-+************************************************************************+*                                                                      *+              The Bool type+*                                                                      *+************************************************************************++An ordinary enumeration type, but deeply wired in.  There are no+magical operations on @Bool@ (just the regular Prelude code).++{\em BEGIN IDLE SPECULATION BY SIMON}++This is not the only way to encode @Bool@.  A more obvious coding makes+@Bool@ just a boxed up version of @Bool#@, like this:+\begin{verbatim}+type Bool# = Int#+data Bool = MkBool Bool#+\end{verbatim}++Unfortunately, this doesn't correspond to what the Report says @Bool@+looks like!  Furthermore, we get slightly less efficient code (I+think) with this coding. @gtInt@ would look like this:++\begin{verbatim}+gtInt :: Int -> Int -> Bool+gtInt x y = case x of I# x# ->+            case y of I# y# ->+            case (gtIntPrim x# y#) of+                b# -> MkBool b#+\end{verbatim}++Notice that the result of the @gtIntPrim@ comparison has to be turned+into an integer (here called @b#@), and returned in a @MkBool@ box.++The @if@ expression would compile to this:+\begin{verbatim}+case (gtInt x y) of+  MkBool b# -> case b# of { 1# -> e1; 0# -> e2 }+\end{verbatim}++I think this code is a little less efficient than the previous code,+but I'm not certain.  At all events, corresponding with the Report is+important.  The interesting thing is that the language is expressive+enough to describe more than one alternative; and that a type doesn't+necessarily need to be a straightforwardly boxed version of its+primitive counterpart.++{\em END IDLE SPECULATION BY SIMON}+-}++boolTy :: Type+boolTy = mkTyConTy boolTyCon++boolTyCon :: TyCon+boolTyCon = pcTyCon boolTyConName+                    (Just (CType NoSourceText Nothing+                           (NoSourceText, fsLit "HsBool")))+                    [] [falseDataCon, trueDataCon]++falseDataCon, trueDataCon :: DataCon+falseDataCon = pcDataCon falseDataConName [] [] boolTyCon+trueDataCon  = pcDataCon trueDataConName  [] [] boolTyCon++falseDataConId, trueDataConId :: Id+falseDataConId = dataConWorkId falseDataCon+trueDataConId  = dataConWorkId trueDataCon++orderingTyCon :: TyCon+orderingTyCon = pcTyCon orderingTyConName Nothing+                        [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]++ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon+ordLTDataCon = pcDataCon ordLTDataConName  [] [] orderingTyCon+ordEQDataCon = pcDataCon ordEQDataConName  [] [] orderingTyCon+ordGTDataCon = pcDataCon ordGTDataConName  [] [] orderingTyCon++ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id+ordLTDataConId = dataConWorkId ordLTDataCon+ordEQDataConId = dataConWorkId ordEQDataCon+ordGTDataConId = dataConWorkId ordGTDataCon++{-+************************************************************************+*                                                                      *+            The List type+   Special syntax, deeply wired in,+   but otherwise an ordinary algebraic data type+*                                                                      *+************************************************************************++       data [] a = [] | a : (List a)+-}++mkListTy :: Type -> Type+mkListTy ty = mkTyConApp listTyCon [ty]++listTyCon :: TyCon+listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]++-- See also Note [Empty lists] in GHC.Hs.Expr.+nilDataCon :: DataCon+nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon++consDataCon :: DataCon+consDataCon = pcDataConWithFixity True {- Declared infix -}+               consDataConName+               alpha_tyvar [] noConcreteTyVars alpha_tyvar []+               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])+               listTyCon++-- Interesting: polymorphic recursion would help here.+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy+-- gets the over-specific type (Type -> Type)++-- Wired-in type Maybe++maybeTyCon :: TyCon+maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar+                     [nothingDataCon, justDataCon]++nothingDataCon :: DataCon+nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon++justDataCon :: DataCon+justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon++mkPromotedMaybeTy :: Kind -> Maybe Type -> Type+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]+mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]++mkMaybeTy :: Type -> Kind+mkMaybeTy t = mkTyConApp maybeTyCon [t]++isPromotedMaybeTy :: Type -> Maybe (Maybe Type)+isPromotedMaybeTy t+  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x+  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing+  | otherwise = Nothing+++{-+** *********************************************************************+*                                                                      *+            The tuple types+*                                                                      *+************************************************************************++The tuple types are definitely magic, because they form an infinite+family.++\begin{itemize}+\item+They have a special family of type constructors, of type @TyCon@+These contain the tycon arity, but don't require a Unique.++\item+They have a special family of constructors, of type+@Id@. Again these contain their arity but don't need a Unique.++\item+There should be a magic way of generating the info tables and+entry code for all tuples.++But at the moment we just compile a Haskell source+file\srcloc{lib/prelude/...} containing declarations like:+\begin{verbatim}+data Tuple0             = Tup0+data Tuple2  a b        = Tup2  a b+data Tuple3  a b c      = Tup3  a b c+data Tuple4  a b c d    = Tup4  a b c d+...+\end{verbatim}+The print-names associated with the magic @Id@s for tuple constructors+``just happen'' to be the same as those generated by these+declarations.++\item+The instance environment should have a magic way to know+that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and+so on. \ToDo{Not implemented yet.}++\item+There should also be a way to generate the appropriate code for each+of these instances, but (like the info tables and entry code) it is+done by enumeration\srcloc{lib/prelude/InTup?.hs}.+\end{itemize}+-}++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are flattened.+-- See Note [One-tuples]+mkTupleTy :: Boxity -> [Type] -> Type+-- Special case for *boxed* 1-tuples, which are represented by the type itself+mkTupleTy Boxed   [ty] = ty+mkTupleTy boxity  tys  = mkTupleTy1 boxity tys++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.+-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]+-- in "GHC.Core.Make"+mkTupleTy1 :: Boxity -> [Type] -> Type+mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys+mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))+                                     (map getRuntimeRep tys ++ tys)++-- | Build the type of a small tuple that holds the specified type of thing+-- Flattens 1-tuples. See Note [One-tuples].+mkBoxedTupleTy :: [Type] -> Type+mkBoxedTupleTy tys = mkTupleTy Boxed tys++unitTy :: Type+unitTy = mkTupleTy Boxed []++-- Make a constraint tuple, flattening a 1-tuple as usual+-- If we get a constraint tuple that is bigger than the pre-built+--   ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't+--   have an info table in the RTS, so we can't use it at runtime.  But+--   this is used only in filling in extra-constraint wildcards, so it+--   never is used at runtime anyway+--   See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]+mkConstraintTupleTy :: [Type] -> Type+mkConstraintTupleTy [ty] = ty+mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys+++{- *********************************************************************+*                                                                      *+            The sum types+*                                                                      *+************************************************************************+-}++mkSumTy :: [Type] -> Type+mkSumTy tys = mkTyConApp (sumTyCon (length tys))+                         (map getRuntimeRep tys ++ tys)++-- Promoted Booleans++promotedFalseDataCon, promotedTrueDataCon :: TyCon+promotedTrueDataCon   = promoteDataCon trueDataCon+promotedFalseDataCon  = promoteDataCon falseDataCon++-- Promoted Maybe+promotedNothingDataCon, promotedJustDataCon :: TyCon+promotedNothingDataCon = promoteDataCon nothingDataCon+promotedJustDataCon    = promoteDataCon justDataCon++-- Promoted Ordering++promotedLTDataCon+  , promotedEQDataCon+  , promotedGTDataCon+  :: TyCon+promotedLTDataCon     = promoteDataCon ordLTDataCon+promotedEQDataCon     = promoteDataCon ordEQDataCon+promotedGTDataCon     = promoteDataCon ordGTDataCon++-- Promoted List+promotedConsDataCon, promotedNilDataCon :: TyCon+promotedConsDataCon   = promoteDataCon consDataCon+promotedNilDataCon    = promoteDataCon nilDataCon++-- | Make a *promoted* list.+mkPromotedListTy :: Kind   -- ^ of the elements of the list+                 -> [Type] -- ^ elements+                 -> Type+mkPromotedListTy k tys+  = foldr cons nil tys+  where+    cons :: Type  -- element+         -> Type  -- list+         -> Type+    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]++    nil :: Type+    nil = mkTyConApp promotedNilDataCon [k]++-- | Extract the elements of a promoted list. Panics if the type is not a+-- promoted list+extractPromotedList :: Type    -- ^ The promoted list+                    -> [Type]+extractPromotedList tys = go tys+  where+    go list_ty+      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` consDataConKey) $+        t : go ts++      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` nilDataConKey)+        []++      | otherwise+      = pprPanic "extractPromotedList" (ppr tys)++---------------------------------------+-- ghc-bignum+---------------------------------------++integerTyConName+   , integerISDataConName+   , integerIPDataConName+   , integerINDataConName+   :: Name+integerTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "Integer")+      integerTyConKey+      integerTyCon+integerISDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IS")+      integerISDataConKey+      integerISDataCon+integerIPDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IP")+      integerIPDataConKey+      integerIPDataCon+integerINDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IN")+      integerINDataConKey+      integerINDataCon++integerTy :: Type+integerTy = mkTyConTy integerTyCon++integerTyCon :: TyCon+integerTyCon = pcTyCon integerTyConName Nothing []+                  [integerISDataCon, integerIPDataCon, integerINDataCon]++integerISDataCon :: DataCon+integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon++integerIPDataCon :: DataCon+integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon++integerINDataCon :: DataCon+integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon++naturalTyConName+   , naturalNSDataConName+   , naturalNBDataConName+   :: Name+naturalTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "Natural")+      naturalTyConKey+      naturalTyCon+naturalNSDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NS")+      naturalNSDataConKey+      naturalNSDataCon+naturalNBDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NB")+      naturalNBDataConKey+      naturalNBDataCon++naturalTy :: Type+naturalTy = mkTyConTy naturalTyCon++naturalTyCon :: TyCon+naturalTyCon = pcTyCon naturalTyConName Nothing []+                  [naturalNSDataCon, naturalNBDataCon]++naturalNSDataCon :: DataCon+naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon++naturalNBDataCon :: DataCon+naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon+++{-+************************************************************************+*                                                                      *+   Semi-builtin names+*                                                                      *+************************************************************************++Note [pretendNameIsInScope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we filter out instances that mention types whose names are+not in scope. However, in the situations listed below, we make an exception+for some commonly used names, such as Data.Kind.Type, which may not actually+be in scope but should be treated as though they were in scope.+This includes built-in names, as well as a few extra names such as+'Type', 'TYPE', 'BoxedRep', etc.++Situations in which we apply this special logic:++  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.+    This fixes #1581.++  - When reporting instance overlap errors. Not doing so could mean+    that we would omit instances for typeclasses like++      type Cls :: k -> Constraint+      class Cls a++    because BoxedRep/Lifted were not in scope.+    See GHC.Tc.Errors.potentialInstancesErrMsg.+    This fixes one of the issues reported in #20465.+-}++-- | Should this name be considered in-scope, even though it technically isn't?+--+-- This ensures that we don't filter out information because, e.g.,+-- Data.Kind.Type isn't imported.+--+-- See Note [pretendNameIsInScope].+pretendNameIsInScope :: Name -> Bool+pretendNameIsInScope n+  = isBuiltInSyntax n+  || isTupleTyConName n+  || isSumTyConName n+  || isCTupleTyConName n+  || any (n `hasKey`)+    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey+    , liftedDataConKey, unliftedDataConKey+    , tYPETyConKey+    , cONSTRAINTTyConKey+    , runtimeRepTyConKey, boxedRepDataConKey+    , eqTyConKey+    , listTyConKey+    , oneDataConKey+    , manyDataConKey+    , fUNTyConKey, unrestrictedFunTyConKey ]
+ GHC/Builtin/Types.hs-boot view
@@ -0,0 +1,83 @@+module GHC.Builtin.Types where++import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, RuntimeRepType)+import {-# SOURCE #-} GHC.Core.DataCon  ( DataCon )++import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag)+import {-# SOURCE #-} GHC.Types.Name (Name)++listTyCon :: TyCon+typeSymbolKind :: Type+charTy :: Type+mkBoxedTupleTy :: [Type] -> Type++coercibleTyCon, heqTyCon :: TyCon++unitTy :: Type+unitTyCon :: TyCon++liftedTypeKindTyConName :: Name+constraintKindTyConName :: Name++liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind++liftedTypeKindTyCon, unliftedTypeKindTyCon :: TyCon++liftedRepTyCon, unliftedRepTyCon :: TyCon++constraintKind :: Kind++runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon+runtimeRepTy, levityTy :: Type++boxedRepDataConTyCon, liftedDataConTyCon :: TyCon+vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon++liftedRepTy, unliftedRepTy, zeroBitRepTy :: RuntimeRepType+liftedDataConTy, unliftedDataConTy :: Type++intRepDataConTy,+  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+  wordRepDataConTy,+  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+  addrRepDataConTy,+  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType++vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type++int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type++anyTypeOfKind :: Kind -> Type+unboxedTupleKind :: [Type] -> Type++multiplicityTyCon :: TyCon+multiplicityTy :: Type+oneDataConTy :: Type+oneDataConTyCon :: TyCon+manyDataConTy :: Type+manyDataConTyCon :: TyCon+unrestrictedFunTyCon :: TyCon+multMulTyCon :: TyCon++tupleTyConName :: TupleSort -> Arity -> Name+tupleDataConName :: Boxity -> Arity -> Name++integerTy, naturalTy :: Type++promotedTupleDataCon :: Boxity -> Arity -> TyCon++tupleDataCon :: Boxity -> Arity -> DataCon+tupleTyCon   :: Boxity -> Arity -> TyCon++cTupleDataCon :: Arity -> DataCon+cTupleDataConName :: Arity -> Name+cTupleTyConName :: Arity -> Name+cTupleSelIdName :: ConTag -> Arity -> Name++sumDataCon :: ConTag -> Arity -> DataCon+sumTyCon :: Arity -> TyCon
+ GHC/Builtin/Types/Literals.hs view
@@ -0,0 +1,1176 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}   -- See calls to mkTemplateTyVars++module GHC.Builtin.Types.Literals+  ( tryInteractInertFam, tryInteractTopFam, tryMatchFam++  , 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.Core.Unify      ( tcMatchTys )+import GHC.Data.Pair+import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon, tyConArity+                         , Injectivity(..), isBuiltInSynFamTyCon_maybe )+import GHC.Core.Coercion.Axiom+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, mkTemplateTyVars )+import GHC.Builtin.Names+                  ( gHC_INTERNAL_TYPELITS+                  , gHC_INTERNAL_TYPELITS_INTERNAL+                  , gHC_INTERNAL_TYPENATS+                  , gHC_INTERNAL_TYPENATS_INTERNAL+                  , typeNatAddTyFamNameKey+                  , typeNatMulTyFamNameKey+                  , typeNatExpTyFamNameKey+                  , typeNatSubTyFamNameKey+                  , typeNatDivTyFamNameKey+                  , typeNatModTyFamNameKey+                  , typeNatLogTyFamNameKey+                  , typeNatCmpTyFamNameKey+                  , typeSymbolCmpTyFamNameKey+                  , typeSymbolAppendFamNameKey+                  , typeCharCmpTyFamNameKey+                  , typeConsSymbolTyFamNameKey+                  , typeUnconsSymbolTyFamNameKey+                  , typeCharToNatTyFamNameKey+                  , typeNatToCharTyFamNameKey+                  )+import GHC.Data.FastString+import GHC.Utils.Panic+import GHC.Utils.Outputable++import Control.Monad ( guard )+import Data.List  ( isPrefixOf, isSuffixOf )+import Data.Maybe ( listToMaybe )+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.++* 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.++Note [Inlining axiom constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have a number of constructor functions with types like+   mkUnaryConstFoldAxiom :: TyCon -> String+                         -> (Type -> Maybe a)+                         -> (a -> Maybe Type)+                         -> BuiltInFamRewrite++For very type-family-heavy code, these higher order argument are inefficient;+e.g. the fourth argument might always return (Just ty) in the above. Inlining+them is a bit brutal, but not bad, makes a few-percent difference in, say+perf test T13386.++These functions aren't exported, so the effect is very local.++-}++-------------------------------------------------------------------------------+--     Key utility functions+-------------------------------------------------------------------------------++tryInteractTopFam :: BuiltInSynFamily -> TyCon -> [Type] -> Type+                  -> [(CoAxiomRule, TypeEqn)]+-- The returned CoAxiomRule is always unary+tryInteractTopFam fam fam_tc tys r+  = [(bifinj_axr bif, eqn_out) | bif  <- sfInteract fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in :: TypeEqn+    eqn_in = Pair (mkTyConApp fam_tc tys) r++tryInteractInertFam :: BuiltInSynFamily -> TyCon+                    -> [Type] -> [Type] -- F tys1 ~ F tys2+                    -> [(CoAxiomRule, TypeEqn)]+tryInteractInertFam builtin_fam fam_tc tys1 tys2+  = [(bifinj_axr bif, eqn_out) | bif <- sfInteract builtin_fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in = Pair (mkTyConApp fam_tc tys1) (mkTyConApp fam_tc tys2)++tryMatchFam :: BuiltInSynFamily -> [Type]+            -> Maybe (CoAxiomRule, [Type], Type)+-- Does this reduce on the given arguments?+-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)+-- That is: mkAxiomCo (BuiltInFamRew ax) (map mkNomReflCo ts)+--              :: F tys ~r rhs,+tryMatchFam builtin_fam arg_tys+  = listToMaybe $   -- Pick first rule to match+    [ (bifrw_axr rw_ax, inst_tys, res_ty)+    | rw_ax <- sfMatchFam builtin_fam+    , Just (inst_tys,res_ty) <- [bifrw_match rw_ax arg_tys] ]++-------------------------------------------------------------------------------+--          Constructing BuiltInFamInjectivity, BuiltInFamRewrite+-------------------------------------------------------------------------------++mkUnaryConstFoldAxiom :: TyCon -> String+                      -> (Type -> Maybe a)+                      -> (a -> Maybe Type)+                      -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkUnaryConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkUnaryConstFoldAxiom fam_tc str isReqTy f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 1+      , bifrw_match  = \ts -> do { [t1] <- return ts+                                 ; t1' <- isReqTy t1+                                 ; res <- f t1'+                                 ; return ([t1], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2] <- return cs+                                 ; s2' <- isReqTy s2+                                 ; z   <- f s2'+                                 ; return (mkTyConApp fam_tc [s1] === z) }+      }++mkBinConstFoldAxiom :: TyCon -> String+                    -> (Type -> Maybe a)+                    -> (Type -> Maybe b)+                    -> (a -> b -> Maybe Type)+                    -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkBinConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkBinConstFoldAxiom fam_tc str isReqTy1 isReqTy2 f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 2+      , bifrw_match  = \ts -> do { [t1,t2] <- return ts+                                 ; t1' <- isReqTy1 t1+                                 ; t2' <- isReqTy2 t2+                                 ; res <- f t1' t2'+                                 ; return ([t1,t2], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2, Pair t1 t2] <- return cs+                                 ; s2' <- isReqTy1 s2+                                 ; t2' <- isReqTy2 t2+                                 ; z   <- f s2' t2'+                                 ; return (mkTyConApp fam_tc [s1,t1] === z) }+      }++mkRewriteAxiom :: TyCon -> String+               -> [TyVar] -> [Type]  -- LHS of axiom+               -> Type               -- RHS of axiom+               -> BuiltInFamRewrite+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkRewriteAxiom fam_tc str tpl_tvs lhs_tys rhs_ty+  = assertPpr (tyConArity fam_tc == length lhs_tys) (text str <+> ppr lhs_tys) $+    bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = bif_arity+      , bifrw_match  = match_fn+      , bifrw_proves = inst_fn }++    bif_arity = length tpl_tvs++    match_fn :: [Type] -> Maybe ([Type],Type)+    match_fn arg_tys+      = assertPpr (tyConArity fam_tc == length arg_tys) (text str <+> ppr arg_tys) $+        case tcMatchTys lhs_tys arg_tys of+          Nothing    -> Nothing+          Just subst -> Just (substTyVars subst tpl_tvs, substTy subst rhs_ty)++    inst_fn :: [TypeEqn] -> Maybe TypeEqn+    inst_fn inst_eqns+      = assertPpr (length inst_eqns == bif_arity) (text str $$ ppr inst_eqns) $+        Just (mkTyConApp fam_tc (substTys (zipTCvSubst tpl_tvs tys1) lhs_tys)+              ===+              substTy (zipTCvSubst tpl_tvs tys2) rhs_ty)+      where+        (tys1, tys2) = unzipPairs inst_eqns++mkTopUnaryFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s ~ r) where `F` is a unary type function+{-# INLINE mkTopUnaryFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopUnaryFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs)+                        -> do { (tc, [a]) <- splitTyConApp_maybe lhs+                              ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                              ; f a rhs } }++mkTopBinFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s t  ~ r) where `F` is a binary type function+{-# INLINE mkTopBinFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopBinFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs) ->+                        do { (tc, [a,b]) <- splitTyConApp_maybe lhs+                           ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                           ; f a b rhs } }++mkUnaryBIF :: String -> TyCon -> BuiltInFamInjectivity+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkUnaryBIF str fam_tc+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; return (Pair x1 x2) }++mkBinBIF :: String -> TyCon+         -> WhichArg -> WhichArg+         -> (Type -> Bool)         -- The guard on the equal args, if any+         -> BuiltInFamInjectivity+{-# INLINE mkBinBIF #-}  -- See Note [Inlining axiom constructors]+mkBinBIF str fam_tc eq1 eq2 check_me+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2,y2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1,y1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; case (eq1, eq2) of+               (ArgX,ArgX) -> do_it x1 x2 y1 y2+               (ArgX,ArgY) -> do_it x1 y2 x2 y1+               (ArgY,ArgX) -> do_it y1 x2 y2 x1+               (ArgY,ArgY) -> do_it y1 y2 x1 x2 }++    do_it a1 a2 b1 b2 = do { same a1 a2; guard (check_me a1); return (Pair b1 b2) }++noGuard :: Type -> Bool+noGuard _ = True++numGuard :: (Integer -> Bool) -> Type -> Bool+numGuard pred ty = case isNumLitTy ty of+                      Just n  -> pred n+                      Nothing -> False++data WhichArg = ArgX | ArgY+++-------------------------------------------------------------------------------+--     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+  ]+++-- 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 $+    [ pr | tc <- typeNatTyCons+         , Just ops <- [isBuiltInSynFamTyCon_maybe tc]+         , pr <- [ (bifinj_name bif, bifinj_axr bif) | bif <- sfInteract ops ]+              ++ [ (bifrw_name bif,  bifrw_axr bif)  | bif <- sfMatchFam ops ] ]++-------------------------------------------------------------------------------+--                   Addition (+)+-------------------------------------------------------------------------------++typeNatAddTyCon :: TyCon+typeNatAddTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam  = axAddRewrites+    , sfInteract  = axAddInjectivity+    }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+")+              typeNatAddTyFamNameKey typeNatAddTyCon+++sn,tn :: TyVar  -- Of kind Natural+(sn: tn: _) = mkTemplateTyVars (repeat typeSymbolKind)++axAddRewrites :: [BuiltInFamRewrite]+axAddRewrites+  = [ mkRewriteAxiom   tc "Add0L" [tn] [num 0, var tn] (var tn)   -- 0 + t --> t+    , mkRewriteAxiom   tc "Add0R" [sn] [var sn, num 0] (var sn)   -- s + 0 --> s+    , mkBinConstFoldAxiom tc "AddDef" isNumLitTy isNumLitTy $     -- 3 + 4 --> 7+      \x y -> Just $ num (x + y) ]+  where+    tc = typeNatAddTyCon++axAddInjectivity :: [BuiltInFamInjectivity]+axAddInjectivity+  = [ -- (s + t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "AddT-0L" tc $ \ a _b r ->+      do { _ <- known r (== 0); return (Pair a (num 0)) }++    , -- (s + t ~ 0) => (t ~ 0)+      mkTopBinFamDeduction "AddT-0R" tc $ \ _a b r ->+      do { _ <- known r (== 0); return (Pair b (num 0)) }++    , -- (5 + t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "AddT-KKL" tc $ \ a b r ->+      do { na <- isNumLitTy a; nr <- known r (>= na); return (Pair b (num (nr-na))) }++    , -- (s + 5 ~ 8) => (s ~ 3)+      mkTopBinFamDeduction "AddT-KKR" tc $ \ a b r ->+      do { nb <- isNumLitTy b; nr <- known r (>= nb); return (Pair a (num (nr-nb))) }++    , mkBinBIF "AddI-xx" tc ArgX ArgX noGuard  -- x1+y1~x2+y2 {x1=x2}=> (y1 ~ y2)+    , mkBinBIF "AddI-xy" tc ArgX ArgY noGuard  -- x1+y1~x2+y2 {x1=y2}=> (x2 ~ y1)+    , mkBinBIF "AddI-yx" tc ArgY ArgX noGuard  -- x1+y1~x2+y2 {y1=x2}=> (x1 ~ y2)+    , mkBinBIF "AddI-yy" tc ArgY ArgY noGuard  -- x1+y1~x2+y2 {y1=y2}=> (x1 ~ x2)+    ]+  where+    tc = typeNatAddTyCon++-------------------------------------------------------------------------------+--                   Subtraction (-)+-------------------------------------------------------------------------------++typeNatSubTyCon :: TyCon+typeNatSubTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam = axSubRewrites+    , sfInteract = axSubInjectivity+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-")+            typeNatSubTyFamNameKey typeNatSubTyCon++axSubRewrites :: [BuiltInFamRewrite]+axSubRewrites+  = [ mkRewriteAxiom   tc "Sub0R" [sn] [var sn, num 0] (var sn)   -- s - 0 --> s+    , mkBinConstFoldAxiom tc "SubDef" isNumLitTy isNumLitTy $     -- 4 - 3 --> 1  if x>=y+      \x y -> fmap num (minus x y) ]+  where+    tc = typeNatSubTyCon++axSubInjectivity :: [BuiltInFamInjectivity]+axSubInjectivity+  = [ -- (a - b ~ 5) => (5 + b ~ a)+      mkTopBinFamDeduction "SubT" tc $ \ a b r ->+      do { _ <- isNumLitTy r; return (Pair (r .+. b) a) }++    , mkBinBIF "SubI-xx" tc ArgX ArgX noGuard -- (x-y1 ~ x-y2) => (y1 ~ y2)+    , mkBinBIF "SubI-yy" tc ArgY ArgY noGuard -- (x1-y ~ x2-y) => (x1 ~ x2)+    ]+  where+    tc = typeNatSubTyCon++{-+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.+-}+++-------------------------------------------------------------------------------+--                   Multiplication (*)+-------------------------------------------------------------------------------++typeNatMulTyCon :: TyCon+typeNatMulTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axMulRewrites+                   , sfInteract = axMulInjectivity  }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*")+              typeNatMulTyFamNameKey typeNatMulTyCon++axMulRewrites :: [BuiltInFamRewrite]+axMulRewrites+  = [ mkRewriteAxiom   tc "Mul0L" [tn] [num 0, var tn] (num 0)   -- 0 * t --> 0+    , mkRewriteAxiom   tc "Mul0R" [sn] [var sn, num 0] (num 0)   -- s * 0 --> 0+    , mkRewriteAxiom   tc "Mul1L" [tn] [num 1, var tn] (var tn)  -- 1 * t --> t+    , mkRewriteAxiom   tc "Mul1R" [sn] [var sn, num 1] (var sn)  -- s * 1 --> s+    , mkBinConstFoldAxiom tc "MulDef" isNumLitTy isNumLitTy $    -- 3 + 4 --> 12+      \x y -> Just $ num (x * y) ]+  where+    tc = typeNatMulTyCon++axMulInjectivity :: [BuiltInFamInjectivity]+axMulInjectivity+  = [ -- (s * t ~ 1)  => (s ~ 1)+      mkTopBinFamDeduction "MulT1" tc $ \ s _t r ->+      do { _ <- known r (== 1); return (Pair s r) }++    , -- (s * t ~ 1)  => (t ~ 1)+      mkTopBinFamDeduction "MulT2" tc $ \ _s t r ->+      do { _ <- known r (== 1); return (Pair t r) }++    , -- (3 * t ~ 15) => (t ~ 5)+      mkTopBinFamDeduction "MulT3" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- divide nr ns; return (Pair t (num y)) }++    , -- (s * 3 ~ 15) => (s ~ 5)+      mkTopBinFamDeduction "MulT4" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- divide nr nt; return (Pair s (num y)) }++    , mkBinBIF "MulI-xx" tc ArgX ArgX (numGuard (/= 0))    -- (x*y1 ~ x*y2) {x/=0}=> (y1 ~ y2)+    , mkBinBIF "MulI-yy" tc ArgY ArgY (numGuard (/= 0))    -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatMulTyCon+++-------------------------------------------------------------------------------+--                   Division: Div and Mod+-------------------------------------------------------------------------------++typeNatDivTyCon :: TyCon+typeNatDivTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axDivRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div")+            typeNatDivTyFamNameKey typeNatDivTyCon++typeNatModTyCon :: TyCon+typeNatModTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axModRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod")+            typeNatModTyFamNameKey typeNatModTyCon++axDivRewrites :: [BuiltInFamRewrite]+axDivRewrites+  = [ mkRewriteAxiom   tc "Div1" [sn] [var sn, num 1] (var sn)   -- s `div` 1 --> s+    , mkBinConstFoldAxiom tc "DivDef" isNumLitTy isNumLitTy $    -- 8 `div` 4 --> 2+      \x y -> do { guard (y /= 0); return (num (div x y)) } ]+  where+    tc = typeNatDivTyCon++axModRewrites :: [BuiltInFamRewrite]+axModRewrites+  = [ mkRewriteAxiom   tc "Mod1" [sn] [var sn, num 1] (num 0)   -- s `mod` 1 --> 0+    , mkBinConstFoldAxiom tc "ModDef" isNumLitTy isNumLitTy $   -- 8 `mod` 3 --> 2+      \x y -> do { guard (y /= 0); return (num (mod x y)) } ]+  where+    tc = typeNatModTyCon++-------------------------------------------------------------------------------+--                   Exponentiation: Exp+-------------------------------------------------------------------------------++typeNatExpTyCon :: TyCon  -- Exponentiation+typeNatExpTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axExpRewrites+                   , sfInteract = axExpInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^")+                typeNatExpTyFamNameKey typeNatExpTyCon++axExpRewrites :: [BuiltInFamRewrite]+axExpRewrites+  = [ mkRewriteAxiom   tc "Exp0R" [sn] [var sn, num 0] (num 1)   -- s ^ 0 --> 1+    , mkRewriteAxiom   tc "Exp1L" [tn] [num 1, var tn] (num 1)   -- 1 ^ t --> 1+    , mkRewriteAxiom   tc "Exp1R" [sn] [var sn, num 1] (var sn)  -- s ^ 1 --> s+    , mkBinConstFoldAxiom tc "ExpDef" isNumLitTy isNumLitTy $    -- 2 ^ 3 --> 8+      \x y -> Just (num (x ^ y)) ]+  where+    tc = typeNatExpTyCon++axExpInjectivity :: [BuiltInFamInjectivity]+axExpInjectivity+  = [ -- (s ^ t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "ExpT1" tc $ \ s _t r ->+      do { 0 <- isNumLitTy r; return (Pair s r) }++    , -- (2 ^ t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "ExpT2" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- logExact nr ns; return (Pair t (num y)) }++    , -- (s ^ 2 ~ 9) => (s ~ 3)+      mkTopBinFamDeduction "ExpT3" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- rootExact nr nt; return (Pair s (num y)) }++    , mkBinBIF "ExpI-xx" tc ArgX ArgX (numGuard (> 1))    -- (x^y1 ~ x^y2) {x>1}=> (y1 ~ y2)+    , mkBinBIF "ExpI-yy" tc ArgY ArgY (numGuard (/= 0))   -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatExpTyCon++-------------------------------------------------------------------------------+--                   Logarithm: Log2+-------------------------------------------------------------------------------++typeNatLogTyCon :: TyCon+typeNatLogTyCon = mkTypeNatFunTyCon1 name+  BuiltInSynFamily { sfMatchFam = axLogRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2")+            typeNatLogTyFamNameKey typeNatLogTyCon++axLogRewrites :: [BuiltInFamRewrite]+axLogRewrites+  = [ mkUnaryConstFoldAxiom tc "LogDef" isNumLitTy $       -- log 8 --> 3+      \x -> do { (a,_) <- genLog x 2; return (num a) } ]+  where+    tc = typeNatLogTyCon++-------------------------------------------------------------------------------+--               Comparision of Nats: CmpNat+-------------------------------------------------------------------------------++typeNatCmpTyCon :: TyCon+typeNatCmpTyCon+  = mkFamilyTyCon name+      (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+      orderingKind+      Nothing+      (BuiltInSynFamTyCon ops)+      Nothing+      NotInjective++  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat")+                  typeNatCmpTyFamNameKey typeNatCmpTyCon+    ops = BuiltInSynFamily { sfMatchFam = axCmpNatRewrites+                           , sfInteract = axCmpNatInjectivity }++axCmpNatRewrites :: [BuiltInFamRewrite]+axCmpNatRewrites+  = [ mkRewriteAxiom   tc "CmpNatRefl" [sn] [var sn, var sn] (ordering EQ)    -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpNatDef" isNumLitTy isNumLitTy $              -- 2 `cmp` 3 --> LT+      \x y -> Just (ordering (compare x y)) ]+  where+    tc = typeNatCmpTyCon++axCmpNatInjectivity :: [BuiltInFamInjectivity]+axCmpNatInjectivity+  = [ -- s `cmp` t ~ EQ   ==>   s ~ t+      mkTopBinFamDeduction "CmpNatT3" typeNatCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]++-------------------------------------------------------------------------------+--              Comparsion of Symbols: CmpSymbol+-------------------------------------------------------------------------------++typeSymbolCmpTyCon :: TyCon+typeSymbolCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [typeSymbolKind, typeSymbolKind])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol")+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axSymbolCmpRewrites+                         , sfInteract = axSymbolCmpInjectivity }++ss,ts :: TyVar  -- Of kind Symbol+(ss: ts: _) = mkTemplateTyVars (repeat typeSymbolKind)++axSymbolCmpRewrites :: [BuiltInFamRewrite]+axSymbolCmpRewrites+  = [ mkRewriteAxiom   tc "CmpSymbolRefl" [ss] [var ss, var ss] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpSymbolDef" isStrLitTy isStrLitTy $           -- "a" `cmp` "b" --> LT+      \x y -> Just (ordering (lexicalCompareFS x y)) ]+  where+    tc = typeSymbolCmpTyCon++axSymbolCmpInjectivity :: [BuiltInFamInjectivity]+axSymbolCmpInjectivity+  = [ mkTopBinFamDeduction "CmpSymbolT" typeSymbolCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++-------------------------------------------------------------------------------+--            AppendSymbol+-------------------------------------------------------------------------------++typeSymbolAppendTyCon :: TyCon+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axAppendRewrites+                   , sfInteract = axAppendInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol")+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon++axAppendRewrites :: [BuiltInFamRewrite]+axAppendRewrites+  = [ mkRewriteAxiom   tc "Concat0R" [ts] [nullStrLitTy, var ts] (var ts) -- "" ++ t --> t+    , mkRewriteAxiom   tc "Concat0L" [ss] [var ss, nullStrLitTy] (var ss) -- s ++ "" --> s+    , mkBinConstFoldAxiom tc "AppendSymbolDef" isStrLitTy isStrLitTy $    -- "a" ++ "b" --> "ab"+      \x y -> Just (mkStrLitTy (appendFS x y)) ]+  where+    tc = typeSymbolAppendTyCon++axAppendInjectivity :: [BuiltInFamInjectivity]+axAppendInjectivity+ = [ -- (AppendSymbol a b ~ "") => (a ~ "")+     mkTopBinFamDeduction "AppendSymbolT1" tc $ \ a _b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair a nullStrLitTy) }++   , -- (AppendSymbol a b ~ "") => (b ~ "")+     mkTopBinFamDeduction "AppendSymbolT2" tc $ \ _a b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair b nullStrLitTy) }++   , -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { as <- isStrLitTyS a; rs <- isStrLitTyS r; guard (as `isPrefixOf` rs)+        ; return (Pair b (mkStrLitTyS (drop (length as) rs))) }++   , -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { bs <- isStrLitTyS b; rs <- isStrLitTyS r; guard (bs `isSuffixOf` rs)+        ; return (Pair a (mkStrLitTyS (take (length rs - length bs) rs))) }++    , mkBinBIF "AppI-xx" tc ArgX ArgX noGuard  -- (x++y1 ~ x++y2) => (y1 ~ y2)+    , mkBinBIF "AppI-yy" tc ArgY ArgY noGuard  -- (x1++y ~ x2++y) => (x1 ~ x2)+    ]+  where+    tc = typeSymbolAppendTyCon++-------------------------------------------------------------------------------+--            ConsSymbol+-------------------------------------------------------------------------------++typeConsSymbolTyCon :: TyCon+typeConsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True, True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol")+                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon+  ops = BuiltInSynFamily  { sfMatchFam = axConsRewrites+                          , sfInteract = axConsInjectivity }++axConsRewrites :: [BuiltInFamRewrite]+axConsRewrites+  = [ mkBinConstFoldAxiom tc "ConsSymbolDef" isCharLitTy isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x y -> Just $ mkStrLitTy (consFS x y) ]+  where+    tc = typeConsSymbolTyCon++axConsInjectivity :: [BuiltInFamInjectivity]+axConsInjectivity+  = [ -- ConsSymbol a b ~ "blah" => (a ~ 'b')+      mkTopBinFamDeduction "ConsSymbolT1" tc $ \ a _b r ->+      do { rs <- isStrLitTy r; (x,_) <- unconsFS rs; return (Pair a (mkCharLitTy x)) }++    , -- ConsSymbol a b ~ "blah" => (b ~ "lah")+      mkTopBinFamDeduction "ConsSymbolT2" tc $ \ _a b r ->+      do { rs <- isStrLitTy r; (_,xs) <- unconsFS rs; return (Pair b (mkStrLitTy xs)) }+++    , mkBinBIF "ConsI-xx" tc ArgX ArgX noGuard  -- (x:y1 ~ x:y2) => (y1 ~ y2)+    , mkBinBIF "ConsI-yy" tc ArgY ArgY noGuard  -- (x1:y ~ x2:y) => (x1 ~ x2)+    ]+  where+    tc = typeConsSymbolTyCon++-------------------------------------------------------------------------------+--            UnconsSymbol+-------------------------------------------------------------------------------++typeUnconsSymbolTyCon :: TyCon+typeUnconsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind ])+    (mkMaybeTy charSymbolPairKind)+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol")+                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon+  ops = BuiltInSynFamily { sfMatchFam = axUnconsRewrites+                         , sfInteract = axUnconsInjectivity }++computeUncons :: FastString -> Type+computeUncons str+  = mkPromotedMaybeTy charSymbolPairKind (fmap reify (unconsFS str))+  where+    reify :: (Char, FastString) -> Type+    reify (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)++axUnconsRewrites :: [BuiltInFamRewrite]+axUnconsRewrites+  = [ mkUnaryConstFoldAxiom tc "ConsSymbolDef" isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x -> Just $ computeUncons x ]+  where+    tc = typeUnconsSymbolTyCon++axUnconsInjectivity :: [BuiltInFamInjectivity]+axUnconsInjectivity+  = [ -- (UnconsSymbol b ~ Nothing) => (b ~ "")+      mkTopUnaryFamDeduction "UnconsSymbolT1" tc $ \b r ->+      do { Nothing  <- isPromotedMaybeTy r; return (Pair b nullStrLitTy) }++    , -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")+      mkTopUnaryFamDeduction "UnconsSymbolT2" tc $ \b r ->+      do { Just pr <- isPromotedMaybeTy r+         ; (c,s) <- isPromotedPairType pr+         ; chr <- isCharLitTy c+         ; str <- isStrLitTy s+         ; return (Pair b (mkStrLitTy (consFS chr str))) }++    , mkUnaryBIF "UnconsI1" tc  -- (UnconsSymbol x1 ~ z, UnconsSymbol x2 ~ z) => (x1 ~ x2)+    ]+  where+    tc = typeUnconsSymbolTyCon++-------------------------------------------------------------------------------+--            CharToNat+-------------------------------------------------------------------------------++typeCharToNatTyCon :: TyCon+typeCharToNatTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat")+                  typeCharToNatTyFamNameKey typeCharToNatTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharToNatRewrites+                         , sfInteract = axCharToNatInjectivity }++axCharToNatRewrites :: [BuiltInFamRewrite]+axCharToNatRewrites+  = [ mkUnaryConstFoldAxiom tc "CharToNatDef" isCharLitTy $    -- CharToNat 'a' --> 97+      \x -> Just $ num (charToInteger x) ]+  where+    tc = typeCharToNatTyCon++axCharToNatInjectivity :: [BuiltInFamInjectivity]+axCharToNatInjectivity+  = [ -- (CharToNat c ~ 122) => (c ~ 'z')+      mkTopUnaryFamDeduction "CharToNatT1" typeCharToNatTyCon $ \c r ->+      do { nr <- isNumLitTy r; chr <- integerToChar nr; return (Pair c (mkCharLitTy chr)) } ]++-------------------------------------------------------------------------------+--            NatToChar+-------------------------------------------------------------------------------++typeNatToCharTyCon :: TyCon+typeNatToCharTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ naturalTy ])+    charTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar")+                  typeNatToCharTyFamNameKey typeNatToCharTyCon+  ops = BuiltInSynFamily { sfMatchFam = axNatToCharRewrites+                         , sfInteract = axNatToCharInjectivity }++axNatToCharRewrites :: [BuiltInFamRewrite]+axNatToCharRewrites+  = [ mkUnaryConstFoldAxiom tc "NatToCharDef" isNumLitTy $    -- NatToChar 97 --> 'a'+      \n -> fmap mkCharLitTy (integerToChar n) ]+  where+    tc = typeNatToCharTyCon++axNatToCharInjectivity :: [BuiltInFamInjectivity]+axNatToCharInjectivity+  = [ -- (NatToChar n ~ 'z') => (n ~ 122)+      mkTopUnaryFamDeduction "CharToNatT1" typeNatToCharTyCon $ \n r ->+      do { c <- isCharLitTy r; return (Pair n (mkNumLitTy (charToInteger c))) } ]+++-----------------------------------------------------------------------------+--                       CmpChar+-----------------------------------------------------------------------------++typeCharCmpTyCon :: TyCon+typeCharCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, charTy ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar")+                  typeCharCmpTyFamNameKey typeCharCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharCmpRewrites+                         , sfInteract = axCharCmpInjectivity }++sc :: TyVar  -- Of kind Char+(sc: _) = mkTemplateTyVars (repeat charTy)++axCharCmpRewrites :: [BuiltInFamRewrite]+axCharCmpRewrites+  = [ mkRewriteAxiom   tc "CmpCharRefl" [sc] [var sc, var sc] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpCharDef" isCharLitTy isCharLitTy $         -- 'a' `cmp` 'b' --> LT+      \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 ]+  where+    tc = typeCharCmpTyCon++axCharCmpInjectivity :: [BuiltInFamInjectivity]+axCharCmpInjectivity+  = [  -- (CmpChar s t ~ EQ) => s ~ t+      mkTopBinFamDeduction "CmpCharT" typeCharCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++{-------------------------------------------------------------------------------+Various utilities for making axioms and types+-------------------------------------------------------------------------------}++(===) :: Type -> Type -> Pair Type+x === y = Pair x y++num :: Integer -> Type+num = mkNumLitTy++var :: TyVar -> Type+var = mkTyVarTy++(.+.) :: 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]+-}+++nullStrLitTy :: Type  -- The type ""+nullStrLitTy = mkStrLitTy nilFS++isStrLitTyS :: Type -> Maybe String+isStrLitTyS ty = do { fs <- isStrLitTy ty; return (unpackFS fs) }++mkStrLitTyS :: String -> Type+mkStrLitTyS s = mkStrLitTy (mkFastString s)++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++-- 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++same :: Type -> Type -> Maybe ()+same ty1 ty2 = guard (ty1 `tcEqType` ty2)++known :: Type -> (Integer -> Bool) -> Maybe Integer+known x p = do { nx <- isNumLitTy x; guard (p nx); return nx }++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+++{- -----------------------------------------------------------------------------+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)+
+ GHC/Builtin/Types/Prim.hs view
@@ -0,0 +1,1440 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998+++Wired-in knowledge about primitive types+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module defines TyCons that can't be expressed in Haskell.+--   They are all, therefore, wired-in TyCons.  C.f module "GHC.Builtin.Types"+module GHC.Builtin.Types.Prim(+        mkTemplateKindVar, mkTemplateKindVars,+        mkTemplateTyVars, mkTemplateTyVarsFrom,+        mkTemplateKiTyVars, mkTemplateKiTyVar,++        mkTemplateTyConBinders, mkTemplateKindTyConBinders,+        mkTemplateAnonTyConBinders,++        alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar,+        alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec,+        alphaTys, alphaTy, betaTy, gammaTy, deltaTy,+        alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep,+        alphaTysUnliftedRep, alphaTyUnliftedRep,+        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,+        runtimeRep1TyVarInf, runtimeRep2TyVarInf,+        runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty,+        levity1TyVar, levity2TyVar,+        levity1TyVarInf, levity2TyVarInf,+        levity1Ty, levity2Ty,++        alphaConstraintTyVar, alphaConstraintTy,++        openAlphaTyVar, openBetaTyVar, openGammaTyVar,+        openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,+        openAlphaTy, openBetaTy, openGammaTy,++        levPolyAlphaTyVar, levPolyBetaTyVar,+        levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec,+        levPolyAlphaTy, levPolyBetaTy,++        multiplicityTyVar1, multiplicityTyVar2,++        -- Kind constructors...+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,++        -- Arrows+        funTyFlagTyCon, isArrowTyCon,+        fUNTyCon,       fUNTyConName,+        ctArrowTyCon, ctArrowTyConName,+        ccArrowTyCon, ccArrowTyConName,+        tcArrowTyCon, tcArrowTyConName,++        unexposedPrimTyCons, exposedPrimTyCons, primTyCons,++        charPrimTyCon,          charPrimTy, charPrimTyConName,+        intPrimTyCon,           intPrimTy, intPrimTyConName,+        wordPrimTyCon,          wordPrimTy, wordPrimTyConName,+        addrPrimTyCon,          addrPrimTy, addrPrimTyConName,+        floatPrimTyCon,         floatPrimTy, floatPrimTyConName,+        doublePrimTyCon,        doublePrimTy, doublePrimTyConName,++        statePrimTyCon,         mkStatePrimTy,+        realWorldTyCon,         realWorldTy,+        realWorldStatePrimTy,   realWorldMutableByteArrayPrimTy,++        proxyPrimTyCon,         mkProxyPrimTy,++        arrayPrimTyCon, mkArrayPrimTy,+        byteArrayPrimTyCon,     byteArrayPrimTy,+        smallArrayPrimTyCon, mkSmallArrayPrimTy,+        mutableArrayPrimTyCon, mkMutableArrayPrimTy,+        mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy,+        smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy,+        mutVarPrimTyCon, mkMutVarPrimTy,++        mVarPrimTyCon,                  mkMVarPrimTy,+        tVarPrimTyCon,                  mkTVarPrimTy,+        stablePtrPrimTyCon,             mkStablePtrPrimTy,+        stableNamePrimTyCon,            mkStableNamePrimTy,+        compactPrimTyCon,               compactPrimTy,+        bcoPrimTyCon,                   bcoPrimTy,+        weakPrimTyCon,                  mkWeakPrimTy,+        threadIdPrimTyCon,              threadIdPrimTy,+        stackSnapshotPrimTyCon,         stackSnapshotPrimTy,+        promptTagPrimTyCon,             mkPromptTagPrimTy,++        int8PrimTyCon,          int8PrimTy, int8PrimTyConName,+        word8PrimTyCon,         word8PrimTy, word8PrimTyConName,++        int16PrimTyCon,         int16PrimTy, int16PrimTyConName,+        word16PrimTyCon,        word16PrimTy, word16PrimTyConName,++        int32PrimTyCon,         int32PrimTy, int32PrimTyConName,+        word32PrimTyCon,        word32PrimTy, word32PrimTyConName,++        int64PrimTyCon,         int64PrimTy, int64PrimTyConName,+        word64PrimTyCon,        word64PrimTy, word64PrimTyConName,++        eqPrimTyCon,            -- ty1 ~# ty2+        eqReprPrimTyCon,        -- ty1 ~R# ty2  (at role Representational)+        eqPhantPrimTyCon,       -- ty1 ~P# ty2  (at role Phantom)+        equalityTyCon,++        -- * SIMD+#include "primop-vector-tys-exports.hs-incl"+  ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Builtin.Types+  ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind, unliftedTypeKind+  , boxedRepDataConTyCon, vecRepDataConTyCon+  , liftedRepTy, unliftedRepTy, zeroBitRepTy+  , intRepDataConTy+  , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy+  , wordRepDataConTy+  , word16RepDataConTy, word8RepDataConTy, word32RepDataConTy, word64RepDataConTy+  , addrRepDataConTy+  , floatRepDataConTy, doubleRepDataConTy+  , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy+  , vec64DataConTy+  , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy+  , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy+  , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy+  , doubleElemRepDataConTy+  , multiplicityTy+  , constraintKind )++import {-# SOURCE #-} GHC.Types.TyThing( mkATyCon )+import {-# SOURCE #-} GHC.Core.Type ( mkTyConApp, getLevity )++import GHC.Core.TyCon+import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid+                         -- import loops which show up if you import Type instead++import GHC.Types.Var    ( TyVarBinder, TyVar,binderVar, binderVars+                        , mkTyVar, mkTyVarBinder, mkTyVarBinders )+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Unique++import GHC.Builtin.Uniques+import GHC.Builtin.Names+import GHC.Utils.Misc ( changeLast )+import GHC.Utils.Panic ( assertPpr )+import GHC.Utils.Outputable++import GHC.Data.FastString+import Data.Char++{- *********************************************************************+*                                                                      *+             Building blocks+*                                                                      *+********************************************************************* -}++mk_TYPE_app :: Type -> Type+mk_TYPE_app rep = mkTyConApp tYPETyCon [rep]++mk_CONSTRAINT_app :: Type -> Type+mk_CONSTRAINT_app rep = mkTyConApp cONSTRAINTTyCon [rep]++mkPrimTc :: FastString -> Unique -> TyCon -> Name+mkPrimTc = mkGenPrimTc UserSyntax++mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name+mkBuiltInPrimTc = mkGenPrimTc BuiltInSyntax++mkGenPrimTc :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name+mkGenPrimTc built_in_syntax occ key tycon+  = mkWiredInName gHC_PRIM (mkTcOccFS occ)+                  key+                  (mkATyCon tycon)+                  built_in_syntax++-- | Create a primitive 'TyCon' with the given 'Name',+-- arguments of kind 'Type` with the given 'Role's,+-- and the given result kind representation.+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon :: Name+            -> [Role] -> RuntimeRepType -> TyCon+pcPrimTyCon name roles res_rep+  = mkPrimTyCon name binders result_kind roles+  where+    bndr_kis    = liftedTypeKind <$ roles+    binders     = mkTemplateAnonTyConBinders bndr_kis+    result_kind = mk_TYPE_app res_rep++-- | Create a primitive nullary 'TyCon' with the given 'Name'+-- and result kind representation.+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon0 :: Name -> RuntimeRepType -> TyCon+pcPrimTyCon0 name res_rep+  = pcPrimTyCon name [] res_rep++-- | Create a primitive 'TyCon' like 'pcPrimTyCon', except the last+-- argument is levity-polymorphic, where the levity argument is+-- implicit and comes before other arguments+--+-- Only use this in "GHC.Builtin.Types.Prim".+pcPrimTyCon_LevPolyLastArg :: Name+                           -> [Role] -- ^ roles of the arguments (must be non-empty),+                                     -- not including the implicit argument of kind 'Levity',+                                     -- which always has 'Nominal' role+                           -> RuntimeRepType  -- ^ representation of the fully-applied type+                           -> TyCon+pcPrimTyCon_LevPolyLastArg name roles res_rep+  = mkPrimTyCon name binders result_kind (Nominal : roles)+    where+      result_kind = mk_TYPE_app res_rep+      lev_bndr = mkNamedTyConBinder Inferred levity1TyVar+      binders  = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis+      lev_tv   = mkTyVarTy (binderVar lev_bndr)++      -- [ Type, ..., Type, TYPE (BoxedRep l) ]+      anon_bndr_kis = changeLast (liftedTypeKind <$ roles) $+                      mk_TYPE_app $+                      mkTyConApp boxedRepDataConTyCon [lev_tv]+++{- *********************************************************************+*                                                                      *+           Primitive type constructors+*                                                                      *+********************************************************************* -}++{- Note Note [Unexposed TyCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A few primitive TyCons are "unexposed", meaning:+* We don't want users to be able to write them (see #15209);+  i.e. they aren't in scope, ever.  In particular they do not+  appear in the exports of GHC.Prim: see GHC.Builtin.Utils.ghcPrimExports++* We don't want users to see them in GHCi's @:browse@ output (see #12023).+-}++primTyCons :: [TyCon]+primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons++-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed".+-- See Note [Unexposed TyCons]+unexposedPrimTyCons :: [TyCon]+unexposedPrimTyCons+  = [ eqPrimTyCon      -- (~#)+    , eqReprPrimTyCon  -- (~R#)+    , eqPhantPrimTyCon -- (~P#)++    -- These arrows are un-exposed for now+    , ctArrowTyCon  -- (=>)+    , ccArrowTyCon  -- (==>)+    , tcArrowTyCon  -- (-=>)+    ]++-- | Primitive 'TyCon's that are defined in, and exported from, GHC.Prim.+exposedPrimTyCons :: [TyCon]+exposedPrimTyCons+  = [ addrPrimTyCon+    , arrayPrimTyCon+    , byteArrayPrimTyCon+    , smallArrayPrimTyCon+    , charPrimTyCon+    , doublePrimTyCon+    , floatPrimTyCon+    , intPrimTyCon+    , int8PrimTyCon+    , int16PrimTyCon+    , int32PrimTyCon+    , int64PrimTyCon+    , bcoPrimTyCon+    , weakPrimTyCon+    , mutableArrayPrimTyCon+    , mutableByteArrayPrimTyCon+    , smallMutableArrayPrimTyCon+    , mVarPrimTyCon+    , tVarPrimTyCon+    , mutVarPrimTyCon+    , realWorldTyCon+    , stablePtrPrimTyCon+    , stableNamePrimTyCon+    , compactPrimTyCon+    , statePrimTyCon+    , proxyPrimTyCon+    , threadIdPrimTyCon+    , wordPrimTyCon+    , word8PrimTyCon+    , word16PrimTyCon+    , word32PrimTyCon+    , word64PrimTyCon+    , stackSnapshotPrimTyCon+    , promptTagPrimTyCon++    , fUNTyCon+    , tYPETyCon+    , cONSTRAINTTyCon++#include "primop-vector-tycons.hs-incl"+    ]++charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName,+  wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName,+  addrPrimTyConName, floatPrimTyConName, doublePrimTyConName,+  statePrimTyConName, proxyPrimTyConName, realWorldTyConName,+  arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName,+  mutableArrayPrimTyConName, mutableByteArrayPrimTyConName,+  smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,+  tVarPrimTyConName, stablePtrPrimTyConName,+  stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,+  weakPrimTyConName, threadIdPrimTyConName,+  eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,+  stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name+charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon+intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon+int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon+int16PrimTyConName            = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon+int32PrimTyConName            = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon+int64PrimTyConName            = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon+wordPrimTyConName             = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon+word8PrimTyConName            = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon+word16PrimTyConName           = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon+word32PrimTyConName           = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon+word64PrimTyConName           = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon+addrPrimTyConName             = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon+floatPrimTyConName            = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon+doublePrimTyConName           = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon+statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon+proxyPrimTyConName            = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon+eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon+eqReprPrimTyConName           = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon+eqPhantPrimTyConName          = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon+realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon+arrayPrimTyConName            = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon+byteArrayPrimTyConName        = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon+smallArrayPrimTyConName       = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon+mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon+mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon+smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon+mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon+mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon+tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon+stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon+stableNamePrimTyConName       = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon+compactPrimTyConName          = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon+stackSnapshotPrimTyConName    = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotPrimTyConKey stackSnapshotPrimTyCon+bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon+weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon+threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon+promptTagPrimTyConName        = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon++{- *********************************************************************+*                                                                      *+                Type variables+*                                                                      *+********************************************************************* -}++{-+alphaTyVars is a list of type variables for use in templates:+        ["a", "b", ..., "z", "t1", "t2", ... ]+-}++mkTemplateKindVar :: Kind -> TyVar+mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k")++mkTemplateKindVars :: [Kind] -> [TyVar]+-- k0  with unique (mkAlphaTyVarUnique 0)+-- k1  with unique (mkAlphaTyVarUnique 1)+-- ... etc+mkTemplateKindVars [kind] = [mkTemplateKindVar kind]+  -- Special case for one kind: just "k"+mkTemplateKindVars kinds+  = [ mkTyVar (mk_tv_name u ('k' : show u)) kind+    | (kind, u) <- kinds `zip` [0..] ]+mk_tv_name :: Int -> String -> Name+mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u)+                                (mkTyVarOccFS (mkFastString s))+                                noSrcSpan++mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar]+-- a  with unique (mkAlphaTyVarUnique n)+-- b  with unique (mkAlphaTyVarUnique n+1)+-- ... etc+-- Typically called as+--   mkTemplateTyVarsFrom (length kv_bndrs) kinds+-- where kv_bndrs are the kind-level binders of a TyCon+mkTemplateTyVarsFrom n kinds+  = [ mkTyVar name kind+    | (kind, index) <- zip kinds [0..],+      let ch_ord = index + ord 'a'+          name_str | ch_ord <= ord 'z' = [chr ch_ord]+                   | otherwise         = 't':show index+          name = mk_tv_name (index + n) name_str+    ]++mkTemplateTyVars :: [Kind] -> [TyVar]+mkTemplateTyVars = mkTemplateTyVarsFrom 1++mkTemplateTyConBinders+    :: [Kind]                -- [k1, .., kn]   Kinds of kind-forall'd vars+    -> ([Kind] -> [Kind])    -- Arg is [kv1:k1, ..., kvn:kn]+                             --     same length as first arg+                             -- Result is anon arg kinds+    -> [TyConBinder]+mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds+  = kv_bndrs ++ tv_bndrs+  where+    kv_bndrs   = mkTemplateKindTyConBinders kind_var_kinds+    anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs))+    tv_bndrs   = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds++mkTemplateKiTyVars+    :: [Kind]                -- [k1, .., kn]   Kinds of kind-forall'd vars+    -> ([Kind] -> [Kind])    -- Arg is [kv1:k1, ..., kvn:kn]+                             --     same length as first arg+                             -- Result is anon arg kinds [ak1, .., akm]+    -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]+-- Example: if you want the tyvars for+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, Type])+mkTemplateKiTyVars kind_var_kinds mk_arg_kinds+  = kv_bndrs ++ tv_bndrs+  where+    kv_bndrs   = mkTemplateKindVars kind_var_kinds+    anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs)+    tv_bndrs   = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds++mkTemplateKiTyVar+    :: Kind                  -- [k1, .., kn]   Kind of kind-forall'd var+    -> (Kind -> [Kind])      -- Arg is kv1:k1+                             -- Result is anon arg kinds [ak1, .., akm]+    -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]+-- Example: if you want the tyvars for+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, Type])+mkTemplateKiTyVar kind mk_arg_kinds+  = kv_bndr : tv_bndrs+  where+    kv_bndr    = mkTemplateKindVar kind+    anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr)+    tv_bndrs   = mkTemplateTyVarsFrom 1 anon_kinds++mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder]+-- Makes named, Specified binders+mkTemplateKindTyConBinders kinds+  = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]++mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder]+mkTemplateAnonTyConBinders kinds+  = mkAnonTyConBinders (mkTemplateTyVars kinds)++mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder]+mkTemplateAnonTyConBindersFrom n kinds+  = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds)++alphaTyVars :: [TyVar]+alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind++alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar+(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars++alphaTyVarSpec, betaTyVarSpec, gammaTyVarSpec, deltaTyVarSpec :: TyVarBinder+(alphaTyVarSpec:betaTyVarSpec:gammaTyVarSpec:deltaTyVarSpec:_) = mkTyVarBinders Specified alphaTyVars++alphaConstraintTyVars :: [TyVar]+alphaConstraintTyVars = mkTemplateTyVars $ repeat constraintKind++alphaConstraintTyVar :: TyVar+(alphaConstraintTyVar:_) = alphaConstraintTyVars++alphaConstraintTy :: Type+alphaConstraintTy = mkTyVarTy alphaConstraintTyVar++alphaTys :: [Type]+alphaTys = mkTyVarTys alphaTyVars+alphaTy, betaTy, gammaTy, deltaTy :: Type+(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys++alphaTyVarsUnliftedRep :: [TyVar]+alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat unliftedTypeKind++alphaTyVarUnliftedRep :: TyVar+(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep++alphaTysUnliftedRep :: [Type]+alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep+alphaTyUnliftedRep :: Type+(alphaTyUnliftedRep:_) = alphaTysUnliftedRep++runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar+(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _)+  = drop 16 (mkTemplateTyVars (repeat runtimeRepTy))  -- selects 'q','r'++runtimeRep1TyVarInf, runtimeRep2TyVarInf :: TyVarBinder+runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar+runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar++runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType+runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar+runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar+runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar+openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar+-- alpha :: TYPE r1+-- beta  :: TYPE r2+-- gamma :: TYPE r3+[openAlphaTyVar,openBetaTyVar,openGammaTyVar]+  = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty+                     , mk_TYPE_app runtimeRep2Ty+                     , mk_TYPE_app runtimeRep3Ty]++openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder+openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar+openBetaTyVarSpec  = mkTyVarBinder Specified openBetaTyVar+openGammaTyVarSpec = mkTyVarBinder Specified openGammaTyVar++openAlphaTy, openBetaTy, openGammaTy :: Type+openAlphaTy = mkTyVarTy openAlphaTyVar+openBetaTy  = mkTyVarTy openBetaTyVar+openGammaTy = mkTyVarTy openGammaTyVar++levity1TyVar, levity2TyVar :: TyVar+(levity2TyVar : levity1TyVar : _) -- NB: levity2TyVar before levity1TyVar+  = drop 10 (mkTemplateTyVars (repeat levityTy)) -- selects 'k', 'l'+-- The ordering of levity2TyVar before levity1TyVar is chosen so that+-- the more common levity1TyVar uses the levity variable 'l'.++levity1TyVarInf, levity2TyVarInf :: TyVarBinder+levity1TyVarInf = mkTyVarBinder Inferred levity1TyVar+levity2TyVarInf = mkTyVarBinder Inferred levity2TyVar++levity1Ty, levity2Ty :: Type+levity1Ty = mkTyVarTy levity1TyVar+levity2Ty = mkTyVarTy levity2TyVar++levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar+[levPolyAlphaTyVar, levPolyBetaTyVar] =+  mkTemplateTyVars+    [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty])+    , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])]+-- alpha :: TYPE ('BoxedRep l)+-- beta  :: TYPE ('BoxedRep k)++levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec :: TyVarBinder+levPolyAlphaTyVarSpec = mkTyVarBinder Specified levPolyAlphaTyVar+levPolyBetaTyVarSpec  = mkTyVarBinder Specified levPolyBetaTyVar++levPolyAlphaTy, levPolyBetaTy :: Type+levPolyAlphaTy = mkTyVarTy levPolyAlphaTyVar+levPolyBetaTy  = mkTyVarTy levPolyBetaTyVar++multiplicityTyVar1, multiplicityTyVar2  :: TyVar+(multiplicityTyVar1 : multiplicityTyVar2 : _)+   = drop 13 (mkTemplateTyVars (repeat multiplicityTy))  -- selects 'n', 'm'+++{-+************************************************************************+*                                                                      *+                FunTyCon+*                                                                      *+************************************************************************+-}++{- Note [Function type constructors and FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have four distinct function type constructors, and a type synonym++ FUN :: forall (m :: Multiplicity) ->+        forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+        TYPE rep1 -> TYPE rep2 -> Type++ (=>)  :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          CONSTRAINT rep1 -> TYPE rep2 -> Type++ (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint++ (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+          TYPE rep1 -> CONSTRAINT rep2 -> Constraint++ type (->) = FUN Many++For efficiency, all four are always represented by+  FunTy { ft_af :: FunTyFlag, ft_mult :: Mult+        , ft_arg :: Type, ft_res :: Type }+rather than by using a TyConApp.++* The four TyCons FUN, (=>), (==>), (-=>) are all wired in.+  But (->) is just a regular synonym, with no special treatment;+  in particular it is not wired-in.++* The ft_af :: FunTyFlag distinguishes the four cases.+  See Note [FunTyFlag] in GHC.Types.Var.++* The ft_af field is redundant: it can always be gleaned from+  the kinds of ft_arg and ft_res.  See Note [FunTyFlag] in GHC.Types.Var.++* The ft_mult :: Mult field gives the first argument for FUN+  For the other three cases ft_mult is redundant; it is always Many.+  Note that of the four type constructors, only `FUN` takes a Multiplicity.++* Functions in GHC.Core.Type help to build and decompose `FunTy`.+  * funTyConAppTy_maybe+  * funTyFlagTyCon+  * tyConAppFun_maybe+  * splitFunTy_maybe+  Use them!+-}++funTyFlagTyCon :: FunTyFlag -> TyCon+-- `anonArgTyCon af` gets the TyCon that corresponds to the `FunTyFlag`+-- But be careful: fUNTyCon has a different kind to the others!+-- See Note [Function type constructors and FunTy]+funTyFlagTyCon FTF_T_T = fUNTyCon+funTyFlagTyCon FTF_T_C = tcArrowTyCon+funTyFlagTyCon FTF_C_T = ctArrowTyCon+funTyFlagTyCon FTF_C_C = ccArrowTyCon++isArrowTyCon :: TyCon -> Bool+-- We don't bother to look for plain (->), because this function+-- should only be used after unwrapping synonyms+isArrowTyCon tc+  = assertPpr (not (isTypeSynonymTyCon tc)) (ppr tc)+    getUnique tc `elem`+    [fUNTyConKey, ctArrowTyConKey, ccArrowTyConKey, tcArrowTyConKey]++fUNTyConName, ctArrowTyConName, ccArrowTyConName, tcArrowTyConName :: Name+fUNTyConName     = mkPrimTc        (fsLit "FUN") fUNTyConKey       fUNTyCon+ctArrowTyConName = mkBuiltInPrimTc (fsLit "=>")  ctArrowTyConKey ctArrowTyCon+ccArrowTyConName = mkBuiltInPrimTc (fsLit "==>") ccArrowTyConKey ccArrowTyCon+tcArrowTyConName = mkBuiltInPrimTc (fsLit "-=>") tcArrowTyConKey tcArrowTyCon++-- | The @FUN@ type constructor.+--+-- @+-- FUN :: forall (m :: Multiplicity) ->+--        forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--        TYPE rep1 -> TYPE rep2 -> Type+-- @+--+-- The runtime representations quantification is left inferred. This+-- means they cannot be specified with @-XTypeApplications@.+--+-- This is a deliberate choice to allow future extensions to the+-- function arrow.+fUNTyCon :: TyCon+fUNTyCon = mkPrimTyCon fUNTyConName tc_bndrs liftedTypeKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1+               , mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_TYPE_app runtimeRep1Ty+                                             , mk_TYPE_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Nominal, Representational, Representational]++-- (=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--         CONSTRAINT rep1 -> TYPE rep2 -> Type+ctArrowTyCon :: TyCon+ctArrowTyCon = mkPrimTyCon ctArrowTyConName tc_bndrs liftedTypeKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty+                                             , mk_TYPE_app       runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]++-- (==>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--          CONSTRAINT rep1 -> CONSTRAINT rep2 -> Constraint+ccArrowTyCon :: TyCon+ccArrowTyCon = mkPrimTyCon ccArrowTyConName tc_bndrs constraintKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_CONSTRAINT_app runtimeRep1Ty+                                             , mk_CONSTRAINT_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]++-- (-=>) :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--          TYPE rep1 -> CONSTRAINT rep2 -> Constraint+tcArrowTyCon :: TyCon+tcArrowTyCon = mkPrimTyCon tcArrowTyConName tc_bndrs constraintKind tc_roles+  where+    -- See also unrestrictedFunTyCon+    tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar+               , mkNamedTyConBinder Inferred runtimeRep2TyVar ]+               ++ mkTemplateAnonTyConBinders [ mk_TYPE_app       runtimeRep1Ty+                                             , mk_CONSTRAINT_app runtimeRep2Ty ]+    tc_roles = [Nominal, Nominal, Representational, Representational]++{-+************************************************************************+*                                                                      *+                Type and Constraint+*                                                                      *+************************************************************************++Note [TYPE and CONSTRAINT]  aka Note [Type vs Constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC distinguishes Type from Constraint throughout the compiler.+See GHC Proposal #518, and tickets #21623 and #11715.++All types that classify values have a kind of the form+  (TYPE rr) or (CONSTRAINT rr)+where the `RuntimeRep` parameter, rr, tells us how the value is represented+at runtime.  TYPE and CONSTRAINT are primitive type constructors.++See Note [RuntimeRep polymorphism] about the `rr` parameter.++There are a bunch of type synonyms and data types defined in the+library ghc-prim:GHC.Types.  All of them are also wired in to GHC, in+GHC.Builtin.Types++  type Constraint   = CONSTRAINT LiftedRep  :: Type++  type Type         = TYPE LiftedRep   :: Type+  type UnliftedType = TYPE UnliftedRep :: Type++  type LiftedRep    = BoxedRep Lifted   :: RuntimeRep+  type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep++  data RuntimeRep     -- Defined in ghc-prim:GHC.Types+      = BoxedRep Levity+      | IntRep+      | FloatRep+      .. etc ..++  data Levity = Lifted | Unlifted++We abbreviate '*' specially (with -XStarIsType), as if we had this:+    type * = Type++So for example:+    Int        :: TYPE (BoxedRep Lifted)+    Array# Int :: TYPE (BoxedRep Unlifted)+    Int#       :: TYPE IntRep+    Float#     :: TYPE FloatRep+    Maybe      :: TYPE (BoxedRep Lifted) -> TYPE (BoxedRep Lifted)+    (# , #)    :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2])++    Eq Int       :: CONSTRAINT (BoxedRep Lifted)+    IP "foo" Int :: CONSTRAINT (BoxedRep Lifted)+    a ~ b        :: CONSTRAINT (BoxedRep Lifted)+    a ~# b       :: CONSTRAINT (TupleRep [])++Constraints are mostly lifted, but unlifted ones are useful too.+Specifically  (a ~# b) :: CONSTRAINT (TupleRep [])++Wrinkles++(W1) Type and Constraint are considered distinct throughout GHC. But they+     are not /apart/: see Note [Type and Constraint are not apart]++(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and+     aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.+     See Note [Type vs Constraint for error ids] in GHC.Core.Make.+     Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;+     see Note [inlineId magic].++(W3) We need a TypeOrConstraint flag in LitRubbish.++(W4) In the CPR transformation, we can't unbox constructors with constraint+     arguments because unboxed tuples (# …, … #) currently only supports fields+     of type TYPE rr. See (CPR2) in Note [Which types are unboxed?] in+     GHC.Core.Opt.WorkWrap.Utils.++Note [Type and Constraint are not apart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type and Constraint are not equal (eqType) but they are not /apart/+either. Reason (c.f. #7451):++* We want to allow newtype classes, where+    class C a where { op :: a -> a }++* The axiom for such a class will look like+    axiom axC a :: (C a :: Constraint) ~# (a->a :: Type)++* This axiom connects a type of kind Type with one of kind Constraint+  That is dangerous: kindCo (axC Int) :: Type ~N Constraint+  And /that/ is bad because we could have+     type family F a where+        F Type       = Int+        F Constraint = Bool+  So now we can prove Int ~N Bool, and all is lost.  We prevent this+  by saying that Type and Constraint are not Apart, which makes the+  above type family instances illegal.++So we ensure that Type and Constraint are not apart; or, more+precisely, that TYPE and CONSTRAINT are not apart.  This+non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look+for `maybeApart MARTypeVsConstraint`.++Note that, as before, nothing prevents writing instances like:++  instance C (Proxy @Type a) where ...++In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint+etc) are all allowed in instance heads. It's just that TYPE is not+apart from CONSTRAINT, which means that the above instance would+irretrievably overlap with:++  instance C (Proxy @Constraint a) where ...++Wrinkles++(W1) In GHC.Core.RoughMap.roughMatchTyConName we are careful to map+     TYPE and CONSTRAINT to the same rough-map key.  Reason:+     If we insert (F @Constraint tys) into a FamInstEnv, and look+     up (F @Type tys'), we /must/ ensure that the (C @Constraint tys)+     appears among the unifiables when we do the lookupRM' in+     GHC.Core.FamInstEnv.lookup_fam_inst_env'.  So for the RoughMap we+     simply pretend that they are the same type constructor.  If we+     don't, we'll treat them as fully apart, which is unsound.++(W2) We must extend this treatment to the different arrow types (see+     Note [Function type constructors and FunTy]): if we have+       FunCo (axC Int) <Int> :: (C Int => Int) ~ ((Int -> Int) -> Int),+     then we could extract an equality between (=>) and (->). We thus+     must ensure that (=>) and (->) (among the other arrow combinations)+     are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty.++(W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart?  In truth yes,+     they are.  But it's easier to say that they are not apart, by+     reporting "maybeApart" (which is always safe), rather than+     recurse into the arguments (whose kinds may be utterly different)+     to look for apartness inside them.  Again this is in+     GHC.Core.Unify.unify_ty.++(W4) We give a different Typeable instance for Type than for Constraint.+     For type classes instances (unlike type family instances) it is not+     /unsound/ for Type and Constraint to treated as fully distinct; and+     for Typeable is desirable to give them different TypeReps.+     Certainly,+       - both Type and Constraint must /have/ a TypeRep, and+       - they had better not be the same (else eqTypeRep would give us+         a proof Type ~N Constraint, which we do not want+     So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are+     treated as separate TyCons; i.e. given no special treatment.++Note [RuntimeRep polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g+   f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a]+   f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ...+This is no good: we could not generate code for 'f', because the+calling convention for 'f' varies depending on whether the argument is+a a Int, Int#, or Float#.  (You could imagine generating specialised+code, one for each instantiation of 'rr', but we don't do that.)++Certain functions CAN be runtime-rep-polymorphic, because the code+generator never has to manipulate a value of type 'a :: TYPE rr'.++* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a+  Code generator never has to manipulate the return value.++* unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:+  Always inlined to be a no-op+     unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                             (a :: TYPE r1) (b :: TYPE r2).+                             a -> b++* Unboxed tuples, and unboxed sums, defined in GHC.Builtin.Types+  Always inlined, and hence specialised to the call site+     (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)+                     (a :: TYPE r1) (b :: TYPE r2).+                     a -> b -> TYPE ('TupleRep '[r1, r2])+-}++----------------------+tYPETyCon :: TyCon+tYPETyCon = mkPrimTyCon tYPETyConName+                        (mkTemplateAnonTyConBinders [runtimeRepTy])+                        liftedTypeKind+                        [Nominal]++tYPETyConName :: Name+tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon++tYPEKind :: Type+tYPEKind = mkTyConTy tYPETyCon++----------------------+cONSTRAINTTyCon :: TyCon+cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName+                              (mkTemplateAnonTyConBinders [runtimeRepTy])+                              liftedTypeKind+                              [Nominal]++cONSTRAINTTyConName :: Name+cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon++cONSTRAINTKind :: Type+cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon+++{- *********************************************************************+*                                                                      *+       Basic primitive types (Char#, Int#, etc.)+*                                                                      *+********************************************************************* -}++charPrimTy :: Type+charPrimTy      = mkTyConTy charPrimTyCon+charPrimTyCon :: TyCon+charPrimTyCon   = pcPrimTyCon0 charPrimTyConName wordRepDataConTy++intPrimTy :: Type+intPrimTy       = mkTyConTy intPrimTyCon+intPrimTyCon :: TyCon+intPrimTyCon    = pcPrimTyCon0 intPrimTyConName intRepDataConTy++int8PrimTy :: Type+int8PrimTy     = mkTyConTy int8PrimTyCon+int8PrimTyCon :: TyCon+int8PrimTyCon  = pcPrimTyCon0 int8PrimTyConName int8RepDataConTy++int16PrimTy :: Type+int16PrimTy    = mkTyConTy int16PrimTyCon+int16PrimTyCon :: TyCon+int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName int16RepDataConTy++int32PrimTy :: Type+int32PrimTy     = mkTyConTy int32PrimTyCon+int32PrimTyCon :: TyCon+int32PrimTyCon  = pcPrimTyCon0 int32PrimTyConName int32RepDataConTy++int64PrimTy :: Type+int64PrimTy     = mkTyConTy int64PrimTyCon+int64PrimTyCon :: TyCon+int64PrimTyCon  = pcPrimTyCon0 int64PrimTyConName int64RepDataConTy++wordPrimTy :: Type+wordPrimTy      = mkTyConTy wordPrimTyCon+wordPrimTyCon :: TyCon+wordPrimTyCon   = pcPrimTyCon0 wordPrimTyConName wordRepDataConTy++word8PrimTy :: Type+word8PrimTy     = mkTyConTy word8PrimTyCon+word8PrimTyCon :: TyCon+word8PrimTyCon  = pcPrimTyCon0 word8PrimTyConName word8RepDataConTy++word16PrimTy :: Type+word16PrimTy    = mkTyConTy word16PrimTyCon+word16PrimTyCon :: TyCon+word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName word16RepDataConTy++word32PrimTy :: Type+word32PrimTy    = mkTyConTy word32PrimTyCon+word32PrimTyCon :: TyCon+word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName word32RepDataConTy++word64PrimTy :: Type+word64PrimTy    = mkTyConTy word64PrimTyCon+word64PrimTyCon :: TyCon+word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName word64RepDataConTy++addrPrimTy :: Type+addrPrimTy      = mkTyConTy addrPrimTyCon+addrPrimTyCon :: TyCon+addrPrimTyCon   = pcPrimTyCon0 addrPrimTyConName addrRepDataConTy++floatPrimTy     :: Type+floatPrimTy     = mkTyConTy floatPrimTyCon+floatPrimTyCon :: TyCon+floatPrimTyCon  = pcPrimTyCon0 floatPrimTyConName floatRepDataConTy++doublePrimTy :: Type+doublePrimTy    = mkTyConTy doublePrimTyCon+doublePrimTyCon :: TyCon+doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName doubleRepDataConTy++{-+************************************************************************+*                                                                      *+   The @State#@ type (and @_RealWorld@ types)+*                                                                      *+************************************************************************++Note [The equality types story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC sports a veritable menagerie of equality types:++         Type or  Lifted?  Hetero?  Role      Built in         Defining module+         class?    L/U                        TyCon+-----------------------------------------------------------------------------------------+~#         T        U      hetero   nominal   eqPrimTyCon      GHC.Prim+~~         C        L      hetero   nominal   heqTyCon         GHC.Types+~          C        L      homo     nominal   eqTyCon          GHC.Types+:~:        T        L      homo     nominal   (not built-in)   Data.Type.Equality+:~~:       T        L      hetero   nominal   (not built-in)   Data.Type.Equality++~R#        T        U      hetero   repr      eqReprPrimTy     GHC.Prim+Coercible  C        L      homo     repr      coercibleTyCon   GHC.Types+Coercion   T        L      homo     repr      (not built-in)   Data.Type.Coercion+~P#        T        U      hetero   phantom   eqPhantPrimTyCon GHC.Prim++Recall that "hetero" means the equality can related types of different+kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2)+also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2).++To produce less confusion for end users, when not dumping and without+-fprint-equality-relations, each of these groups is printed as the bottommost+listed equality. That is, (~#) and (~~) are both rendered as (~) in+error messages, and (~R#) is rendered as Coercible.++Let's take these one at a time:++    --------------------------+    (~#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    --------------------------+This is The Type Of Equality in GHC. It classifies nominal coercions.+This type is used in the solver for recording equality constraints.+It responds "yes" to Type.isEqPred and classifies as an EqPred in+Type.classifyPredType.++All wanted constraints of this type are built with coercion holes.+(See Note [Coercion holes] in GHC.Core.TyCo.Rep.) But see also+Note [Deferred errors for coercion holes] in GHC.Tc.Errors to see how+equality constraints are deferred.++Within GHC, ~# is called eqPrimTyCon, and it is defined in GHC.Builtin.Types.Prim.+++    --------------------------+    (~~) :: forall k1 k2. k1 -> k2 -> Constraint+    --------------------------+This is (almost) an ordinary class, defined as if by+  class a ~# b => a ~~ b+  instance a ~# b => a ~~ b+Here's what's unusual about it:++ * We can't actually declare it that way because we don't have syntax for ~#.+   And ~# isn't a constraint, so even if we could write it, it wouldn't kind+   check.++ * Users cannot write instances of it.++ * It is "naturally coherent". This means that the solver won't hesitate to+   solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the+   context. (Normally, it waits to learn more, just in case the given+   influences what happens next.) See Note [Solving equality classes]+   in GHC.Tc.Solver.Dict++ * It always terminates. That is, in the UndecidableInstances checks, we+   don't worry if a (~~) constraint is too big, as we know that solving+   equality terminates.++On the other hand, this behaves just like any class w.r.t. eager superclass+unpacking in the solver. So a lifted equality given quickly becomes an unlifted+equality given. This is good, because the solver knows all about unlifted+equalities. There is some special-casing in GHC.Tc.Solver.Dict.matchClassInst to+pretend that there is an instance of this class, as we can't write the instance+in Haskell.++Within GHC, ~~ is called heqTyCon, and it is defined in GHC.Builtin.Types.+++    --------------------------+    (~) :: forall k. k -> k -> Constraint+    --------------------------+This is /exactly/ like (~~), except with a homogeneous kind.+It is an almost-ordinary class defined as if by+  class a ~# b => (a :: k) ~ (b :: k)+  instance a ~# b => a ~ b++ * All the bullets for (~~) apply++ * In addition (~) is magical syntax, as ~ is a reserved symbol.+   It cannot be exported or imported.++ * The data constructor of the class is "Eq#", not ":C~"++Within GHC, ~ is called eqTyCon, and it is defined in GHC.Builtin.Types.++Historical note: prior to July 18 (~) was defined as a+  more-ordinary class with (~~) as a superclass.  But that made it+  special in different ways; and the extra superclass selections to+  get from (~) to (~#) via (~~) were tiresome.  Now it's defined+  uniformly with (~~) and Coercible; much nicer.)+++    --------------------------+    (:~:) :: forall k. k -> k -> *+    (:~~:) :: forall k1 k2. k1 -> k2 -> *+    --------------------------+These are perfectly ordinary GADTs, wrapping (~) and (~~) resp.+They are not defined within GHC at all.+++    --------------------------+    (~R#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    --------------------------+The is the representational analogue of ~#. This is the type of representational+equalities that the solver works on. All wanted constraints of this type are+built with coercion holes.++Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in GHC.Builtin.Types.Prim.+++    --------------------------+    Coercible :: forall k. k -> k -> Constraint+    --------------------------+This is quite like (~~) in the way it's defined and treated within GHC, but+it's homogeneous. Homogeneity helps with type inference (as GHC can solve one+kind from the other) and, in my (Richard's) estimation, will be more intuitive+for users.++An alternative design included HCoercible (like (~~)) and Coercible (like (~)).+One annoyance was that we want `coerce :: Coercible a b => a -> b`, and+we need the type of coerce to be fully wired-in. So the HCoercible/Coercible+split required that both types be fully wired-in. Instead of doing this,+I just got rid of HCoercible, as I'm not sure who would use it, anyway.++Within GHC, Coercible is called coercibleTyCon, and it is defined in+GHC.Builtin.Types.+++    --------------------------+    Coercion :: forall k. k -> k -> *+    --------------------------+This is a perfectly ordinary GADT, wrapping Coercible. It is not defined+within GHC at all.+++    --------------------------+    (~P#) :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    --------------------------+This is the phantom analogue of ~# and it is barely used at all.+(The solver has no idea about this one.) Here is the motivation:++    data Phant a = MkPhant+    type role Phant phantom++    Phant <Int, Bool>_P :: Phant Int ~P# Phant Bool++We just need to have something to put on that last line. You probably+don't need to worry about it.++++Note [The State# TyCon]+~~~~~~~~~~~~~~~~~~~~~~~+State# is the primitive, unlifted type of states.  It has one type parameter,+thus+        State# RealWorld+or+        State# s++where s is a type variable. The only purpose of the type parameter is to+keep different state threads separate.  It is represented by nothing at all.++The type parameter to State# is intended to keep separate threads separate.+Even though this parameter is not used in the definition of State#, it is+given role Nominal to enforce its intended use.+-}++mkStatePrimTy :: Type -> Type+mkStatePrimTy ty = TyConApp statePrimTyCon [ty]++statePrimTyCon :: TyCon   -- See Note [The State# TyCon]+statePrimTyCon   = pcPrimTyCon statePrimTyConName [Nominal] zeroBitRepTy++{-+RealWorld is deeply magical.  It is *primitive*, but it is not+*unlifted* (hence ptrArg).  We never manipulate values of type+RealWorld; it's only used in the type system, to parameterise State#.+-}++realWorldTyCon :: TyCon+realWorldTyCon = mkPrimTyCon realWorldTyConName [] liftedTypeKind []+realWorldTy :: Type+realWorldTy          = mkTyConTy realWorldTyCon+realWorldStatePrimTy :: Type+realWorldStatePrimTy = mkStatePrimTy realWorldTy        -- State# RealWorld+realWorldMutableByteArrayPrimTy :: Type+realWorldMutableByteArrayPrimTy+  = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld++mkProxyPrimTy :: Type -> Type -> Type+mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]++proxyPrimTyCon :: TyCon+proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom]+  where+     -- Kind: forall k. k -> TYPE (TupleRep '[])+     binders = mkTemplateTyConBinders [liftedTypeKind] id+     res_kind = unboxedTupleKind []+++{- *********************************************************************+*                                                                      *+                Primitive equality constraints+    See Note [The equality types story]+*                                                                      *+********************************************************************* -}++eqPrimTyCon :: TyCon  -- The representation type for equality predicates+                      -- See Note [The equality types story]+eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]+    roles    = [Nominal, Nominal, Nominal, Nominal]++-- like eqPrimTyCon, but the type for *Representational* coercions+-- this should only ever appear as the type of a covar. Its role is+-- interpreted in coercionRole+eqReprPrimTyCon :: TyCon   -- See Note [The equality types story]+eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]+    roles    = [Nominal, Nominal, Representational, Representational]++-- like eqPrimTyCon, but the type for *Phantom* coercions.+-- This is only used to make higher-order equalities. Nothing+-- should ever actually have this type!+eqPhantPrimTyCon :: TyCon+eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles+  where+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep+    binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]+    roles    = [Nominal, Nominal, Phantom, Phantom]++-- | Given a Role, what TyCon is the type of equality predicates at that role?+equalityTyCon :: Role -> TyCon+equalityTyCon Nominal          = eqPrimTyCon+equalityTyCon Representational = eqReprPrimTyCon+equalityTyCon Phantom          = eqPhantPrimTyCon++{- *********************************************************************+*                                                                      *+             The primitive array types+*                                                                      *+********************************************************************* -}++arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon,+    byteArrayPrimTyCon,+    smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon+arrayPrimTyCon             = pcPrimTyCon_LevPolyLastArg arrayPrimTyConName        [Representational]          unliftedRepTy+mutableArrayPrimTyCon      = pcPrimTyCon_LevPolyLastArg mutableArrayPrimTyConName [Nominal, Representational] unliftedRepTy+mutableByteArrayPrimTyCon  = pcPrimTyCon mutableByteArrayPrimTyConName  [Nominal] unliftedRepTy+byteArrayPrimTyCon         = pcPrimTyCon0 byteArrayPrimTyConName        unliftedRepTy+smallArrayPrimTyCon        = pcPrimTyCon_LevPolyLastArg smallArrayPrimTyConName        [Representational]          unliftedRepTy+smallMutableArrayPrimTyCon = pcPrimTyCon_LevPolyLastArg smallMutableArrayPrimTyConName [Nominal, Representational] unliftedRepTy++mkArrayPrimTy :: Type -> Type+mkArrayPrimTy elt           = TyConApp arrayPrimTyCon [getLevity elt, elt]+byteArrayPrimTy :: Type+byteArrayPrimTy             = mkTyConTy byteArrayPrimTyCon+mkSmallArrayPrimTy :: Type -> Type+mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [getLevity elt, elt]+mkMutableArrayPrimTy :: Type -> Type -> Type+mkMutableArrayPrimTy s elt  = TyConApp mutableArrayPrimTyCon [getLevity elt, s, elt]+mkMutableByteArrayPrimTy :: Type -> Type+mkMutableByteArrayPrimTy s  = TyConApp mutableByteArrayPrimTyCon [s]+mkSmallMutableArrayPrimTy :: Type -> Type -> Type+mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [getLevity elt, s, elt]+++{- *********************************************************************+*                                                                      *+                The mutable variable type+*                                                                      *+********************************************************************* -}++mutVarPrimTyCon :: TyCon+mutVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mutVarPrimTyConName [Nominal, Representational] unliftedRepTy++mkMutVarPrimTy :: Type -> Type -> Type+mkMutVarPrimTy s elt        = TyConApp mutVarPrimTyCon [getLevity elt, s, elt]++{-+************************************************************************+*                                                                      *+   The synchronizing variable type+\subsection[TysPrim-synch-var]{The synchronizing variable type}+*                                                                      *+************************************************************************+-}++mVarPrimTyCon :: TyCon+mVarPrimTyCon = pcPrimTyCon_LevPolyLastArg mVarPrimTyConName [Nominal, Representational] unliftedRepTy++mkMVarPrimTy :: Type -> Type -> Type+mkMVarPrimTy s elt          = TyConApp mVarPrimTyCon [getLevity elt, s, elt]++{-+************************************************************************+*                                                                      *+   The transactional variable type+*                                                                      *+************************************************************************+-}++tVarPrimTyCon :: TyCon+tVarPrimTyCon = pcPrimTyCon_LevPolyLastArg tVarPrimTyConName [Nominal, Representational] unliftedRepTy++mkTVarPrimTy :: Type -> Type -> Type+mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [getLevity elt, s, elt]++{-+************************************************************************+*                                                                      *+   The stable-pointer type+*                                                                      *+************************************************************************+-}++stablePtrPrimTyCon :: TyCon+stablePtrPrimTyCon = pcPrimTyCon_LevPolyLastArg stablePtrPrimTyConName [Representational] addrRepDataConTy++mkStablePtrPrimTy :: Type -> Type+mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [getLevity ty, ty]++{-+************************************************************************+*                                                                      *+   The stable-name type+*                                                                      *+************************************************************************+-}++stableNamePrimTyCon :: TyCon+stableNamePrimTyCon = pcPrimTyCon_LevPolyLastArg stableNamePrimTyConName [Phantom] unliftedRepTy++mkStableNamePrimTy :: Type -> Type+mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [getLevity ty, ty]++{-+************************************************************************+*                                                                      *+   The Compact NFData (CNF) type+*                                                                      *+************************************************************************+-}++compactPrimTyCon :: TyCon+compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName unliftedRepTy++compactPrimTy :: Type+compactPrimTy = mkTyConTy compactPrimTyCon++{-+************************************************************************+*                                                                      *+   The @StackSnapshot#@ type+*                                                                      *+************************************************************************+-}++stackSnapshotPrimTyCon :: TyCon+stackSnapshotPrimTyCon = pcPrimTyCon0 stackSnapshotPrimTyConName unliftedRepTy++stackSnapshotPrimTy :: Type+stackSnapshotPrimTy = mkTyConTy stackSnapshotPrimTyCon+++{-+************************************************************************+*                                                                      *+   The ``bytecode object'' type+*                                                                      *+************************************************************************+-}++-- Unlike most other primitive types, BCO is lifted. This is because in+-- general a BCO may be a thunk for the reasons given in Note [Updatable CAF+-- BCOs] in GHCi.CreateBCO.+bcoPrimTy    :: Type+bcoPrimTy    = mkTyConTy bcoPrimTyCon+bcoPrimTyCon :: TyCon+bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName liftedRepTy++{-+************************************************************************+*                                                                      *+   The ``weak pointer'' type+*                                                                      *+************************************************************************+-}++weakPrimTyCon :: TyCon+weakPrimTyCon = pcPrimTyCon_LevPolyLastArg weakPrimTyConName [Representational] unliftedRepTy++mkWeakPrimTy :: Type -> Type+mkWeakPrimTy v = TyConApp weakPrimTyCon [getLevity v, v]++{-+************************************************************************+*                                                                      *+   The ``thread id'' type+*                                                                      *+************************************************************************++A thread id is represented by a pointer to the TSO itself, to ensure+that they are always unique and we can always find the TSO for a given+thread id.  However, this has the unfortunate consequence that a+ThreadId# for a given thread is treated as a root by the garbage+collector and can keep TSOs around for too long.++Hence the programmer API for thread manipulation uses a weak pointer+to the thread id internally.+-}++threadIdPrimTy :: Type+threadIdPrimTy    = mkTyConTy threadIdPrimTyCon+threadIdPrimTyCon :: TyCon+threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy++{-+************************************************************************+*                                                                      *+   The ``prompt tag'' type+*                                                                      *+************************************************************************+-}++promptTagPrimTyCon :: TyCon+promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy++mkPromptTagPrimTy :: Type -> Type+mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v]++{-+************************************************************************+*                                                                      *+\subsection{SIMD vector types}+*                                                                      *+************************************************************************+-}++#include "primop-vector-tys.hs-incl"
+ GHC/Builtin/Uniques.hs view
@@ -0,0 +1,482 @@+++-- | This is where we define a mapping from Uniques to their associated+-- known-key Names for things associated with tuples and sums. We use this+-- mapping while deserializing known-key Names in interface file symbol tables,+-- which are encoded as their Unique. See Note [Symbol table representation of+-- names] for details.+--++module GHC.Builtin.Uniques+    ( -- * Looking up known-key names+      knownUniqueName++      -- * Getting the 'Unique's of 'Name's+      -- ** Anonymous sums+    , mkSumTyConUnique, mkSumDataConUnique+    , isSumTyConUnique++      -- ** Tuples+      -- *** Vanilla+    , mkTupleTyConUnique+    , mkTupleDataConUnique+    , isTupleTyConUnique+    , isTupleDataConLikeUnique+      -- *** Constraint+    , mkCTupleTyConUnique+    , mkCTupleDataConUnique+    , mkCTupleSelIdUnique+    , isCTupleTyConUnique++      -- ** Making built-in uniques+    , mkAlphaTyVarUnique+    , mkPrimOpIdUnique, mkPrimOpWrapperUnique+    , mkPreludeMiscIdUnique, mkPreludeDataConUnique+    , mkPreludeTyConUnique, mkPreludeClassUnique++    , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique+    , mkCostCentreUnique++    , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique+    , mkFldNSUnique, isFldNSUnique++    , mkBuiltinUnique+    , mkPseudoUniqueE++      -- ** Deriving uniques+      -- *** From TyCon name uniques+    , tyConRepNameUnique+      -- *** From DataCon name uniques+    , dataConWorkerUnique, dataConTyRepNameUnique++    , initExitJoinUnique++      -- Boxing data types+    , mkBoxingTyConUnique, boxingDataConUnique++    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCon+import {-# SOURCE #-} GHC.Core.DataCon+import {-# SOURCE #-} GHC.Types.Id+import {-# SOURCE #-} GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Data.FastString++import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Maybe+import GHC.Utils.Word64 (word64ToInt)++-- | Get the 'Name' associated with a known-key 'Unique'.+knownUniqueName :: Unique -> Maybe Name+knownUniqueName u =+    case tag of+      'z' -> Just $ getUnboxedSumName n+      '4' -> Just $ getTupleTyConName Boxed n+      '5' -> Just $ getTupleTyConName Unboxed n+      '7' -> Just $ getTupleDataConName Boxed n+      '8' -> Just $ getTupleDataConName Unboxed n+      'j' -> Just $ getCTupleSelIdName n+      'k' -> Just $ getCTupleTyConName n+      'm' -> Just $ getCTupleDataConName n+      _   -> Nothing+  where+    (tag, n') = unpkUnique u+    -- Known unique names are guaranteed to fit in Int, so we don't need the whole Word64.+    n = assert (isValidKnownKeyUnique u) (word64ToInt n')++{-+Note [Unique layout for unboxed sums]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Sum arities start from 2. The encoding is a bit funny: we break up the+integral part into bitfields for the arity, an alternative index (which is+taken to be 0xfc in the case of the TyCon), and, in the case of a datacon, a+tag (used to identify the sum's TypeRep binding).++This layout is chosen to remain compatible with the usual unique allocation+for wired-in data constructors described in GHC.Types.Unique++TyCon for sum of arity k:+  00000000 kkkkkkkk 11111100++TypeRep of TyCon for sum of arity k:+  00000000 kkkkkkkk 11111101++DataCon for sum of arity k and alternative n (zero-based):+  00000000 kkkkkkkk nnnnnn00++TypeRep for sum DataCon of arity k and alternative n (zero-based):+  00000000 kkkkkkkk nnnnnn10+-}++mkSumTyConUnique :: Arity -> Unique+mkSumTyConUnique arity =+    assertPpr (arity <= 0x3f) (ppr arity) $+              -- 0x3f since we only have 6 bits to encode the+              -- alternative+    mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc)++-- | Inverse of 'mkSumTyConUnique'+isSumTyConUnique :: Unique -> Maybe Arity+isSumTyConUnique u =+  case (tag, n .&. 0xfc) of+    ('z', 0xfc) -> Just (word64ToInt n `shiftR` 8)+    _ -> Nothing+  where+    (tag, n) = unpkUnique u++mkSumDataConUnique :: ConTagZ -> Arity -> Unique+mkSumDataConUnique alt arity+  | alt >= arity+  = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity)+  | otherwise+  = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}++getUnboxedSumName :: Int -> Name+getUnboxedSumName n+  | n .&. 0xfc == 0xfc+  = case tag of+      0x0 -> tyConName $ sumTyCon arity+      0x1 -> getRep $ sumTyCon arity+      _   -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag)+  | tag == 0x0+  = dataConName $ sumDataCon (alt + 1) arity+  | tag == 0x1+  = getName $ dataConWrapId $ sumDataCon (alt + 1) arity+  | tag == 0x2+  = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity+  | otherwise+  = pprPanic "getUnboxedSumName" (ppr n)+  where+    arity = n `shiftR` 8+    alt = (n .&. 0xfc) `shiftR` 2+    tag = 0x3 .&. n+    getRep tycon =+        fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon))+        $ tyConRepName_maybe tycon++-- Note [Uniques for tuple type and data constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Wired-in type constructor keys occupy *two* slots:+--    * u: the TyCon itself+--    * u+1: the TyConRepName of the TyCon+--+-- Wired-in tuple data constructor keys occupy *three* slots:+--    * u: the DataCon itself+--    * u+1: its worker Id+--    * u+2: the TyConRepName of the promoted TyCon++{-+Note [Unique layout for constraint tuple selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Constraint tuples, like boxed and unboxed tuples, have their type and data+constructor Uniques wired in (see+Note [Uniques for tuple type and data constructors]). Constraint tuples are+somewhat more involved, however. For a boxed or unboxed n-tuple, we need:++* A Unique for the type constructor, and+* A Unique for the data constructor++With a constraint n-tuple, however, we need:++* A Unique for the type constructor,+* A Unique for the data constructor, and+* A Unique for each of the n superclass selectors++To pick a concrete example (n = 2), the binary constraint tuple has a type+constructor and data constructor (%,%) along with superclass selectors+$p1(%,%) and $p2(%,%).++Just as we wire in the Uniques for constraint tuple type constructors and data+constructors, we wish to wire in the Uniques for the superclass selectors as+well. Not only does this make everything consistent, it also avoids a+compile-time performance penalty whenever GHC.Classes is loaded from an+interface file. This is because GHC.Classes defines constraint tuples as class+definitions, and if these classes weren't wired in, then loading GHC.Classes+would also load every single constraint tuple type constructor, data+constructor, and superclass selector. See #18635.++We encode the Uniques for constraint tuple superclass selectors as follows. The+integral part of the Unique is broken up into bitfields for the arity and the+position of the superclass. Given a selector for a constraint tuple with+arity n (zero-based) and position k (where 1 <= k <= n), its Unique will look+like:++  00000000 nnnnnnnn kkkkkkkk++We can use bit-twiddling tricks to access the arity and position with+cTupleSelIdArityBits and cTupleSelIdPosBitmask, respectively.++This pattern bears a certain resemblance to the way that the Uniques for+unboxed sums are encoded. This is because for a unboxed sum of arity n, there+are n corresponding data constructors, each with an alternative position k.+Similarly, for a constraint tuple of arity n, there are n corresponding+superclass selectors. Reading Note [Unique layout for unboxed sums] will+instill an appreciation for how the encoding for constraint tuple superclass+selector Uniques takes inspiration from the encoding for unboxed sum Uniques.+-}++mkCTupleTyConUnique :: Arity -> Unique+mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a)++mkCTupleDataConUnique :: Arity -> Unique+mkCTupleDataConUnique a = mkUniqueInt 'm' (3*a)++mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique+mkCTupleSelIdUnique sc_pos arity+  | sc_pos >= arity+  = panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity)+  | otherwise+  = mkUniqueInt 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)++-- | Inverse of 'mkCTupleTyConUnique'+isCTupleTyConUnique :: Unique -> Maybe Arity+isCTupleTyConUnique u =+  case (tag, i) of+    ('k', 0) -> Just arity+    _        -> Nothing+  where+    (tag, n) = unpkUnique u+    (arity', i) = quotRem n 2+    arity = word64ToInt arity'++getCTupleTyConName :: Int -> Name+getCTupleTyConName n =+    case n `divMod` 2 of+      (arity, 0) -> cTupleTyConName arity+      (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity+      _          -> panic "getCTupleTyConName: impossible"++getCTupleDataConName :: Int -> Name+getCTupleDataConName n =+    case n `divMod` 3 of+      (arity,  0) -> cTupleDataConName arity+      (arity,  1) -> getName $ dataConWrapId $ cTupleDataCon arity+      (arity,  2) -> mkPrelTyConRepName $ cTupleDataConName arity+      _           -> panic "getCTupleDataConName: impossible"++getCTupleSelIdName :: Int -> Name+getCTupleSelIdName n = cTupleSelIdName (sc_pos + 1) arity+  where+    arity  = n `shiftR` cTupleSelIdArityBits+    sc_pos = n .&. cTupleSelIdPosBitmask++-- Given the arity of a constraint tuple, this is the number of bits by which+-- one must shift it to the left in order to encode the arity in the Unique+-- of a superclass selector for that constraint tuple. Alternatively, given the+-- Unique for a constraint tuple superclass selector, this is the number of+-- bits by which one must shift it to the right to retrieve the arity of the+-- constraint tuple. See Note [Unique layout for constraint tuple selectors].+cTupleSelIdArityBits :: Int+cTupleSelIdArityBits = 8++-- Given the Unique for a constraint tuple superclass selector, one can+-- retrieve the position of the selector by ANDing this mask, which will+-- clear all but the eight least significant bits.+-- See Note [Unique layout for constraint tuple selectors].+cTupleSelIdPosBitmask :: Int+cTupleSelIdPosBitmask = 0xff++--------------------------------------------------+-- Normal tuples++mkTupleDataConUnique :: Boxity -> Arity -> Unique+mkTupleDataConUnique Boxed          a = mkUniqueInt '7' (3*a)    -- may be used in C labels+mkTupleDataConUnique Unboxed        a = mkUniqueInt '8' (3*a)++mkTupleTyConUnique :: Boxity -> Arity -> Unique+mkTupleTyConUnique Boxed           a  = mkUniqueInt '4' (2*a)+mkTupleTyConUnique Unboxed         a  = mkUniqueInt '5' (2*a)++-- | Inverse of 'mkTupleTyConUnique'+isTupleTyConUnique :: Unique -> Maybe (Boxity, Arity)+isTupleTyConUnique u =+  case (tag, i) of+    ('4', 0) -> Just (Boxed,   arity)+    ('5', 0) -> Just (Unboxed, arity)+    _        -> Nothing+  where+    (tag,   n) = unpkUnique u+    (arity', i) = quotRem n 2+    arity = word64ToInt arity'++-- | Inverse of 'mkTupleTyDataUnique' that also matches the worker and promoted tycon.+isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity)+isTupleDataConLikeUnique u =+  case tag of+    '7' -> Just (Boxed,   arity)+    '8' -> Just (Unboxed, arity)+    _ -> Nothing+  where+    (tag,   n) = unpkUnique u+    (arity', _) = quotRem n 3+    arity = word64ToInt arity'++getTupleTyConName :: Boxity -> Int -> Name+getTupleTyConName boxity n =+    case n `divMod` 2 of+      (arity, 0) -> tyConName $ tupleTyCon boxity arity+      (arity, 1) -> fromMaybe (panic "getTupleTyConName")+                    $ tyConRepName_maybe $ tupleTyCon boxity arity+      _          -> panic "getTupleTyConName: impossible"++getTupleDataConName :: Boxity -> Int -> Name+getTupleDataConName boxity n =+    case n `divMod` 3 of+      (arity, 0) -> dataConName $ tupleDataCon boxity arity+      (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity+      (arity, 2) -> fromMaybe (panic "getTupleDataCon")+                    $ tyConRepName_maybe $ promotedTupleDataCon boxity arity+      _          -> panic "getTupleDataConName: impossible"++{-+Note [Uniques for wired-in prelude things and known tags]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Allocation of unique supply characters:+        v,u: for renumbering value-, and usage- vars.+        B:   builtin+        C-E: pseudo uniques     (used in native-code generator)+        I:   GHCi evaluation+        X:   uniques from mkLocalUnique+        _:   unifiable tyvars   (above)+        0-9: prelude things below+             (no numbers left any more..)+        ::   (prelude) parallel array data constructors++        other a-z: lower case chars for unique supplies.  Used so far:++        a       TypeChecking?+        b       Boxing tycons & datacons+        c       StgToCmm/Renamer+        d       desugarer+        f       AbsC flattener+        i       TypeChecking interface files+        j       constraint tuple superclass selectors+        k       constraint tuple tycons+        m       constraint tuple datacons+        n       Native/LLVM codegen+        r       Hsc name cache+        s       simplifier+        u       Cmm pipeline+        y       GHCi bytecode generator+        z       anonymous sums++Note [Related uniques for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* All wired in tycons actually use *two* uniques:+  * u: the TyCon itself+  * u+1: the TyConRepName of the TyCon (for use with TypeRep)+  The "+1" is implemented in tyConRepNameUnique.+  If this ever changes, make sure to also change the treatment for boxing tycons.++* All wired in datacons use *three* uniques:+  * u: the DataCon itself+  * u+1: its worker Id+  * u+2: the TyConRepName of the promoted TyCon+  No wired-in datacons have wrappers.+  The "+1" is implemented in dataConWorkerUnique and the "+2" is in dataConTyRepNameUnique.+  If this ever changes, make sure to also change the treatment for boxing tycons.++* Because boxing tycons (see Note [Boxing constructors] in GHC.Builtin.Types)+  come with both a tycon and a datacon, each one takes up five slots, combining+  the two cases above. Getting from the tycon to the datacon (by adding 2)+  is implemented in boxingDataConUnique.+-}++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPrimOpIdUnique       :: Int -> Unique+-- See Note [Primop wrappers] in GHC.Builtin.PrimOps.+mkPrimOpWrapperUnique  :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique++mkAlphaTyVarUnique   i = mkUniqueInt '1' i+mkPreludeClassUnique i = mkUniqueInt '2' i++--------------------------------------------------+mkPrimOpIdUnique op         = mkUniqueInt '9' (2*op)+mkPrimOpWrapperUnique op    = mkUniqueInt '9' (2*op+1)+mkPreludeMiscIdUnique  i    = mkUniqueInt '0' i++mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique++mkBuiltinUnique i = mkUniqueInt 'B' i+mkPseudoUniqueE i = mkUniqueInt 'E' i -- used in NCG spiller to create spill VirtualRegs++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique+mkRegSingleUnique = mkUniqueInt 'R'+mkRegSubUnique    = mkUniqueInt 'S'+mkRegPairUnique   = mkUniqueInt 'P'+mkRegClassUnique  = mkUniqueInt 'L'++mkCostCentreUnique :: Int -> Unique+mkCostCentreUnique = mkUniqueInt 'C'++varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique :: Unique+varNSUnique    = mkUnique 'i' 0+dataNSUnique   = mkUnique 'd' 0+tvNSUnique     = mkUnique 'v' 0+tcNSUnique     = mkUnique 'c' 0++mkFldNSUnique :: FastString -> Unique+mkFldNSUnique fs = mkUniqueInt 'f' (uniqueOfFS fs)++isFldNSUnique :: Unique -> Bool+isFldNSUnique uniq = case unpkUnique uniq of+  (tag, _) -> tag == 'f'++initExitJoinUnique :: Unique+initExitJoinUnique = mkUnique 's' 0++--------------------------------------------------+-- Wired-in type constructor keys occupy *two* slots:+-- See Note [Related uniques for wired-in things]++mkPreludeTyConUnique   :: Int -> Unique+mkPreludeTyConUnique i = mkUniqueInt '3' (2*i)++tyConRepNameUnique :: Unique -> Unique+tyConRepNameUnique  u = incrUnique u++--------------------------------------------------+-- Wired-in data constructor keys occupy *three* slots:+-- See Note [Related uniques for wired-in things]++mkPreludeDataConUnique :: Int -> Unique+mkPreludeDataConUnique i = mkUniqueInt '6' (3*i)    -- Must be alphabetic++dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique+dataConWorkerUnique  u = incrUnique u+dataConTyRepNameUnique u = stepUnique u 2++--------------------------------------------------+-- The data constructors of RuntimeRep occupy *five* slots:+-- See Note [Related uniques for wired-in things]+--+--    Example: WordRep+--+-- * u: the TyCon of the boxing data type WordBox+-- * u+1: the TyConRepName of the boxing data type+-- * u+2: the DataCon for MkWordBox+-- * u+3: the worker id for MkWordBox+-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox+--+-- Note carefully that+-- * u,u+1 are in sync with the conventions for+--          wired-in type constructors, above+-- * u+2,u+3,u+4 are in sync with the conventions for+--               wired-in data constructors, above+-- A little delicate!++mkBoxingTyConUnique :: Int -> Unique+mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i)++boxingDataConUnique :: Unique -> Unique+boxingDataConUnique u = stepUnique u 2
+ GHC/Builtin/Uniques.hs-boot view
@@ -0,0 +1,36 @@+module GHC.Builtin.Uniques where++import GHC.Prelude+import GHC.Types.Unique+import {-# SOURCE #-} GHC.Types.Name+import GHC.Types.Basic++-- Needed by GHC.Builtin.Types+knownUniqueName :: Unique -> Maybe Name++mkSumTyConUnique :: Arity -> Unique+mkSumDataConUnique :: ConTagZ -> Arity -> Unique++mkCTupleTyConUnique :: Arity -> Unique+mkCTupleDataConUnique :: Arity -> Unique++mkTupleTyConUnique :: Boxity -> Arity -> Unique+mkTupleDataConUnique :: Boxity -> Arity -> Unique++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPrimOpIdUnique       :: Int -> Unique+mkPrimOpWrapperUnique  :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique++mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique++initExitJoinUnique :: Unique++mkPreludeTyConUnique   :: Int -> Unique+tyConRepNameUnique :: Unique -> Unique++mkPreludeDataConUnique :: Int -> Unique+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique
+ GHC/Builtin/Utils.hs view
@@ -0,0 +1,341 @@+{-+(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,+        ghcPrimWarns,+        ghcPrimFixities,++        -- * 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.Fixity+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id.Make+import GHC.Types.SourceText+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Types.TyThing+import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )++import GHC.Utils.Outputable+import GHC.Utils.Misc as Utils+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Parser.Annotation+import GHC.Hs.Doc+import GHC.Unit.Module.ModIface (IfaceExport)+import GHC.Unit.Module.Warnings++import GHC.Data.List.SetOps++import Control.Applicative ((<|>))+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 badNamesDoc <- knownKeyNamesOkay all_names+  = pprPanic "badAllKnownKeyNames" badNamesDoc+  | 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 SDoc+knownKeyNamesOkay all_names+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names+  = Just $ text "    Out-of-range known-key uniques: " <>+           brackets (pprWithCommas (ppr . nameOccName) ns)+  | null badNamesPairs+  = Nothing+  | otherwise+  = Just badNamesDoc+  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+    badNamesDoc :: SDoc+    badNamesDoc  = vcat $ map pairToDoc badNamesPairs++    pairToDoc :: (Unique, [Name]) -> SDoc+    pairToDoc (uniq, ns) = text "        " <>+                           pprUniqueAlways uniq <>+                           text ": " <>+                           brackets (pprWithCommas (ppr . 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+    findName (nameStr, doc)+      | Just name <- lookupFsEnv ghcPrimNames nameStr+      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])+      | otherwise = Nothing++ghcPrimNames :: FastStringEnv Name+ghcPrimNames+  = mkFsEnv+    [ (occNameFS $ nameOccName name, name)+    | name <-+        map idName ghcPrimIds +++        map idName allThePrimOpIds +++        map tyConName exposedPrimTyCons+    ]++-- See Note [GHC.Prim Deprecations]+ghcPrimWarns :: Warnings a+ghcPrimWarns = WarnSome+  -- declaration warnings+  (map mk_decl_dep primOpDeprecations)+  -- export warnings+  []+  where+    mk_txt msg =+      DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText msg Nothing) []]+    mk_decl_dep (occ, msg) = (occ, mk_txt msg)++ghcPrimFixities :: [(OccName,Fixity)]+ghcPrimFixities = fixities+  where+    -- The fixity listed here for @`seq`@ should match+    -- those in primops.txt.pp (from which Haddock docs are generated).+    fixities = (getOccName seqId, Fixity 0 InfixR)+             : mapMaybe mkFixity allThePrimOps+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op++{-+Note [GHC.Prim Docs]+~~~~~~~~~~~~~~~~~~~~+For haddocks of GHC.Prim we generate a dummy haskell file (gen_hs_source) that+contains the type signatures and the comments (but no implementations)+specifically for consumption by haddock.++GHCi's :doc command reads directly from ModIface's though, and GHC.Prim has a+wired-in iface that has nothing to do with the above haskell file. The code+below converts primops.txt into an intermediate form that would later be turned+into a proper DeclDocMap.++We output the docs as a list of pairs (name, docs). We use stringy names here+because mapping names to "Name"s is difficult for things like primtypes and+pseudoops.++Note [GHC.Prim Deprecations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Like Haddock documentation, we must record deprecation pragmas in two places:+in the GHC.Prim source module consumed by Haddock, and in the+declarations wired-in to GHC. To do the following we generate+GHC.Builtin.PrimOps.primOpDeprecations, a list of (OccName, DeprecationMessage)+pairs. We insert these deprecations into the mi_warns field of GHC.Prim's ModIface,+as though they were written in a source module.+-}+++{-+************************************************************************+*                                                                      *+            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"
+ GHC/Builtin/primops.txt.pp view
@@ -0,0 +1,4488 @@+-----------------------------------------------------------------------+--+-- (c) 2010 The University of Glasgow+--+-- Primitive Operations and Types+--+-- For more information on PrimOps, see+--   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops+--+-----------------------------------------------------------------------++-- This file is processed by the utility program genprimopcode to produce+-- a number of include files within the compiler and optionally to produce+-- human-readable documentation.+--+-- It should first be preprocessed.+--+-- Note in particular that Haskell block-style comments are not recognized+-- here, so stick to '--' (even for Notes spanning multiple lines).++-- Note [GHC.Prim]+-- ~~~~~~~~~~~~~~~+-- GHC.Prim is a special module:+--+-- * It can be imported by any module (import GHC.Prim).+--   However, in the future we might change which functions are primitives+--   and which are defined in Haskell.+--   Users should import GHC.Exts, which reexports GHC.Prim and is more stable.+--   In particular, we might move some of the primops to 'foreign import prim'+--   (see ticket #16929 and Note [When do out-of-line primops go in primops.txt.pp])+--+-- * It provides primitives of three sorts:+--   - primitive types such as Int64#, MutableByteArray#+--   - primops such as (+#), newTVar#, touch#+--   - pseudoops such as realWorld#, nullAddr#+--+-- * The pseudoops are described in Note [ghcPrimIds (aka pseudoops)]+--   in GHC.Types.Id.Make.+--+-- * The primitives (primtypes, primops, pseudoops) cannot be defined in+--   source Haskell.+--   There is no GHC/Prim.hs file with definitions.+--   Instead, we support importing GHC.Prim by manually defining its+--   ModIface (see Iface.Load.ghcPrimIface).+--+-- * The primitives are listed in this file, primops.txt.pp.+--   It goes through CPP, which creates primops.txt.+--   It is then consumed by the utility program genprimopcode, which produces+--   the following three types of files.+--+--   1. The files with extension .hs-incl.+--      They can be found by grepping for hs-incl.+--      They are #included in compiler sources.+--+--      One of them, primop-data-decl.hs-incl, defines the PrimOp type:+--        data PrimOp+--         = IntAddOp+--         | IntSubOp+--         | CharGtOp+--         | CharGeOp+--         | ...+--+--      The remaining files define properties of the primops+--      by pattern matching, for example:+--        primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)+--        primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)+--        ...+--      This includes fixity, has-side-effects, commutability,+--      IDs used to generate Uniques etc.+--+--      Additionally, we pattern match on PrimOp when generating Cmm in+--      GHC/StgToCmm/Prim.hs.+--+--   2. The dummy Prim.hs file, which is used for Haddock and+--      contains descriptions taken from primops.txt.pp.+--      All definitions are replaced by placeholders.+--      See Note [GHC.Prim Docs] in GHC.Builtin.Utils.+--+--   3. The module PrimopWrappers.hs, which wraps every call for GHCi;+--      see Note [Primop wrappers] in GHC.Builtin.Primops for details.+--+-- * This file does not list internal-only equality types+--   (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken#+--   in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim.+--   Every export of GHC.Prim should be in listed in this file.+--+-- * The primitive types should be listed in primTyCons in Builtin.Types.Prim+--   in addition to primops.txt.pp.+--   (This task should be delegated to genprimopcode in the future.)+--+--+--+-- Information on how PrimOps are implemented and the steps necessary to+-- add a new one can be found in the Commentary:+--+--  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops+--+-- This file is divided into named sections, each containing or more+-- primop entries. Section headers have the format:+--+--      section "section-name" {haddock-description}+--+-- This information is used solely when producing documentation; it is+-- otherwise ignored.  The haddock-description is optional.+--+-- The format of each primop entry is as follows:+--+--      primop internal-name "name-in-program-text" category type {haddock-description} attributes++-- The default attribute values which apply if you don't specify+-- other ones.  Attribute values can be True, False, or arbitrary+-- text between curly brackets.  This is a kludge to enable+-- processors of this file to easily get hold of simple info+-- (eg, out_of_line), whilst avoiding parsing complex expressions+-- needed for strictness info.+--+-- type refers to the general category of the primop. There are only two:+--+--  * Compare:   A comparison operation of the shape a -> a -> Int#+--  * GenPrimOp: Any other sort of primop+--++-- The vector attribute is rather special. It takes a list of 3-tuples, each of+-- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of+-- the elements in the vector; LENGTH is the length of the vector; and+-- SCALAR_TYPE is the scalar type used to inject to/project from vector+-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example,+-- to broadcast a scalar value to a vector whose elements are of type Int8, we+-- use an Int#.++-- When a primtype or primop has a vector attribute, it is instantiated at each+-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to+-- define a family of types or primops. Vector support also adds three new+-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types+-- derived from the 3-tuple. For the 3-tuple <Int64#,Int64#,2>, VECTOR expands to+-- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #).++defaults+   effect           = NoEffect -- See Note [Classifying primop effects] in GHC.Builtin.PrimOps+   can_fail_warning = WarnIfEffectIsCanFail+   out_of_line      = False   -- See Note [When do out-of-line primops go in primops.txt.pp]+   commutable       = False+   code_size        = { primOpCodeSizeDefault }+   work_free        = { primOpCodeSize _thisOp == 0 }+   cheap            = { primOpOkForSpeculation _thisOp }+   strictness       = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }+   fixity           = Nothing+   vector           = []+   deprecated_msg   = {}      -- A non-empty message indicates deprecation+   div_like         = False   -- Second argument expected to be non zero - used for tests+   defined_bits     = Nothing -- The number of bits the operation is defined for (if not all bits)++-- Note [When do out-of-line primops go in primops.txt.pp]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Out of line primops are those with a C-- implementation. But that+-- doesn't mean they *just* have an C-- implementation. As mentioned in+-- Note [Inlining out-of-line primops and heap checks], some out-of-line+-- primops also have additional internal implementations under certain+-- conditions. Now that `foreign import prim` exists, only those primops+-- which have both internal and external implementations ought to be+-- this file. The rest aren't really primops, since they don't need+-- bespoke compiler support but just a general way to interface with+-- C--. They are just foreign calls.+--+-- Unfortunately, for the time being most of the primops which should be+-- moved according to the previous paragraph can't yet. There are some+-- superficial restrictions in `foreign import prim` which must be fixed+-- first. Specifically, `foreign import prim` always requires:+--+--   - No polymorphism in type+--   - `strictness       = <default>`+--   - `effect           = ReadWriteEffect`+--+-- https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue,+-- and has a table of which external-only primops are blocked by which+-- of these. Hopefully those restrictions are relaxed so the rest of+-- those can be moved over.+--+-- 'module GHC.Prim.Ext is a temporarily "holding ground" for primops+-- that were formally in here, until they can be given a better home.+-- Likewise, their underlying C-- implementation need not live in the+-- RTS either. Best case (in my view), both the C-- and `foreign import+-- prim` can be moved to a small library tailured to the features being+-- implemented and dependencies of those features.++-- Note [Levity and representation polymorphic primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In the types of primops in this module,+--+-- * The names `a,b,c,s` stand for type variables of kind Type+--+-- * The names `a_reppoly` and `b_reppoly` stand for representation-polymorphic+--   type variables. For example:+--      op :: a_reppoly -> b_reppoly -> Int+--   really means+--      op :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}+--                   (a :: TYPE rep1) (b :: TYPE rep2).+--            a -> b -> Int+--+--   Note:+--     - `a_reppoly` and `b_reppoly` have independent `RuntimeRep`s, which+--       are *inferred* type variables.+--     - any use-site of a primop in which the kind of a type appearing in+--       negative position is `a_reppoly` and `b_reppoly`+--       must instantiate the representation to a concrete RuntimeRep.+--       See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+--     - `a_reppoly` and `b_reppoly` share textual names with `a` and `b` (respectively).+--       This means one shouldn't write a type involving both `a` and `a_reppoly`.+--+-- * The names `a_levpoly` and `b_levpoly` stand for levity-polymorphic+--   type variables, similar to `a_reppoly` and `b_reppoly`.+--   For example:+--      op :: a_levpoly -> b_levpoly -> Int+--   really means+--      op :: forall {l :: Levity} {k :: Levity}+--                   (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)).+--            a -> b -> Int+--  Note:+--     - `a_levpoly` and `b_levpoly` have independent levities `l` and `k` (respectively), and+--       these are inferred (not specified), as seen from the curly brackets.+--     - any use site of a primop in which `a_levpoly` or `b_levpoly` appear as+--       the kind of a type appearing in negative position in the type of the+--       primop, we require the Levity to be instantiated to a concrete Levity.+--     - `a_levpoly` and `b_levpoly` share textual names with `a` and `b` (respectively).+--       This means one shouldn't write a type involving both `a` and `a_levpoly`,+--       nor `a_levpoly` and `a_reppoly`, etc.++section "The word size story."+        {Haskell98 specifies that signed integers (type 'Int')+         must contain at least 30 bits. GHC always implements+         'Int' using the primitive type 'Int#', whose size equals+         the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@.+         This is normally set based on the RTS @ghcautoconf.h@ parameter+         @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64+         bits on 64-bit machines.++         GHC also implements a primitive unsigned integer type+         'Word#' which always has the same number of bits as 'Int#'.++         In addition, GHC supports families of explicit-sized integers+         and words at 8, 16, 32, and 64 bits, with the usual+         arithmetic operations, comparisons, and a range of+         conversions.++         Finally, there are strongly deprecated primops for coercing+         between 'Addr#', the primitive type of machine+         addresses, and 'Int#'.  These are pretty bogus anyway,+         but will work on existing 32-bit and 64-bit GHC targets; they+         are completely bogus when tag bits are used in 'Int#',+         so are not available in this case.}++------------------------------------------------------------------------+section "Char#"+        {Operations on 31-bit characters.}+------------------------------------------------------------------------++primtype Char#++primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Int#+primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Int#++primop   CharEqOp  "eqChar#"   Compare+   Char# -> Char# -> Int#+   with commutable = True++primop   CharNeOp  "neChar#"   Compare+   Char# -> Char# -> Int#+   with commutable = True++primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Int#+primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Int#++primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#+   with code_size = 0++------------------------------------------------------------------------+section "Int8#"+        {Operations on 8-bit integers.}+------------------------------------------------------------------------++primtype Int8#++primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int#+primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8#++primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#++primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    commutable = True++primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8#++primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    commutable = True++primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    effect = CanFail+    div_like = True++primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    effect = CanFail+    div_like = True+++primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)+  with+    effect = CanFail+    div_like = True++primop Int8SllOp "uncheckedShiftLInt8#"  GenPrimOp Int8# -> Int# -> Int8#+primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#+primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8#++primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8#+   with code_size = 0++primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int#+primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int#+primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int#+primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int#+primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int#+primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int#++------------------------------------------------------------------------+section "Word8#"+        {Operations on 8-bit unsigned words.}+------------------------------------------------------------------------++primtype Word8#++primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word#+primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8#++primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    commutable = True++primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8#++primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    commutable = True++primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    effect = CanFail+    div_like = True++primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    effect = CanFail+    div_like = True++primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)+  with+    effect = CanFail+    div_like = True++primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#++primop Word8SllOp "uncheckedShiftLWord8#"  GenPrimOp Word8# -> Int# -> Word8#+primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8#++primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8#+   with code_size = 0++primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int#+primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int#+primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int#+primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int#+primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int#+primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int#++------------------------------------------------------------------------+section "Int16#"+        {Operations on 16-bit integers.}+------------------------------------------------------------------------++primtype Int16#++primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int#+primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16#++primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#++primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    commutable = True++primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16#++primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    commutable = True++primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    effect = CanFail+    div_like = True++primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    effect = CanFail+    div_like = True++primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)+  with+    effect = CanFail+    div_like = True++primop Int16SllOp "uncheckedShiftLInt16#"  GenPrimOp Int16# -> Int# -> Int16#+primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#+primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16#++primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16#+   with code_size = 0++primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int#+primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int#+primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int#+primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int#+primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int#+primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int#++------------------------------------------------------------------------+section "Word16#"+        {Operations on 16-bit unsigned words.}+------------------------------------------------------------------------++primtype Word16#++primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word#+primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16#++primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    commutable = True++primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16#++primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    commutable = True++primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    effect = CanFail+    div_like = True++primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    effect = CanFail+    div_like = True++primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)+  with+    effect = CanFail+    div_like = True++primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#++primop Word16SllOp "uncheckedShiftLWord16#"  GenPrimOp Word16# -> Int# -> Word16#+primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16#++primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16#+   with code_size = 0++primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int#+primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int#+primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int#+primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int#+primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int#+primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int#++------------------------------------------------------------------------+section "Int32#"+        {Operations on 32-bit integers.}+------------------------------------------------------------------------++primtype Int32#++primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int#+primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32#++primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32#++primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    commutable = True++primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32#++primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    commutable = True++primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    effect = CanFail+    div_like = True++primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    effect = CanFail+    div_like = True++primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)+  with+    effect = CanFail+    div_like = True++primop Int32SllOp "uncheckedShiftLInt32#"  GenPrimOp Int32# -> Int# -> Int32#+primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#+primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32#++primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32#+   with code_size = 0++primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int#+primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int#+primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int#+primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int#+primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int#+primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int#++------------------------------------------------------------------------+section "Word32#"+        {Operations on 32-bit unsigned words.}+------------------------------------------------------------------------++primtype Word32#++primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word#+primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32#++primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    commutable = True++primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32#++primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    commutable = True++primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    effect = CanFail+    div_like = True++primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    effect = CanFail+    div_like = True++primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)+  with+    effect = CanFail+    div_like = True++primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32#++primop Word32SllOp "uncheckedShiftLWord32#"  GenPrimOp Word32# -> Int# -> Word32#+primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32#++primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32#+   with code_size = 0++primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int#+primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int#+primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int#+primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int#+primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int#+primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int#++------------------------------------------------------------------------+section "Int64#"+        {Operations on 64-bit signed words.}+------------------------------------------------------------------------++primtype Int64#++primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int#+primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64#++primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64#++primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    commutable = True++primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64#++primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    commutable = True++primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    effect = CanFail+    div_like = True++primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    effect = CanFail+    div_like = True++primop Int64SllOp "uncheckedIShiftL64#"  GenPrimOp Int64# -> Int# -> Int64#+primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#+primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64#++primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64#+   with code_size = 0++primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int#+primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int#+primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int#+primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int#+primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int#+primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int#++------------------------------------------------------------------------+section "Word64#"+        {Operations on 64-bit unsigned words.}+------------------------------------------------------------------------++primtype Word64#++primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word#+primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64#++primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    commutable = True++primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64#++primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    commutable = True++primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    effect = CanFail+    div_like = True++primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    effect = CanFail+    div_like = True++primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64#++primop Word64SllOp "uncheckedShiftL64#"  GenPrimOp Word64# -> Int# -> Word64#+primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64#++primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64#+   with code_size = 0++primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int#+primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int#+primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int#+primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int#+primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int#+primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int#++------------------------------------------------------------------------+section "Int#"+        {Operations on native-size integers (32+ bits).}+------------------------------------------------------------------------++primtype Int#++primop   IntAddOp    "+#"    GenPrimOp+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infixl 6++primop   IntSubOp    "-#"    GenPrimOp   Int# -> Int# -> Int#+   with fixity = infixl 6++primop   IntMulOp    "*#"+   GenPrimOp   Int# -> Int# -> Int#+   {Low word of signed integer multiply.}+   with commutable = True+        fixity = infixl 7++primop   IntMul2Op    "timesInt2#" GenPrimOp+   Int# -> Int# -> (# Int#, Int#, Int# #)+   {Return a triple (isHighNeeded,high,low) where high and low are respectively+   the high and low bits of the double-word result. isHighNeeded is a cheap way+   to test if the high word is a sign-extension of the low word (isHighNeeded =+   0#) or not (isHighNeeded = 1#).}++primop   IntMulMayOfloOp  "mulIntMayOflo#"+   GenPrimOp   Int# -> Int# -> Int#+   {Return non-zero if there is any possibility that the upper word of a+    signed integer multiply might contain useful information.  Return+    zero only if you are completely sure that no overflow can occur.+    On a 32-bit platform, the recommended implementation is to do a+    32 x 32 -> 64 signed multiply, and subtract result[63:32] from+    (result[31] >>signed 31).  If this is zero, meaning that the+    upper word is merely a sign extension of the lower one, no+    overflow can occur.++    On a 64-bit platform it is not always possible to+    acquire the top 64 bits of the result.  Therefore, a recommended+    implementation is to take the absolute value of both operands, and+    return 0 iff bits[63:31] of them are zero, since that means that their+    magnitudes fit within 31 bits, so the magnitude of the product must fit+    into 62 bits.++    If in doubt, return non-zero, but do make an effort to create the+    correct answer for small args, since otherwise the performance of+    @(*) :: Integer -> Integer -> Integer@ will be poor.+   }+   with commutable = True++primop   IntQuotOp    "quotInt#"    GenPrimOp+   Int# -> Int# -> Int#+   {Rounds towards zero. The behavior is undefined if the second argument is+    zero.+   }+   with effect = CanFail+        div_like = True++primop   IntRemOp    "remInt#"    GenPrimOp+   Int# -> Int# -> Int#+   {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The+    behavior is undefined if the second argument is zero.+   }+   with effect = CanFail+        div_like = True++primop   IntQuotRemOp "quotRemInt#"    GenPrimOp+   Int# -> Int# -> (# Int#, Int# #)+   {Rounds towards zero.}+   with effect = CanFail+        div_like = True++primop   IntAndOp   "andI#"   GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "and".}+   with commutable = True++primop   IntOrOp   "orI#"     GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "or".}+   with commutable = True++primop   IntXorOp   "xorI#"   GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "xor".}+   with commutable = True++primop   IntNotOp   "notI#"   GenPrimOp   Int# -> Int#+   {Bitwise "not", also known as the binary complement.}++primop   IntNegOp    "negateInt#"    GenPrimOp   Int# -> Int#+   {Unary negation.+    Since the negative 'Int#' range extends one further than the+    positive range, 'negateInt#' of the most negative number is an+    identity operation. This way, 'negateInt#' is always its own inverse.}++primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)+         {Add signed integers reporting overflow.+          First member of result is the sum truncated to an 'Int#';+          second member is zero if the true sum fits in an 'Int#',+          nonzero if overflow occurred (the sum is either too large+          or too small to fit in an 'Int#').}+   with code_size = 2+        commutable = True++primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)+         {Subtract signed integers reporting overflow.+          First member of result is the difference truncated to an 'Int#';+          second member is zero if the true difference fits in an 'Int#',+          nonzero if overflow occurred (the difference is either too large+          or too small to fit in an 'Int#').}+   with code_size = 2++primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntEqOp  "==#"   Compare+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infix 4++primop   IntNeOp  "/=#"   Compare+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infix 4++primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#+   with code_size = 0++primop   IntToWordOp "int2Word#" GenPrimOp Int# -> Word#+   with code_size = 0++primop   IntToFloatOp   "int2Float#"      GenPrimOp  Int# -> Float#+   {Convert an 'Int#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Float#' 1# == 1.0#@}+primop   IntToDoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#+   {Convert an 'Int#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Double#' 1# == 1.0##@}++primop   WordToFloatOp   "word2Float#"      GenPrimOp  Word# -> Float#+   {Convert an 'Word#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Float#' 1## == 1.0#@}+primop   WordToDoubleOp   "word2Double#"          GenPrimOp  Word# -> Double#+   {Convert an 'Word#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Double#' 1## == 1.0##@}++primop   IntSllOp   "uncheckedIShiftL#" GenPrimOp  Int# -> Int# -> Int#+         {Shift left.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   IntSraOp   "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int#+         {Shift right arithmetic.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   IntSrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#+         {Shift right logical.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}++------------------------------------------------------------------------+section "Word#"+        {Operations on native-sized unsigned words (32+ bits).}+------------------------------------------------------------------------++primtype Word#++primop   WordAddOp   "plusWord#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordAddCOp   "addWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)+         {Add unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.}+   with code_size = 2+        commutable = True++primop   WordSubCOp   "subWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)+         {Subtract unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow.}+   with code_size = 2++primop   WordAdd2Op   "plusWord2#"   GenPrimOp   Word# -> Word# -> (# Word#, Word# #)+         {Add unsigned integers, with the high part (carry) in the first+          component of the returned pair and the low part in the second+          component of the pair. See also 'addWordC#'.}+   with code_size = 2+        commutable = True++primop   WordSubOp   "minusWord#"   GenPrimOp   Word# -> Word# -> Word#++primop   WordMulOp   "timesWord#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++-- Returns (# high, low #)+primop   WordMul2Op  "timesWord2#"   GenPrimOp+   Word# -> Word# -> (# Word#, Word# #)+   with commutable = True++primop   WordQuotOp   "quotWord#"   GenPrimOp   Word# -> Word# -> Word#+   with effect = CanFail+        div_like = True++primop   WordRemOp   "remWord#"   GenPrimOp   Word# -> Word# -> Word#+   with effect = CanFail+        div_like = True++primop   WordQuotRemOp "quotRemWord#" GenPrimOp+   Word# -> Word# -> (# Word#, Word# #)+   with effect = CanFail+        div_like = True++primop   WordQuotRem2Op "quotRemWord2#" GenPrimOp+   Word# -> Word# -> Word# -> (# Word#, Word# #)+         { Takes high word of dividend, then low word of dividend, then divisor.+           Requires that high word < divisor.}+   with effect = CanFail+        div_like = True++primop   WordAndOp   "and#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordOrOp   "or#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordXorOp   "xor#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordNotOp   "not#"   GenPrimOp   Word# -> Word#++primop   WordSllOp   "uncheckedShiftL#"   GenPrimOp   Word# -> Int# -> Word#+         {Shift left logical.   Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   WordSrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#+         {Shift right logical.   Result undefined if shift  amount is not+          in the range 0 to word size - 1 inclusive.}++primop   WordToIntOp   "word2Int#"   GenPrimOp   Word# -> Int#+   with code_size = 0++primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Int#+primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Int#+primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Int#+primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Int#+primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Int#+primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Int#++primop   PopCnt8Op   "popCnt8#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 8 bits of a word.}+primop   PopCnt16Op   "popCnt16#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 16 bits of a word.}+primop   PopCnt32Op   "popCnt32#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 32 bits of a word.}+primop   PopCnt64Op   "popCnt64#"   GenPrimOp   Word64# -> Word#+    {Count the number of set bits in a 64-bit word.}+primop   PopCntOp   "popCnt#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in a word.}++primop   Pdep8Op   "pdep8#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep16Op   "pdep16#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep32Op   "pdep32#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep64Op   "pdep64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Deposit bits to a word at locations specified by a mask.++    @since 0.5.2.0}+primop   PdepOp   "pdep#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to a word at locations specified by a mask, aka+    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pdep :: Word -> Word -> Word+    > pdep src mask = go 0 src mask+    >   where+    >     go :: Word -> Word -> Word -> Word+    >     go result _ 0 = result+    >     go result src mask = go newResult newSrc newMask+    >       where+    >         maskCtz   = countTrailingZeros mask+    >         newResult = if testBit src 0 then setBit result maskCtz else result+    >         newSrc    = src `shiftR` 1+    >         newMask   = clearBit mask maskCtz++    @since 0.5.2.0}++primop   Pext8Op   "pext8#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext16Op   "pext16#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext32Op   "pext32#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext64Op   "pext64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Extract bits from a word at locations specified by a mask.++    @since 0.5.2.0}+primop   PextOp   "pext#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from a word at locations specified by a mask, aka+    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pext :: Word -> Word -> Word+    > pext src mask = loop 0 0 0+    >   where+    >     loop i count result+    >       | i >= finiteBitSize (0 :: Word)+    >       = result+    >       | testBit mask i+    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)+    >       | otherwise+    >       = loop (i + 1) count result++    @since 0.5.2.0}++primop   Clz8Op   "clz8#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 8 bits of a word.}+primop   Clz16Op   "clz16#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 16 bits of a word.}+primop   Clz32Op   "clz32#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 32 bits of a word.}+primop   Clz64Op   "clz64#" GenPrimOp Word64# -> Word#+    {Count leading zeros in a 64-bit word.}+primop   ClzOp     "clz#"   GenPrimOp   Word# -> Word#+    {Count leading zeros in a word.}++primop   Ctz8Op   "ctz8#"  GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 8 bits of a word.}+primop   Ctz16Op   "ctz16#" GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 16 bits of a word.}+primop   Ctz32Op   "ctz32#" GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 32 bits of a word.}+primop   Ctz64Op   "ctz64#" GenPrimOp Word64# -> Word#+    {Count trailing zeros in a 64-bit word.}+primop   CtzOp     "ctz#"   GenPrimOp   Word# -> Word#+    {Count trailing zeros in a word.}++primop   BSwap16Op   "byteSwap16#"   GenPrimOp   Word# -> Word#+    {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }+    with defined_bits = 16+primop   BSwap32Op   "byteSwap32#"   GenPrimOp   Word# -> Word#+    {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }+    with defined_bits = 32+primop   BSwap64Op   "byteSwap64#"   GenPrimOp   Word64# -> Word64#+    {Swap bytes in a 64 bits of a word.}+primop   BSwapOp     "byteSwap#"     GenPrimOp   Word# -> Word#+    {Swap bytes in a word.}++primop   BRev8Op    "bitReverse8#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 8-bit word.}+    with defined_bits = 8+primop   BRev16Op   "bitReverse16#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 16-bit word.}+    with defined_bits = 16+primop   BRev32Op   "bitReverse32#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 32-bit word.}+    with defined_bits = 32+primop   BRev64Op   "bitReverse64#"   GenPrimOp   Word64# -> Word64#+    {Reverse the order of the bits in a 64-bit word.}+primop   BRevOp     "bitReverse#"     GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a word.}++------------------------------------------------------------------------+section "Narrowings"+        {Explicit narrowing of native-sized ints or words.}+------------------------------------------------------------------------++primop   Narrow8IntOp      "narrow8Int#"      GenPrimOp   Int# -> Int#+primop   Narrow16IntOp     "narrow16Int#"     GenPrimOp   Int# -> Int#+primop   Narrow32IntOp     "narrow32Int#"     GenPrimOp   Int# -> Int#+primop   Narrow8WordOp     "narrow8Word#"     GenPrimOp   Word# -> Word#+primop   Narrow16WordOp    "narrow16Word#"    GenPrimOp   Word# -> Word#+primop   Narrow32WordOp    "narrow32Word#"    GenPrimOp   Word# -> Word#++------------------------------------------------------------------------+section "Double#"+        {Operations on double-precision (64 bit) floating-point numbers.}+------------------------------------------------------------------------++primtype Double#++primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop DoubleEqOp "==##"   Compare+   Double# -> Double# -> Int#+   with commutable = True+        fixity = infix 4++primop DoubleNeOp "/=##"   Compare+   Double# -> Double# -> Int#+   with commutable = True+        fixity = infix 4++primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleMinOp   "minDouble#"      GenPrimOp+   Double# -> Double# -> Double#+   {Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   DoubleMaxOp   "maxDouble#"      GenPrimOp+   Double# -> Double# -> Double#+   {Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   DoubleAddOp   "+##"   GenPrimOp+   Double# -> Double# -> Double#+   with commutable = True+        fixity = infixl 6++primop   DoubleSubOp   "-##"   GenPrimOp   Double# -> Double# -> Double#+   with fixity = infixl 6++primop   DoubleMulOp   "*##"   GenPrimOp+   Double# -> Double# -> Double#+   with commutable = True+        fixity = infixl 7++primop   DoubleDivOp   "/##"   GenPrimOp+   Double# -> Double# -> Double#+   with effect = CanFail -- Can this one really fail?+        fixity = infixl 7++primop   DoubleNegOp   "negateDouble#"  GenPrimOp   Double# -> Double#++primop   DoubleFabsOp  "fabsDouble#"    GenPrimOp   Double# -> Double#++primop   DoubleToIntOp   "double2Int#"          GenPrimOp  Double# -> Int#+   {Truncates a 'Double#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.}++primop   DoubleToFloatOp   "double2Float#" GenPrimOp Double# -> Float#++primop   DoubleExpOp   "expDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleExpM1Op "expm1Double#"    GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleLogOp   "logDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleLog1POp   "log1pDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleSqrtOp   "sqrtDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleSinOp   "sinDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleCosOp   "cosDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleTanOp   "tanDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAsinOp   "asinDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleAcosOp   "acosDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleAtanOp   "atanDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleSinhOp   "sinhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleCoshOp   "coshDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleTanhOp   "tanhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAsinhOp   "asinhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAcoshOp   "acoshDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAtanhOp   "atanhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoublePowerOp   "**##" GenPrimOp+   Double# -> Double# -> Double#+   {Exponentiation.}+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp+   Double# -> (# Int#, Word#, Word#, Int# #)+   {Convert to integer.+    First component of the result is -1 or 1, indicating the sign of the+    mantissa. The next two are the high and low 32 bits of the mantissa+    respectively, and the last is the exponent.}+   with out_of_line = True++primop   DoubleDecode_Int64Op   "decodeDouble_Int64#" GenPrimOp+   Double# -> (# Int64#, Int# #)+   {Decode 'Double#' into mantissa and base-2 exponent.}+   with out_of_line = True++primop CastDoubleToWord64Op "castDoubleToWord64#" GenPrimOp+   Double# -> Word64#+   {Bitcast a 'Double#' into a 'Word64#'}++primop CastWord64ToDoubleOp "castWord64ToDouble#" GenPrimOp+   Word64# -> Double#+   {Bitcast a 'Word64#' into a 'Double#'}++------------------------------------------------------------------------+section "Float#"+        {Operations on single-precision (32-bit) floating-point numbers.}+------------------------------------------------------------------------++primtype Float#++primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Int#+primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Int#++primop   FloatEqOp  "eqFloat#"   Compare+   Float# -> Float# -> Int#+   with commutable = True++primop   FloatNeOp  "neFloat#"   Compare+   Float# -> Float# -> Int#+   with commutable = True++primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Int#+primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#++primop   FloatMinOp   "minFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   {Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   FloatMaxOp   "maxFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   {Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   FloatAddOp   "plusFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with commutable = True++primop   FloatSubOp   "minusFloat#"      GenPrimOp      Float# -> Float# -> Float#++primop   FloatMulOp   "timesFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with commutable = True++primop   FloatDivOp   "divideFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with effect = CanFail++primop   FloatNegOp   "negateFloat#"      GenPrimOp    Float# -> Float#++primop   FloatFabsOp  "fabsFloat#"        GenPrimOp    Float# -> Float#++primop   FloatToIntOp   "float2Int#"      GenPrimOp  Float# -> Int#+   {Truncates a 'Float#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.}++primop   FloatExpOp   "expFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatExpM1Op   "expm1Float#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatLogOp   "logFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatLog1POp  "log1pFloat#"     GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatSqrtOp   "sqrtFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatSinOp   "sinFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatCosOp   "cosFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatTanOp   "tanFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAsinOp   "asinFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatAcosOp   "acosFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatAtanOp   "atanFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatSinhOp   "sinhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatCoshOp   "coshFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatTanhOp   "tanhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAsinhOp   "asinhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAcoshOp   "acoshFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAtanhOp   "atanhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatPowerOp   "powerFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatToDoubleOp   "float2Double#" GenPrimOp  Float# -> Double#++primop   FloatDecode_IntOp   "decodeFloat_Int#" GenPrimOp+   Float# -> (# Int#, Int# #)+   {Convert to integers.+    First 'Int#' in result is the mantissa; second is the exponent.}+   with out_of_line = True++primop CastFloatToWord32Op "castFloatToWord32#" GenPrimOp+   Float# -> Word32#+   {Bitcast a 'Float#' into a 'Word32#'}++primop CastWord32ToFloatOp "castWord32ToFloat#" GenPrimOp+   Word32# -> Float#+   {Bitcast a 'Word32#' into a 'Float#'}++------------------------------------------------------------------------+section "Fused multiply-add operations"+  { #fma#++    The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#'+    implement the operation++    \[+    \lambda\ x\ y\ z \rightarrow x * y + z+    \]++    with a single floating-point rounding operation at the end, as opposed to+    rounding twice (which can accumulate rounding errors).++    These primops can be compiled directly to a single machine instruction on+    architectures that support them. Currently, these are:++      1. x86 with CPUs that support the FMA3 extended instruction set (which+         includes most processors since 2013).+      2. PowerPC.+      3. AArch64.++    This requires users pass the '-mfma' flag to GHC. Otherwise, the primop+    is implemented by falling back to the C standard library, which might+    perform software emulation (this may yield results that are not IEEE+    compliant on some platforms).++    The additional operations 'fmsubFloat#'/'fmsubDouble#',+    'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide+    variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed:++    \[+    \begin{aligned}+    \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt]+    \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt]+    \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt]+    \mathrm{fnmsub}\ x\ y\ z &= - x * y - z+    \end{aligned}+    \]++    }+------------------------------------------------------------------------++primop   FloatFMAdd   "fmaddFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+primop   FloatFMSub   "fmsubFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+primop   FloatFNMAdd   "fnmaddFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+primop   FloatFNMSub   "fnmsubFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}++primop   DoubleFMAdd   "fmaddDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+primop   DoubleFMSub   "fmsubDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+primop   DoubleFNMAdd   "fnmaddDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+primop   DoubleFNMSub   "fnmsubDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}++------------------------------------------------------------------------+section "Arrays"+        {Operations on 'Array#'.}+------------------------------------------------------------------------++primtype Array# a++primtype MutableArray# s a++primop  NewArrayOp "newArray#" GenPrimOp+   Int# -> a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #)+   {Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  ReadArrayOp "readArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  WriteArrayOp "writeArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+   code_size = 2 -- card update too++primop  SizeofArrayOp "sizeofArray#" GenPrimOp+   Array# a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  IndexArrayOp "indexArray#" GenPrimOp+   Array# a_levpoly -> Int# -> (# a_levpoly #)+   {Read from the specified index of an immutable array. The result is packaged+    into an unboxed unary tuple; the result itself is not yet+    evaluated. Pattern matching on the tuple forces the indexing of the+    array to happen but does not evaluate the element itself. Evaluating+    the thunk prevents additional thunks from building up on the+    heap. Avoiding these thunks, in turn, reduces references to the+    argument array, allowing it to be garbage collected more promptly.}+   with+   effect = CanFail++-- Note [primOpEffect of unsafe freezes and thaws]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Mutable and immutable pointer arrays have different info table+-- pointers; this is for the benefit of the garbage collector.+-- Consequently, unsafe freeze/thaw operations on pointer arrays are+-- NOT no-ops: They at least have to update the info table pointer. (For+-- thaw, they also add the array to the mutable set.)+--+-- We don't want to duplicate this, so these operations are considered+-- to have effect = ReadWriteEffect.+--+-- (Actually, these operations /are/ no-ops in the JS backend, where+-- mutable and immutable arrays are the same because JS. But we don't+-- have target-dependent primOpEffect yet.)+--+-- This reasoning does not apply to byte arrays, which the garbage+-- collector can always ignore the contents of.  Their unsafe freeze+-- and thaw operations really are no-ops; their underlying heap+-- objects are always ARR_WORDS.++primop  UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp+   MutableArray# s a_levpoly -> State# s -> (# State# s, Array# a_levpoly #)+   {Make a mutable array immutable, without copying.}+   with+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp+   Array# a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  CopyArrayOp "copyArray#" GenPrimOp+  Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. In the case where+   the source and destination are the same array the source and+   destination regions may overlap.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CloneArrayOp "cloneArray#" GenPrimOp+  Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect -- assumed too expensive to duplicate?+  can_fail_warning = YesWarnCanFail++primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  FreezeArrayOp "freezeArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, Array# a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  ThawArrayOp "thawArray#" GenPrimOp+  Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop CasArrayOp  "casArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {Given an array, an offset, the expected old value, and+    the new value, perform an atomic compare and swap (i.e. write the new+    value if the current value and the old value are the same pointer).+    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns+    the element at the offset after the operation completes. This means that+    on a success the new value is returned, and on a failure the actual old+    value (not the expected one) is returned. Implies a full memory barrier.+    The use of a pointer equality on a boxed value makes this function harder+    to use correctly than 'casIntArray#'. All of the difficulties+    of using 'reallyUnsafePtrEquality#' correctly apply to+    'casArray#' as well.+   }+   with+   out_of_line = True+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+++------------------------------------------------------------------------+section "Small Arrays"++        {Operations on 'SmallArray#'. A 'SmallArray#' works+         just like an 'Array#', but with different space use and+         performance characteristics (that are often useful with small+         arrays). The 'SmallArray#' and 'SmallMutableArray#'+         lack a `card table'. The purpose of a card table is to avoid+         having to scan every element of the array on each GC by+         keeping track of which elements have changed since the last GC+         and only scanning those that have changed. So the consequence+         of there being no card table is that the representation is+         somewhat smaller and the writes are somewhat faster (because+         the card table does not need to be updated). The disadvantage+         of course is that for a 'SmallMutableArray#' the whole+         array has to be scanned on each GC. Thus it is best suited for+         use cases where the mutable array is not long lived, e.g.+         where a mutable array is initialised quickly and then frozen+         to become an immutable 'SmallArray#'.+        }++------------------------------------------------------------------------++primtype SmallArray# a++primtype SmallMutableArray# s a++primop  NewSmallArrayOp "newSmallArray#" GenPrimOp+   Int# -> a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+   {Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+   {Shrink mutable array to new specified size, in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofSmallMutableArray#'.++    Assuming the non-profiling RTS, for the copying garbage collector+    (default) this primitive compiles to an O(1) operation in C--, modifying+    the array in-place. For the non-moving garbage collector, however, the+    time is proportional to the number of elements shrinked out. Backends+    bypassing C-- representation (such as JavaScript) might behave+    differently.++    @since 0.6.1}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail because of the "newSize <= oldSize" requirement++primop  ReadSmallArrayOp "readSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int#+   {Return the number of elements in the array. __Deprecated__, it is+   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@+   operations on the same small mutable array.}+   with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead }++primop  GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> State# s -> (# State# s, Int# #)+   {Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.++   @since 0.6.1}++primop  IndexSmallArrayOp "indexSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+   {Read from specified index of immutable array. Result is packaged into+    an unboxed singleton; the result itself is not yet evaluated.}+   with+   effect = CanFail++primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #)+   {Make a mutable array immutable, without copying.}+   with+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawSmallArrayOp  "unsafeThawSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++-- The code_size is only correct for the case when the copy family of+-- primops aren't inlined. It would be nice to keep track of both.++primop  CopySmallArrayOp "copySmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.}+  with+  out_of_line = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. The source and destination arrays can+   refer to the same array. Both arrays must fully contain the+   specified ranges, but this is not checked.+   The regions are allowed to overlap, although this is only possible when the same+   array is provided as both the source and the destination. }+  with+  out_of_line = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CloneSmallArrayOp "cloneSmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect -- assumed too expensive to duplicate?+  can_fail_warning = YesWarnCanFail++primop  CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop CasSmallArrayOp  "casSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {Unsafe, machine-level atomic compare and swap on an element within an array.+    See the documentation of 'casArray#'.}+   with+   out_of_line = True+   effect = ReadWriteEffect -- Might index out of bounds+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "Byte Arrays"+        {A 'ByteArray#' is a region of+         raw memory in the garbage-collected heap, which is not+         scanned for pointers.+         There are three sets of operations for accessing byte array contents:+         index for reading from immutable byte arrays, and read/write+         for mutable byte arrays.  Each set contains operations for a+         range of useful primitive data types.  Each operation takes+         an offset measured in terms of the size of the primitive type+         being read or written.++         }++------------------------------------------------------------------------++primtype ByteArray#+{+  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,+  which is not scanned for pointers during garbage collection.++  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.+  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.++  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,+  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.++  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.++  The representation on the heap of a Byte Array is:++  > +------------+-----------------+-----------------------++  > |            |                 |                       |+  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |+  > |            |                 |                       |+  > +------------+-----------------+-----------------------+++  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.++  Alternatively, enabling the @UnliftedFFITypes@ extension+  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.+}++primtype MutableByteArray# s+{ A mutable 'ByteAray#'. It can be created in three ways:++  * 'newByteArray#': Create an unpinned array.+  * 'newPinnedByteArray#': This will create a pinned array,+  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.++  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values+  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,+  because no garbage collection happens during these unsafe calls+  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)+  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+  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).+}++primop  NewByteArrayOp_Char "newByteArray#" GenPrimOp+   Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Create a new mutable byte array of specified size (in bytes), in+    the specified state thread. The size of the memory underlying the+    array will be rounded up to the platform's word size.}+   with out_of_line = True+        effect = ReadWriteEffect++primop  NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp+   Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Like 'newByteArray#' but GC guarantees not to move it.}+   with out_of_line = True+        effect = ReadWriteEffect++primop  NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp+   Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Like 'newPinnedByteArray#' but allow specifying an arbitrary+    alignment, which must be a power of two.}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail warning for the "power of two" requirement++primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp+   MutableByteArray# s -> Int#+   {Determine whether a 'MutableByteArray#' is guaranteed not to move+   during GC.}+   with out_of_line = True++primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp+   ByteArray# -> Int#+   {Determine whether a 'ByteArray#' is guaranteed not to move.}+   with out_of_line = True++primop  ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp+   ByteArray# -> Int#+   {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed+    to be copied into compact regions by the user, potentially invalidating+    the results of earlier calls to 'byteArrayContents#'.++    See the section `Pinned Byte Arrays` in the user guide for more information.++    This function also returns true for regular pinned bytearrays.+   }+   with out_of_line = True++primop  MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp+   MutableByteArray# s -> Int#+   { 'isByteArrayWeaklyPinned#' but for mutable arrays.+   }+   with out_of_line = True++primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp+   ByteArray# -> Addr#+   {Intended for use with pinned arrays; otherwise very unsafe!}++primop  MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp+   MutableByteArray# s -> Addr#+   {Intended for use with pinned arrays; otherwise very unsafe!}++primop  ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> State# s+   {Shrink mutable byte array to new specified size (in bytes), in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofMutableByteArray#'.++    Assuming the non-profiling RTS, this primitive compiles to an O(1)+    operation in C--, modifying the array in-place. Backends bypassing C--+    representation (such as JavaScript) might behave differently.++    @since 0.4.0.0}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail for the "newSize <= oldSize" requirement++primop  ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+   {Resize mutable byte array to new specified size (in bytes), shrinking or growing it.+    The returned 'MutableByteArray#' is either the original+    'MutableByteArray#' resized in-place or, if not possible, a newly+    allocated (unpinned) 'MutableByteArray#' (with the original content+    copied over).++    To avoid undefined behaviour, the original 'MutableByteArray#' shall+    not be accessed anymore after a 'resizeMutableByteArray#' has been+    performed.  Moreover, no reference to the old one should be kept in order+    to allow garbage collection of the original 'MutableByteArray#' in+    case a new 'MutableByteArray#' had to be allocated.++    @since 0.4.0.0}+   with out_of_line = True+        effect = ReadWriteEffect++primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp+   MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)+   {Make a mutable byte array immutable, without copying.}+   with+   code_size = 0+   effect = NoEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawByteArrayOp "unsafeThawByteArray#" GenPrimOp+   ByteArray# -> State# s -> (# State# s, MutableByteArray# s #)+   {Make an immutable byte array mutable, without copying.++    @since 0.12.0.0}+   with+   code_size = 0+   effect = NoEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  SizeofByteArrayOp "sizeofByteArray#" GenPrimOp+   ByteArray# -> Int#+   {Return the size of the array in bytes.}++primop  SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int#+   {Return the size of the array in bytes. __Deprecated__, it is+   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'+   operations on the same mutable byte+   array.}+   with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead }++primop  GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp+   MutableByteArray# s -> State# s -> (# State# s, Int# #)+   {Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.++   @since 0.5.0.0}+++bytearray_access_ops+-- This generates a whole bunch of primops;+-- see utils/genprimopcode/AccessOps.hs+++primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp+   ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+   {@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares+    @n@ bytes starting at offset @src1_ofs@ in the first+    'ByteArray#' @src1@ to the range of @n@ bytes+    (i.e. same length) starting at offset @src2_ofs@ of the second+    'ByteArray#' @src2@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  Returns an 'Int#'+    less than, equal to, or greater than zero if the range is found,+    respectively, to be byte-wise lexicographically less than, to+    match, or be greater than the second range.++    @since 0.5.2.0}+   with+   effect = CanFail++primop  CopyByteArrayOp "copyByteArray#" GenPrimOp+  ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range+    starting at offset @src_ofs@ of length @len@ from the+    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain+    the specified ranges, but this is not checked.  The two arrays must+    not be the same array in different states, but this is not checked+    either.+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4}++primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the+    range starting at offset @src_ofs@ of length @len@ from the+    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are+    allowed to overlap, although this is only possible when the same+    array is provided as both the source and the destination.+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyMutableByteArrayNonOverlappingOp "copyMutableByteArrayNonOverlapping#" GenPrimOp+  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@+    copies the range starting at offset @src_ofs@ of length @len@ from+    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are /not/+    allowed to overlap, but this is also not checked.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp+  ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+  {Copy a range of the ByteArray\# to the memory range starting at the Addr\#.+   The ByteArray\# and the memory region at Addr\# must fully contain the+   specified ranges, but this is not checked. The Addr\# must not point into the+   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked+   either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp+  MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+  {Copy a range of the MutableByteArray\# to the memory range starting at the+   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were+   pinned), but this is not checked either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp+  Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  {Copy a memory range starting at the Addr\# to the specified range in the+   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),+   but this is not checked either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyAddrToAddrOp "copyAddrToAddr#" GenPrimOp+  Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld+  { @'copyAddrToAddr#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  These two memory ranges are allowed to overlap.++    Analogous to the standard C function @memmove@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++primop  CopyAddrToAddrNonOverlappingOp "copyAddrToAddrNonOverlapping#" GenPrimOp+  Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld+  { @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  As the name suggests, these two memory ranges+    /must not overlap/, although this pre-condition is not checked.++    Analogous to the standard C function @memcpy@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++primop  SetByteArrayOp "setByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+  {@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of+   the 'MutableByteArray#' to the byte @c@.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  SetAddrRangeOp "setAddrRange#" GenPrimOp+  Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld+  { @'setAddrRange#' dest len c@ sets all of the bytes in+    @[dest, dest+len)@ to the value @c@.++    Analogous to the standard C function @memset@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++-- Atomic operations++primop  AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array and an offset in machine words, read an element. The+    index is assumed to be in bounds. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+   {Given an array and an offset in machine words, write an element. The+    index is assumed to be in bounds. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int "casIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, an offset in machine words, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #)+   {Given an array, an offset in bytes, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #)+   {Given an array, an offset in 16 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #)+   {Given an array, an offset in 32 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #)+   {Given an array, an offset in 64 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "Addr#"+------------------------------------------------------------------------++primtype Addr#+        { An arbitrary machine address assumed to point outside+         the garbage-collected heap. }++pseudoop "nullAddr#" Addr#+        { The null address. }++primop   AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr#+primop   AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int#+         {Result is meaningless if two 'Addr#'s are so far apart that their+         difference doesn't fit in an 'Int#'.}+primop   AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#+         {Return the remainder when the 'Addr#' arg, treated like an 'Int#',+          is divided by the 'Int#' arg.}+primop   AddrToIntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#+        {Coerce directly from address to int. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.}+   with code_size = 0+primop   IntToAddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#+        {Coerce directly from int to address. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.}+   with code_size = 0++primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Int#+++addr_access_ops+-- This generates a whole bunch of primops;+-- see utils/genprimopcode/AccessOps.hs+++primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp+   Addr# -> Addr# -> State# s -> (# State# s, Addr# #)+   {The atomic exchange operation. Atomically exchanges the value at the first address+    with the Addr# given as second argument. Implies a read barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {The atomic exchange operation. Atomically exchanges the value at the address+    with the given value. Returns the old value. Implies a read barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp+   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)+   { Compare and swap on a word-sized memory location.++     Use as: \s -> atomicCasAddrAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp+   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)+   { Compare and swap on a word-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp+   Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #)+   { Compare and swap on a 8 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr8# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp+   Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #)+   { Compare and swap on a 16 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr16# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp+   Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #)+   { Compare and swap on a 32 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr32# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp+   Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #)+   { Compare and swap on a 64 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr64# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp+   Addr# -> State# s -> (# State# s, Word# #)+   {Given an address, read a machine word.  Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> State# s+   {Given an address, write a machine word. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+++------------------------------------------------------------------------+section "Mutable variables"+        {Operations on MutVar\#s.}+------------------------------------------------------------------------++primtype MutVar# s a+        {A 'MutVar#' behaves like a single-element mutable array.}++primop  NewMutVarOp "newMutVar#" GenPrimOp+   a_levpoly -> State# s -> (# State# s, MutVar# s a_levpoly #)+   {Create 'MutVar#' with specified initial value in specified state thread.}+   with+   out_of_line = True+   effect = ReadWriteEffect++-- Note [Why MutVar# ops can't fail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We don't label readMutVar# or writeMutVar# as CanFail.+-- This may seem a bit peculiar, because they surely *could*+-- fail spectacularly if passed a pointer to unallocated memory.+-- But MutVar#s are always correct by construction; we never+-- test if a pointer is valid before using it with these operations.+-- So we never have to worry about floating the pointer reference+-- outside a validity test. At the moment, ReadWriteEffect blocks+-- up the relevant optimizations anyway, but we hope to draw finer+-- distinctions soon, which should improve matters for readMutVar#+-- at least.++primop  ReadMutVarOp "readMutVar#" GenPrimOp+   MutVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'MutVar#'. Result is not yet evaluated.}+   with+   -- See Note [Why MutVar# ops can't fail]+   effect = ReadWriteEffect++primop  WriteMutVarOp "writeMutVar#"  GenPrimOp+   MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+   {Write contents of 'MutVar#'.}+   with+   -- See Note [Why MutVar# ops can't fail]+   effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall } -- for the write barrier++primop  AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp+   MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {Atomically exchange the value of a 'MutVar#'.}+   with+   effect = ReadWriteEffect++-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Looking at the type of atomicModifyMutVar2#, one might wonder why+-- it doesn't return an unboxed tuple. e.g.,+--+--   MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #)+--+-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity.+-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces+-- its contents with a thunk of the form (fst (f x)). This can be done using an+-- atomic compare-and-swap as it is merely replacing a pointer.++primop  AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp+   MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #)+   { Modify the contents of a 'MutVar#', returning the previous+     contents @x :: a@ and the result of applying the given function to the+     previous contents @f x :: c@.++     The @data@ type @c@ (not a @newtype@!) must be a record whose first field+     is of lifted type @a :: Type@ and is not unpacked. For example, product+     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both+     monomorphic and strict in its first field, it's recommended to mark the+     latter @{-# NOUNPACK #-}@ explicitly.++     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an+     old @x :: a@ with a pointer to a selector thunk @fst r@, where+     @fst@ is a selector for the first field of the record and @r@ is a+     function application thunk @r = f x@.++     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an+     effort to reflect restrictions on @c@ faithfully, providing a+     well-typed high-level wrapper.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv }++primop  AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp+   MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)+   { Modify the contents of a 'MutVar#', returning the previous+     contents and the result of applying the given function to the+     previous contents. }+   with+   out_of_line = True+   effect = ReadWriteEffect+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv }++primop  CasMutVarOp "casMutVar#" GenPrimOp+  MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   { Compare-and-swap: perform a pointer equality test between+     the first value passed to this function and the value+     stored inside the 'MutVar#'. If the pointers are equal,+     replace the stored value with the second value passed to this+     function, otherwise do nothing.+     Returns the final value stored inside the 'MutVar#'.+     The 'Int#' indicates whether a swap took place,+     with @1#@ meaning that we didn't swap, and @0#@+     that we did.+     Implies a full memory barrier.+     Because the comparison is done on the level of pointers,+     all of the difficulties of using+     'reallyUnsafePtrEquality#' correctly apply to+     'casMutVar#' as well.+   }+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Exceptions"+------------------------------------------------------------------------++-- Note [Strict IO wrappers]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- Consider this example, which comes from GHC.IO.Handle.Internals:+--    wantReadableHandle3 f mv b st+--      = case ... of+--          DEFAULT -> case mv of MVar a -> ...+--          0#      -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...)+-- The outer case just decides whether to mask exceptions, but we don't want+-- thereby to hide the strictness in `mv`!  Hence the use of strictOnceApply1Dmd+-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect+-- that it potentially calls its action multiple times).+--+-- Note [Strictness for catch-style primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The catch#-style primops always call their action, just like outlined+-- in Note [Strict IO wrappers].+-- However, it is important that we give their first arg lazyApply1Dmd and not+-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call+--+--   catch# act handler s+--+-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that+-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and+-- Note [Precise exceptions and strictness analysis]).+-- This would cause dead code elimination to discard the continuation of the+-- catch# call, among other things. This first came up in #11555.+--+-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag+-- from `act`. (This is a bit brutal, but the language of strictness types is+-- not expressive enough to give it a more precise semantics that is still+-- sound.)+-- For perf reasons we often (but not always) choose to use a wrapper around+-- catch# that is head-strict in `act`: GHC.IO.catchException.+--+-- A similar caveat applies to prompt#, which can be seen as a+-- generalisation of catch# as explained in GHC.Prim#continuations#.+-- The reason is that even if `act` appears dead-ending (e.g., looping)+-- `prompt# tag ma s` might return alright due to a (higher-order) use of+-- `control0#` in `act`. This came up in #25439.++primop  CatchOp "catch#" GenPrimOp+          (State# RealWorld -> (# State# RealWorld, a_reppoly #) )+       -> (b_levpoly -> State# RealWorld -> (# State# RealWorld, a_reppoly #) )+       -> State# RealWorld+       -> (# State# RealWorld, a_reppoly #)+   { @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions+     thrown.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect+   -- Either inner computation might potentially raise an unchecked exception,+   -- but it doesn't seem worth putting a WARNING in the haddocks over++primop  RaiseOp "raise#" GenPrimOp+   a_levpoly -> b_reppoly+   with+   -- In contrast to 'raiseIO#', which throws a *precise* exception,+   -- exceptions thrown by 'raise#' are considered *imprecise*.+   -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand.+   -- Hence, it has 'botDiv', not 'exnDiv'.+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   work_free = True++primop  RaiseUnderflowOp "raiseUnderflow#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseOverflowOp "raiseOverflow#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseDivZeroOp "raiseDivZero#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseIOOp "raiseIO#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, b_reppoly #)+   with+   -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"+   -- for why this is the *only* primop that has 'exnDiv'+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv }+   out_of_line = True+   effect = ThrowsException+   work_free = True++primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are unmasked.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  MaskStatus "getMaskingState#" GenPrimOp+        State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Continuations"+  { #continuations#++    These operations provide access to first-class delimited continuations,+    which allow a computation to access and manipulate portions of its+    /current continuation/. Operationally, they are implemented by direct+    manipulation of the RTS call stack, which may provide significant+    performance gains relative to manual continuation-passing style (CPS) for+    some programs.++    Intuitively, the delimited control operators 'prompt#' and+    'control0#' can be understood by analogy to 'catch#' and 'raiseIO#',+    respectively:++      * Like 'catch#', 'prompt#' does not do anything on its own, it+        just /delimits/ a subcomputation (the source of the name "delimited+        continuations").++      * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing+        'prompt#' before resuming execution.++    However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard+    the aborted computation: instead, it /captures/ it in a form that allows+    it to be resumed later. In other words, 'control0#' does not+    irreversibly abort the local computation before returning to the enclosing+    'prompt#', it merely suspends it. All local context of the suspended+    computation is packaged up and returned as an ordinary function that can be+    invoked at a later point in time to /continue/ execution, which is why+    the suspended computation is known as a /first-class continuation/.++    In GHC, every continuation prompt is associated with exactly one+    'PromptTag#'. Prompt tags are unique, opaque values created by+    'newPromptTag#' that may only be compared for equality. Both 'prompt#'+    and 'control0#' accept a 'PromptTag#' argument, and 'control0#'+    captures the continuation up to the nearest enclosing use of 'prompt#'+    /with the same tag/. This allows a program to control exactly which+    prompt it will abort to by using different tags, similar to how a program+    can control which 'catch' it will abort to by throwing different types+    of exceptions. Additionally, 'PromptTag#' accepts a single type parameter,+    which is used to relate the expected result type at the point of the+    'prompt#' to the type of the continuation produced by 'control0#'.++    == The gory details++    The high-level explanation provided above should hopefully provide some+    intuition for what these operations do, but it is not very precise; this+    section provides a more thorough explanation.++    The 'prompt#' operation morally has the following type:++@+'prompt#' :: 'PromptTag#' a -> IO a -> IO a+@++    If a computation @/m/@ never calls 'control0#', then+    @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is+    a no-op. This implies the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x+    \]++    The 'control0#' operation morally has the following type:++@+'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b+@++    @'control0#' /tag/ /f/@ captures the current continuation up to the nearest+    enclosing @'prompt#' /tag/@ and resumes execution from the point of the call+    to 'prompt#', passing the captured continuation to @/f/@. To make that+    somewhat more precise, we can say 'control0#' obeys the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k)+      \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k)+    \]++    However, this law does not fully describe the behavior of 'control0#',+    as it does not account for situations where 'control0#' does not appear+    immediately inside 'prompt#'. Capturing the semantics more precisely+    requires some additional notational machinery; a common approach is to+    use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics).+    Assuming an appropriate definition of evaluation contexts \(E\), the+    semantics of 'prompt#' and 'control0#' can be given as follows:++    \[+    \begin{aligned}+    E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)]+      &\longrightarrow E[\mathtt{pure}\ v] \\[8pt]+    E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]]+      &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt]+      \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2+    \end{aligned}+    \]++    A full treatment of the semantics and metatheory of delimited control is+    well outside the scope of this documentation, but a good, thorough+    overview (in Haskell) is provided in [A Monadic Framework for Delimited+    Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by+    Dybvig et al.++    == Safety and invariants++    Correct uses of 'control0#' must obey the following restrictions:++    1. The behavior of 'control0#' is only well-defined within a /strict+       'State#' thread/, such as those associated with @IO@ and strict @ST@+       computations.++    2. Furthermore, 'control0#' may only be called within the dynamic extent+       of a 'prompt#' with a matching tag somewhere in the /current/ strict+       'State#' thread. Effectively, this means that a matching prompt must+       exist somewhere, and the captured continuation must /not/ contain any+       uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For+       example, the following program is ill-defined:++        @+        'prompt#' /tag/ $+          evaluate (unsafePerformIO $ 'control0#' /tag/ /f/)+        @++        In this example, the use of 'prompt#' appears in a different 'State#'+        thread from the use of 'control0#', so there is no valid prompt in+        scope to capture up to.++    3. Finally, 'control0#' may not be used within 'State#' threads associated+       with an STM transaction (i.e. those introduced by 'atomically#').++    If the runtime is able to detect that any of these invariants have been+    violated in a way that would compromise internal invariants of the runtime,+    'control0#' will fail by raising an exception. However, such violations+    are only detected on a best-effort basis, as the bookkeeping necessary for+    detecting /all/ illegal uses of 'control0#' would have significant overhead.+    Therefore, although the operations are "safe" from the runtime's point of+    view (e.g. they will not compromise memory safety or clobber internal runtime+    state), it is still ultimately the programmer's responsibility to ensure+    these invariants hold to guarantee predictable program behavior.++    In a similar vein, since each captured continuation includes the full local+    context of the suspended computation, it can safely be resumed arbitrarily+    many times without violating any invariants of the runtime system. However,+    use of these operations in an arbitrary 'IO' computation may be unsafe for+    other reasons, as most 'IO' code is not written with reentrancy in mind. For+    example, a computation suspended in the middle of reading a file will likely+    finish reading it when it is resumed; further attempts to resume from the+    same place would then fail because the file handle was already closed.++    In other words, although the RTS ensures that a computation's control state+    and local variables are properly restored for each distinct resumption of+    a continuation, it makes no attempt to duplicate any local state the+    computation may have been using (and could not possibly do so in general).+    Furthermore, it provides no mechanism for an arbitrary computation to+    protect itself against unwanted reentrancy (i.e. there is no analogue to+    Scheme's @dynamic-wind@). For those reasons, manipulating the continuation+    is only safe if the caller can be certain that doing so will not violate any+    expectations or invariants of the enclosing computation. }+------------------------------------------------------------------------++primtype PromptTag# a+   { See "GHC.Prim#continuations". }++primop  NewPromptTagOp "newPromptTag#" GenPrimOp+        State# RealWorld -> (# State# RealWorld, PromptTag# a #)+   { See "GHC.Prim#continuations". }+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  PromptOp "prompt#" GenPrimOp+        PromptTag# a+     -> (State# RealWorld -> (# State# RealWorld, a #))+     -> State# RealWorld -> (# State# RealWorld, a #)+   { See "GHC.Prim#continuations". }+   with+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  Control0Op "control0#" GenPrimOp+        PromptTag# a+     -> (((State# RealWorld -> (# State# RealWorld, b_reppoly #))+          -> State# RealWorld -> (# State# RealWorld, a #))+         -> State# RealWorld -> (# State# RealWorld, a #))+     -> State# RealWorld -> (# State# RealWorld, b_reppoly #)+   { See "GHC.Prim#continuations". }+   with+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv }+   out_of_line = True+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "STM-accessible Mutable Variables"+------------------------------------------------------------------------++primtype TVar# s a++primop  AtomicallyOp "atomically#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++-- NB: retry#'s strictness information specifies it to diverge.+-- This lets the compiler perform some extra simplifications, since retry#+-- will technically never return.+--+-- This allows the simplifier to replace things like:+--   case retry# s1+--     (# s2, a #) -> e+-- with:+--   retry# s1+-- where 'e' would be unreachable anyway.  See #8091.+primop  RetryOp "retry#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ReadWriteEffect++primop  CatchRetryOp "catchRetry#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  CatchSTMOp "catchSTM#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (b -> State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  NewTVarOp "newTVar#" GenPrimOp+       a_levpoly+    -> State# s -> (# State# s, TVar# s a_levpoly #)+   {Create a new 'TVar#' holding a specified initial value.}+   with+   out_of_line  = True+   effect = ReadWriteEffect++primop  ReadTVarOp "readTVar#" GenPrimOp+       TVar# s a_levpoly+    -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'TVar#' inside an STM transaction,+    i.e. within a call to 'atomically#'.+    Does not force evaluation of the result.}+   with+   out_of_line  = True+   effect = ReadWriteEffect++primop ReadTVarIOOp "readTVarIO#" GenPrimOp+       TVar# s a_levpoly+    -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'TVar#' outside an STM transaction.+   Does not force evaluation of the result.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  WriteTVarOp "writeTVar#" GenPrimOp+       TVar# s a_levpoly+    -> a_levpoly+    -> State# s -> State# s+   {Write contents of 'TVar#'.}+   with+   out_of_line      = True+   effect = ReadWriteEffect+++------------------------------------------------------------------------+section "Synchronized Mutable Variables"+        {Operations on 'MVar#'s. }+------------------------------------------------------------------------++primtype MVar# s a+        { A shared mutable variable (/not/ the same as a 'MutVar#'!).+        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be+        represented by @('MutVar#' (Maybe a))@.) }++primop  NewMVarOp "newMVar#"  GenPrimOp+   State# s -> (# State# s, MVar# s a_levpoly #)+   {Create new 'MVar#'; initially empty.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  TakeMVarOp "takeMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {If 'MVar#' is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryTakeMVarOp "tryTakeMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  PutMVarOp "putMVar#" GenPrimOp+   MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+   {If 'MVar#' is full, block until it becomes empty.+   Then store value arg as its new contents.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryPutMVarOp "tryPutMVar#" GenPrimOp+   MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, Int# #)+   {If 'MVar#' is full, immediately return with integer 0.+    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  ReadMVarOp "readMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {If 'MVar#' is empty, block until it becomes full.+   Then read its contents without modifying the MVar, without possibility+   of intervention from other threads.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryReadMVarOp "tryReadMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#'.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int# #)+   {Return 1 if 'MVar#' is empty; 0 otherwise.}+   with+   out_of_line = True+   effect = ReadWriteEffect+++------------------------------------------------------------------------+section "Delay/wait operations"+------------------------------------------------------------------------++primop  DelayOp "delay#" GenPrimOp+   Int# -> State# s -> State# s+   {Sleep specified number of microseconds.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  WaitReadOp "waitRead#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until input is available on specified file descriptor.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  WaitWriteOp "waitWrite#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until output is possible on specified file descriptor.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++------------------------------------------------------------------------+section "Concurrency primitives"+------------------------------------------------------------------------++primtype State# s+        { 'State#' is the primitive, unlifted type of states.  It has+        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,+        where s is a type variable. The only purpose of the type parameter+        is to keep different state threads separate.  It is represented by+        nothing at all. }++primtype RealWorld+        { 'RealWorld' is deeply magical.  It is /primitive/, but it is not+        /unlifted/ (hence @ptrArg@).  We never manipulate values of type+        'RealWorld'; it's only used in the type system, to parameterise 'State#'. }++primtype ThreadId#+        {(In a non-concurrent implementation, this can be a singleton+        type, whose (unique) value is returned by 'myThreadId#'.  The+        other operations can be omitted.)}++primop  ForkOp "fork#" GenPrimOp+   (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  ForkOnOp "forkOn#" GenPrimOp+   Int# -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd+                                              , lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  KillThreadOp "killThread#"  GenPrimOp+   ThreadId# -> a -> State# RealWorld -> State# RealWorld+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  YieldOp "yield#" GenPrimOp+   State# RealWorld -> State# RealWorld+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  MyThreadIdOp "myThreadId#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect++primop LabelThreadOp "labelThread#" GenPrimOp+   ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld+   {Set the label of the given thread. The @ByteArray#@ should contain+    a UTF-8-encoded string.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  NoDuplicateOp "noDuplicate#" GenPrimOp+   State# s -> State# s+   with+   out_of_line = True+   effect = ReadWriteEffect++primop GetThreadLabelOp "threadLabel#" GenPrimOp+   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #)+   {Get the label of the given thread.+    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag+    denoting @Just@.++    @since 0.10}+   with+   out_of_line      = True++primop  ThreadStatusOp "threadStatus#" GenPrimOp+   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)+   {Get the status of the given thread. Result is+    @(ThreadStatus, Capability, Locked)@ where+    @ThreadStatus@ is one of the status constants defined in+    @rts/Constants.h@, @Capability@ is the number of+    the capability which currently owns the thread, and+    @Locked@ is a boolean indicating whether the+    thread is bound to that capability.++    @since 0.9}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop ListThreadsOp "listThreads#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, Array# ThreadId# #)+   { Returns an array of the threads started by the program. Note that this+     threads which have finished execution may or may not be present in this+     list, depending upon whether they have been collected by the garbage collector.++     @since 0.10}+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Weak pointers"+------------------------------------------------------------------------++primtype Weak# b++primop  MkWeakOp "mkWeak#" GenPrimOp+   a_levpoly -> b_levpoly -> (State# RealWorld -> (# State# RealWorld, c #))+     -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #)+   { @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,+     with an associated reference to some value @v@. If @k@ is still+     alive then @v@ can be retrieved using 'deRefWeak#'. Note that+     the type of @k@ must be represented by a pointer (i.e. of kind+     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp+   a_levpoly -> b_levpoly -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp+   Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly+          -> State# RealWorld -> (# State# RealWorld, Int# #)+   { @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C+     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If+     @flag@ is zero, @fptr@ will be called with one argument,+     @ptr@. Otherwise, it will be called with two arguments,+     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns+     1 on success, or 0 if @w@ is already dead. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  DeRefWeakOp "deRefWeak#" GenPrimOp+   Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp+   Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#,+              (State# RealWorld -> (# State# RealWorld, b #) ) #)+   { Finalize a weak pointer. The return value is an unboxed tuple+     containing the new state of the world and an "unboxed Maybe",+     represented by an 'Int#' and a (possibly invalid) finalization+     action. An 'Int#' of @1@ indicates that the finalizer is valid. The+     return value @b@ from the finalizer should be ignored. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop TouchOp "touch#" GenPrimOp+   a_levpoly -> State# s -> State# s+   with+   code_size = 0+   effect = ReadWriteEffect -- see Note [touch# has ReadWriteEffect]+   work_free = False+++-- Note [touch# has ReadWriteEffect]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Although touch# emits no code, it is marked as ReadWriteEffect to+-- prevent it from being defeated by the optimizer:+--  * Discarding a touch# call would defeat its whole purpose.+--  * Strictly floating a touch# call out would shorten the lifetime+--    of the touched object, again defeating its purpose.+--  * Duplicating a touch# call might unpredictably extend the lifetime+--    of the touched object.  Although this would not defeat the purpose+--    of touch#, it seems undesirable.+--+-- In practice, this designation probably doesn't matter in most cases,+-- as touch# is usually tightly coupled with a "real" read or write effect.++------------------------------------------------------------------------+section "Stable pointers and names"+------------------------------------------------------------------------++primtype StablePtr# a++primtype StableName# a++primop  MakeStablePtrOp "makeStablePtr#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, StablePtr# a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  DeRefStablePtrOp "deRefStablePtr#" GenPrimOp+   StablePtr# a_levpoly -> State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  EqStablePtrOp "eqStablePtr#" GenPrimOp+   StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+   with+   effect = ReadWriteEffect++primop  MakeStableNameOp "makeStableName#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, StableName# a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  StableNameToIntOp "stableNameToInt#" GenPrimOp+   StableName# a_levpoly -> Int#++------------------------------------------------------------------------+section "Compact normal form"++        {Primitives for working with compact regions. The @ghc-compact@+         library and the @compact@ library demonstrate how to use these+         primitives. The documentation below draws a distinction between+         a CNF and a compact block. A CNF contains one or more compact+         blocks. The source file @rts\/sm\/CNF.c@+         diagrams this relationship. When discussing a compact+         block, an additional distinction is drawn between capacity and+         utilized bytes. The capacity is the maximum number of bytes that+         the compact block can hold. The utilized bytes is the number of+         bytes that are actually used by the compact block.+        }++------------------------------------------------------------------------++primtype Compact#++primop  CompactNewOp "compactNew#" GenPrimOp+   Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)+   { Create a new CNF with a single compact block. The argument is+     the capacity of the compact block (in bytes, not words).+     The capacity is rounded up to a multiple of the allocator block size+     and is capped to one mega block. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactResizeOp "compactResize#" GenPrimOp+   Compact# -> Word# -> State# RealWorld ->+   State# RealWorld+   { Set the new allocation size of the CNF. This value (in bytes)+     determines the capacity of each compact block in the CNF. It+     does not retroactively affect existing compact blocks in the CNF. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactContainsOp "compactContains#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)+   { Returns 1\# if the object is contained in the CNF, 0\# otherwise. }+   with+   out_of_line      = True++primop  CompactContainsAnyOp "compactContainsAny#" GenPrimOp+   a -> State# RealWorld -> (# State# RealWorld, Int# #)+   { Returns 1\# if the object is in any CNF at all, 0\# otherwise. }+   with+   out_of_line      = True++primop  CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp+   Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)+   { Returns the address and the utilized size (in bytes) of the+     first compact block of a CNF.}+   with+   out_of_line      = True++primop  CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp+   Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)+   { Given a CNF and the address of one its compact blocks, returns the+     next compact block and its utilized size, or 'nullAddr#' if the+     argument was the last compact block in the CNF. }+   with+   out_of_line      = True++primop  CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp+   Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)+   { Attempt to allocate a compact block with the capacity (in+     bytes) given by the first argument. The 'Addr#' is a pointer+     to previous compact block of the CNF or 'nullAddr#' to create a+     new CNF with a single compact block.++     The resulting block is not known to the GC until+     'compactFixupPointers#' is called on it, and care must be taken+     so that the address does not escape or memory will be leaked.+   }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactFixupPointersOp "compactFixupPointers#" GenPrimOp+   Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #)+   { Given the pointer to the first block of a CNF and the+     address of the root object in the old address space, fix up+     the internal pointers inside the CNF to account for+     a different position in memory than when it was serialized.+     This method must be called exactly once after importing+     a serialized CNF. It returns the new CNF and the new adjusted+     root address. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactAdd "compactAdd#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)+   { Recursively add a closure and its transitive closure to a+     'Compact#' (a CNF), evaluating any unevaluated components+     at the same time. Note: 'compactAdd#' is not thread-safe, so+     only one thread may call 'compactAdd#' with a particular+     'Compact#' at any given time. The primop does not+     enforce any mutual exclusion; the caller is expected to+     arrange this. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)+   { Like 'compactAdd#', but retains sharing and cycles+   during compaction. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactSize "compactSize#" GenPrimOp+   Compact# -> State# RealWorld -> (# State# RealWorld, Word# #)+   { Return the total capacity (in bytes) of all the compact blocks+     in the CNF. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++------------------------------------------------------------------------+section "Unsafe pointer equality"+--  (#1 Bad Guy: Alastair Reid :)+------------------------------------------------------------------------++primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp+   a_levpoly -> b_levpoly -> Int#+   { Returns @1#@ if the given pointers are equal and @0#@ otherwise. }+   with+   effect = CanFail -- See Note [reallyUnsafePtrEquality# CanFail]+   can_fail_warning = DoNotWarnCanFail++-- Note [Pointer comparison operations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The primop `reallyUnsafePtrEquality#` does a direct pointer+-- equality between two (boxed) values.  Several things to note:+--+-- (PE1) It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and+--       TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example.+--       This levity-polymorphism comes from the use of the type variables+--       "a_levpoly" and "b_levpoly". See Note [Levity and representation polymorphic primops]+--+-- (PE2) It is hetero-typed; you can compare pointers of different types.+--       This is used in various packages such as containers & unordered-containers.+--+-- (PE3) It does not evaluate its arguments. The user of the primop is responsible+--       for doing so.  Consider+--            let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y+--       Here `x` and `y` point to different closures, so the expression will+--       probably return False; but if `x` and/or `y` were evaluated for some+--       other reason, then it might return True.+--+-- (PE4) It is obviously very dangerous, because replacing equals with equals+--       in the program can change the result.  For example+--           let x = f y in reallyUnsafePtrEquality# x x+--       will probably return True, whereas+--            reallyUnsafePtrEquality# (f y) (f y)+--       will probably return False. ("probably", because it's affected+--       by CSE and inlining).+--+-- (PE5) reallyUnsafePtrEquality# can't fail, but it is marked as such+--       to prevent it from floating out.+--       See Note [reallyUnsafePtrEquality# CanFail]+--+-- The library GHC.Prim.PtrEq (and GHC.Exts) provides+--+--   unsafePtrEquality# ::+--     forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#+--+-- It is still heterotyped (like (PE2)), but it's restricted to unlifted types+-- (unlike (PE1)).  That means that (PE3) doesn't apply: unlifted types are+-- always evaluated, which makes it a bit less unsafe.+--+-- However unsafePtrEquality# is /implemented/ by a call to+-- reallyUnsafePtrEquality#, so using the former is really just a documentation+-- hint to the reader of the code.  GHC behaves no differently.+--+-- The same library provides less Wild-West functions+-- for use in specific cases, namely:+--+--   reallyUnsafePtrEquality :: a -> a -> Int#  -- not levity-polymorphic, nor hetero-typed+--   sameArray# :: Array# a -> Array# a -> Int#+--   sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#+--   sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#+--   sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#+--   sameByteArray# :: ByteArray# -> ByteArray# -> Int#+--   sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#+--   sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#+--   sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#+--   sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#+--   sameTVar# :: TVar# s a -> TVar# s a -> Int#+--   sameMVar# :: MVar# s a -> MVar# s a -> Int#+--   eqStableName# :: StableName# a -> StableName# b -> Int#+--+-- These operations are all specialisations of unsafePtrEquality#.++-- Note [reallyUnsafePtrEquality# CanFail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it+-- CanFail anyway. Until 5a9a1738023a, GHC considered primops okay for+-- speculation only when their arguments were known to be forced. This was+-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from+-- floating out of places where its arguments were known to be forced.+-- Unfortunately, GHC could sometimes lose track of whether those arguments+-- were forced, leading to let-can-float invariant failures (see #13027 and the+-- discussion in #11444). Now that ok_for_speculation skips over lifted+-- arguments, we need to explicitly prevent reallyUnsafePtrEquality#+-- from floating out. Imagine if we had+--+--     \x y . case x of x'+--              DEFAULT ->+--            case y of y'+--              DEFAULT ->+--               let eq = reallyUnsafePtrEquality# x' y'+--               in ...+--+-- If the let floats out, we'll get+--+--     \x y . let eq = reallyUnsafePtrEquality# x y+--            in case x of ...+--+-- The trouble is that pointer equality between thunks is very different+-- from pointer equality between the values those thunks reduce to, and the latter+-- is typically much more precise.++------------------------------------------------------------------------+section "Parallelism"+------------------------------------------------------------------------++primop  ParOp "par#" GenPrimOp a -> Int#+   {Create a new spark evaluating the given argument.+    The return value should always be 1.+    Users are encouraged to use spark# instead.}+   with+      -- Note that Par is lazy to avoid that the sparked thing+      -- gets evaluated strictly, which it should *not* be+   effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall }+   -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it+   -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used+   -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until+   -- everything is sorted out (see #24825).+   --+   -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293+   -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791+   --+   -- deprecated_msg = { Use 'spark#' instead }++primop SparkOp "spark#" GenPrimOp+   a -> State# s -> (# State# s, a #)+   with effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall }++primop GetSparkOp "getSpark#" GenPrimOp+   State# s -> (# State# s, Int#, a #)+   with+   effect = ReadWriteEffect+   out_of_line = True++primop NumSparks "numSparks#" GenPrimOp+   State# s -> (# State# s, Int# #)+   { Returns the number of sparks in the local spark pool. }+   with+   effect = ReadWriteEffect+   out_of_line = True++++------------------------------------------------------------------------+section "Controlling object lifetime"+        {Ensuring that objects don't die a premature death.}+------------------------------------------------------------------------++-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.+primop KeepAliveOp "keepAlive#" GenPrimOp+   a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+   { @'keepAlive#' x s k@ keeps the value @x@ alive during the execution+     of the computation @k@.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   out_of_line = True+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }+                 -- See Note [Strict IO wrappers]+   effect = ReadWriteEffect+   -- The invoked computation may have side effects+++------------------------------------------------------------------------+section "Tag to enum stuff"+        {Convert back and forth between values of enumerated types+        and small integers.}+------------------------------------------------------------------------++primop  DataToTagSmallOp "dataToTagSmall#" GenPrimOp+   a_levpoly -> Int#+   { Used internally to implement @dataToTag#@: Use that function instead!+     This one normally offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   }+   with+   deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. }+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }+   effect = ThrowsException+   cheap = True++primop  DataToTagLargeOp "dataToTagLarge#" GenPrimOp+   a_levpoly -> Int#+   { Used internally to implement @dataToTag#@: Use that function instead!+     This one offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   }+   with+   deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. }+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }+   effect = ThrowsException+   cheap = True++primop  TagToEnumOp "tagToEnum#" GenPrimOp+   Int# -> a+   with+   effect = CanFail++------------------------------------------------------------------------+section "Bytecode operations"+        {Support for manipulating bytecode objects used by the interpreter and+        linker.++        Bytecode objects are heap objects which represent top-level bindings and+        contain a list of instructions and data needed by these instructions.}+------------------------------------------------------------------------++primtype BCO+   { Primitive bytecode type. }++primop   AddrToAnyOp "addrToAny#" GenPrimOp+   Addr# -> (# a_levpoly #)+   { Convert an 'Addr#' to a followable Any type. }+   with+   code_size = 0++primop   AnyToAddrOp "anyToAddr#" GenPrimOp+   a -> State# RealWorld -> (# State# RealWorld, Addr# #)+   { Retrieve the address of any Haskell value. This is+     essentially an 'unsafeCoerce#', but if implemented as such+     the core lint pass complains and fails to compile.+     As a primop, it is opaque to core/stg, and only appears+     in cmm (where the copy propagation pass will get rid of it).+     Note that "a" must be a value, not a thunk! It's too late+     for strictness analysis to enforce this, so you're on your+     own to guarantee this. Also note that 'Addr#' is not a GC+     pointer - up to you to guarantee that it does not become+     a dangling pointer immediately after you get it.}+   with+   code_size = 0++primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp+   BCO -> (# a #)+   { Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of+     the BCO when evaluated. }+   with+   out_of_line = True++primop  NewBCOOp "newBCO#" GenPrimOp+   ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #)+   { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The+     resulting object encodes a function of the given arity with the instructions+     encoded in @instrs@, and a static reference table usage bitmap given by+     @bitmap@. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  UnpackClosureOp "unpackClosure#" GenPrimOp+   a -> (# Addr#, ByteArray#, Array# b #)+   { @'unpackClosure#' closure@ copies the closure and pointers in the+     payload of the given closure into two new arrays, and returns a pointer to+     the first word of the closure's info table, a non-pointer array for the raw+     bytes of the closure, and a pointer array for the pointers in the payload. }+   with+   out_of_line = True++primop  ClosureSizeOp "closureSize#" GenPrimOp+   a -> Int#+   { @'closureSize#' closure@ returns the size of the given closure in+     machine words. }+   with+   out_of_line = True++primop  GetApStackValOp "getApStackVal#" GenPrimOp+   a -> Int# -> (# Int#, b #)+   with+   out_of_line = True++------------------------------------------------------------------------+section "Misc"+        {These aren't nearly as wired in as Etc...}+------------------------------------------------------------------------++primop  GetCCSOfOp "getCCSOf#" GenPrimOp+   a -> State# s -> (# State# s, Addr# #)++primop  GetCurrentCCSOp "getCurrentCCS#" GenPrimOp+   a -> State# s -> (# State# s, Addr# #)+   { Returns the current 'CostCentreStack' (value is @NULL@ if+     not profiling).  Takes a dummy argument which can be used to+     avoid the call to 'getCurrentCCS#' being floated out by the+     simplifier, which would result in an uninformative stack+     ("CAF"). }++primop  ClearCCSOp "clearCCS#" GenPrimOp+   (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #)+   { Run the supplied IO action with an empty CCS.  For example, this+     is used by the interpreter to run an interpreted computation+     without the call stack showing that it was invoked from GHC. }+   with+   out_of_line = True++------------------------------------------------------------------------+section "Annotating call stacks"+------------------------------------------------------------------------++primop AnnotateStackOp "annotateStack#" GenPrimOp+   b -> (State# s -> (# State# s, a_reppoly #)) -> State# s -> (# State# s, a_reppoly #)+   { Pushes an annotation frame to the stack which can be reported by backtraces. }+   with+   out_of_line = True++------------------------------------------------------------------------+section "Info Table Origin"+------------------------------------------------------------------------+primop WhereFromOp "whereFrom#" GenPrimOp+   a -> Addr# -> State# s -> (# State# s, Int# #)+   { Fills the given buffer with the @InfoProvEnt@ for the info table of the+     given object. Returns @1#@ on success and @0#@ otherwise.}+   with+   out_of_line = True++------------------------------------------------------------------------+section "Etc"+        {Miscellaneous built-ins}+------------------------------------------------------------------------++primtype FUN m a b+  {The builtin function type, written in infix form as @a % m -> b@.+   Values of this type are functions taking inputs of type @a@ and+   producing outputs of type @b@. The multiplicity of the input is+   @m@.++   Note that @'FUN' m a b@ permits representation polymorphism in both+   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be+   well-kinded.+  }++pseudoop "realWorld#"+   State# RealWorld+   { The token used in the implementation of the IO monad as a state monad.+     It does not pass any information at runtime.+     See also 'GHC.Magic.runRW#'. }++pseudoop "void#"+   (# #)+   { This is an alias for the unboxed unit tuple constructor.+     In earlier versions of GHC, 'void#' was a value+     of the primitive type 'Void#', which is now defined to be @(# #)@.+   }+   with deprecated_msg = { Use an unboxed unit tuple instead }++primtype Proxy# a+   { The type constructor 'Proxy#' is used to bear witness to some+   type variable. It's used when you want to pass around proxy values+   for doing things like modelling type applications. A 'Proxy#'+   is not only unboxed, it also has a polymorphic kind, and has no+   runtime representation, being totally free. }++pseudoop "proxy#"+   Proxy# a+   { Witness for an unboxed 'Proxy#' value, which has no runtime+   representation. }++pseudoop   "seq"+   a -> b_reppoly -> b_reppoly+   { The value of @'seq' a b@ is bottom if @a@ is bottom, and+     otherwise equal to @b@. In other words, it evaluates the first+     argument @a@ to weak head normal form (WHNF). 'seq' is usually+     introduced to improve performance by avoiding unneeded laziness.++     A note on evaluation order: the expression @'seq' a b@ does+     /not/ guarantee that @a@ will be evaluated before @b@.+     The only guarantee given by 'seq' is that the both @a@+     and @b@ will be evaluated before 'seq' returns a value.+     In particular, this means that @b@ may be evaluated before+     @a@. If you need to guarantee a specific order of evaluation,+     you must use the function 'pseq' from the "parallel" package. }+   with fixity = infixr 0+         -- This fixity is only the one picked up by Haddock. If you+         -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'.++primop  TraceEventOp "traceEvent#" GenPrimOp+   Addr# -> State# s -> State# s+   { Emits an event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp+   Addr# -> Int# -> State# s -> State# s+   { Emits an event via the RTS tracing framework.  The contents+     of the event is the binary object passed as the first argument with+     the given length passed as the second argument. The event will be+     emitted to the @.eventlog@ file. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  TraceMarkerOp "traceMarker#" GenPrimOp+   Addr# -> State# s -> State# s+   { Emits a marker event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp+   Int64# -> State# RealWorld -> State# RealWorld+   { Sets the allocation counter for the current thread to the given value. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp+   Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld+   { Sets the allocation counter for the another thread to the given value.+     This doesn't take allocations into the current nursery chunk into account.+     Therefore it is only accurate if the other thread is not currently running. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primtype StackSnapshot#+   { Haskell representation of a @StgStack*@ that was created (cloned)+     with a function in "GHC.Stack.CloneStack". Please check the+     documentation in that module for more detailed explanations. }++------------------------------------------------------------------------+section "Safe coercions"+------------------------------------------------------------------------++pseudoop   "coerce"+   Coercible a b => a -> b+   { The function 'coerce' allows you to safely convert between values of+     types that have the same representation with no run-time overhead. In the+     simplest case you can use it instead of a newtype constructor, to go from+     the newtype's concrete type to the abstract type. But it also works in+     more complicated settings, e.g. converting a list of newtypes to a list of+     concrete types.++     When used in conversions involving a newtype wrapper,+     make sure the newtype constructor is in scope.++     This function is representation-polymorphic, but the+     'RuntimeRep' type argument is marked as 'Inferred', meaning+     that it is not available for visible type application. This means+     the typechecker will accept @'coerce' \@'Int' \@Age 42@.++     === __Examples__++     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)+     >>> coerce (Age 42) :: TTL+     TTL 42+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL+     TTL 43+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]+     [TTL 43,TTL 25]++   }++------------------------------------------------------------------------+section "SIMD Vectors"+        {Operations on SIMD vectors.}+------------------------------------------------------------------------++#define ALL_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8> \+  ,<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define SIGNED_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define FLOAT_VECTOR_TYPES \+  [<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define INT_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]++primtype VECTOR+   with vector = ALL_VECTOR_TYPES++primop VecBroadcastOp "broadcast#" GenPrimOp+   SCALAR -> VECTOR+   { Broadcast a scalar to all elements of a vector. }+   with vector = ALL_VECTOR_TYPES++primop VecPackOp "pack#" GenPrimOp+   VECTUPLE -> VECTOR+   { Pack the elements of an unboxed tuple into a vector. }+   with vector = ALL_VECTOR_TYPES++primop VecUnpackOp "unpack#" GenPrimOp+   VECTOR -> VECTUPLE+   { Unpack the elements of a vector into an unboxed tuple. }+   with vector = ALL_VECTOR_TYPES++primop VecInsertOp "insert#" GenPrimOp+   VECTOR -> SCALAR -> Int# -> VECTOR+   { Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecAddOp "plus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Add two vectors element-wise. }+   with commutable = True+        vector = ALL_VECTOR_TYPES++primop VecSubOp "minus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Subtract two vectors element-wise. }+   with vector = ALL_VECTOR_TYPES++primop VecMulOp "times#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Multiply two vectors element-wise. }+   with commutable = True+        vector = ALL_VECTOR_TYPES++primop VecDivOp "divide#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Divide two vectors element-wise. }+   with effect = CanFail+        vector = FLOAT_VECTOR_TYPES++primop VecQuotOp "quot#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. }+   with effect = CanFail+        vector = INT_VECTOR_TYPES+        div_like = True++primop VecRemOp "rem#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. }+   with effect = CanFail+        vector = INT_VECTOR_TYPES+        div_like = True+++primop VecNegOp "negate#" GenPrimOp+   VECTOR -> VECTOR+   { Negate element-wise. }+   with vector = SIGNED_VECTOR_TYPES++primop VecIndexByteArrayOp "indexArray#" GenPrimOp+   ByteArray# -> Int# -> VECTOR+   { Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadByteArrayOp "readArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)+   { Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteByteArrayOp "writeArray#" GenPrimOp+   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s+   { Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadOffAddrOp "readOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES+++primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp+   ByteArray# -> Int# -> VECTOR+   { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)+   { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp+   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s+   { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in scalar elements. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop   VecFMAdd   "fmadd#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFMSub   "fmsub#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFNMAdd   "fnmadd#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFNMSub   "fnmsub#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES++primop VecShuffleOp "shuffle#" GenPrimOp+  VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR+  {Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.}+   with vector = ALL_VECTOR_TYPES++primop VecMinOp "min#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   {Component-wise minimum of two vectors.}+   with+      vector = ALL_VECTOR_TYPES++primop VecMaxOp "max#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   {Component-wise maximum of two vectors.}+   with+      vector = ALL_VECTOR_TYPES++------------------------------------------------------------------------++section "Prefetch"+        {Prefetch operations: Note how every prefetch operation has a name+  with the pattern prefetch*N#, where N is either 0,1,2, or 3.++  This suffix number, N, is the "locality level" of the prefetch, following the+  convention in GCC and other compilers.+  Higher locality numbers correspond to the memory being loaded in more+  levels of the cpu cache, and being retained after initial use. The naming+  convention follows the naming convention of the prefetch intrinsic found+  in the GCC and Clang C compilers.++  On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic+  with locality level N. The code generated by LLVM is target architecture+  dependent, but should agree with the GHC NCG on x86 systems.++  On the PPC native backend, prefetch*N is a No-Op.++  On the x86 NCG, N=0 will generate prefetchNTA,+  N=1 generates prefetcht2, N=2 generates prefetcht1, and+  N=3 generates prefetcht0.++  For streaming workloads, the prefetch*0 operations are recommended.+  For workloads which do many reads or writes to a memory location in a short period of time,+  prefetch*3 operations are recommended.++  For further reading about prefetch and associated systems performance optimization,+  the instruction set and optimization manuals by Intel and other CPU vendors are+  excellent starting place.+++  The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is+  especially a helpful read, even if your software is meant for other CPU+  architectures or vendor hardware. The manual can be found at+  http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html .++  The @prefetch*@ family of operations has the order of operations+  determined by passing around the 'State#' token.++  To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context.++  It is important to note that while the prefetch operations will never change the+  answer to a pure computation, They CAN change the memory locations resident+  in a CPU cache and that may change the performance and timing characteristics+  of an application. The prefetch operations are marked as ReadWriteEffect+  to reflect that these operations have side effects with respect to the runtime+  performance characteristics of the resulting code. Additionally, if the prefetchValue+  operations did not have this attribute, GHC does a float out transformation that+  results in a let-can-float invariant violation, at least with the current design.+  }++++------------------------------------------------------------------------+++--- the Int# argument for prefetch is the byte offset on the byteArray or  Addr#++---+primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp+  Addr# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp+   a ->  State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp+   ByteArray# -> Int# -> State# s -> State# s+   with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+++-- Note [RuntimeRep polymorphism in continuation-style primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--  See below.++section "RuntimeRep polymorphism in continuation-style primops"+  {+  Several primops provided by GHC accept continuation arguments with highly polymorphic+  arguments. For instance, consider the type of `catch#`:++    catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w.+              (State# RealWorld -> (# State# RealWorld, r #) )+           -> (w -> State# RealWorld -> (# State# RealWorld, r #) )+           -> State# RealWorld+           -> (# State# RealWorld, r #)++  This type suggests that we could instantiate `catch#` continuation argument+  (namely, the first argument) with something like,++    f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #)++  However, sadly the type does not capture an important limitation of the+  primop. Specifically, due to the operational behavior of `catch#` the result+  type must be representable with a single machine word. In a future GHC+  release we may improve the precision of this type to capture this limitation.++  See #21868.+  }++------------------------------------------------------------------------+---                                                                  ---+------------------------------------------------------------------------++thats_all_folks
+ GHC/ByteCode/Asm.hs view
@@ -0,0 +1,1044 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveFunctor   #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE UnboxedTuples   #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--+--  (c) The University of Glasgow 2002-2006+--++-- | Bytecode assembler and linker+module GHC.ByteCode.Asm (+        assembleBCOs,+        bcoFreeNames,+        SizedSeq, sizeSS, ssElts,+        iNTERP_STACK_CHECK_THRESH,+        mkNativeCallInfoLit,++        -- * For testing+        assembleBCO+  ) where++import GHC.Prelude hiding ( any )+++import GHC.ByteCode.Instr+import GHC.ByteCode.InfoTable+import GHC.ByteCode.Types+import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )++import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Literal+import GHC.Types.Unique.DSet+import GHC.Types.SptEntry+import GHC.Types.Unique.FM+import GHC.Unit.Types++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Core.TyCon+import GHC.Data.SizedSeq+import GHC.Data.SmallArray++import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Cmm.Expr+import GHC.Cmm.Reg             ( GlobalArgRegs(..) )+import GHC.Cmm.CallConv        ( allArgRegsCover )+import GHC.Platform+import GHC.Platform.Profile+import Language.Haskell.Syntax.Module.Name++import Control.Monad+import qualified Control.Monad.Trans.State.Strict as MTL++import qualified Data.Array.Unboxed as Array+import qualified Data.Array.IO as Array+import Data.Array.Base  ( UArray(..), numElements, unsafeFreeze )++#if ! defined(DEBUG)+import Data.Array.Base  ( unsafeWrite )+#endif++import Foreign hiding (shiftL, shiftR)+import Data.ByteString (ByteString)+import Data.Char  (ord)+import Data.Maybe (fromMaybe)+import GHC.Float (castFloatToWord32, castDoubleToWord64)++import qualified Data.List as List ( any )+import GHC.Exts+++-- -----------------------------------------------------------------------------+-- 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 <- elemsFlatBag ptrs ] :+             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :+             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag 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+  :: Profile+  -> FlatBag (ProtoBCO Name)+  -> [TyCon]+  -> [(Name, ByteString)]+  -> Maybe InternalModBreaks+  -> [SptEntry]+  -> IO CompiledByteCode+assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  let itbls = mkITbls profile tycons+  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos+  return CompiledByteCode+    { bc_bcos = bcos+    , bc_itbls = itbls+    , bc_strs = top_strs+    , bc_breaks = modbreaks+    , bc_spt_entries = spt_entries+    }++-- Note [Allocating string literals]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Our strategy for handling top-level string literal bindings is described in+-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,+-- but not all Addr# literals in a program are guaranteed to be lifted to the+-- top level. Our strategy for handling local Addr# literals is somewhat simpler:+-- after assembling, we find all the BCONPtrStr arguments in the program, malloc+-- memory for them, and bake the resulting addresses into the instruction stream+-- in the form of BCONPtrWord arguments.+--+-- We used to allocate remote buffers for BCONPtrStr ByteStrings when+-- assembling, but this gets in the way of bytecode serialization: we+-- want the ability to serialize and reload assembled bytecode, so+-- it's better to preserve BCONPtrStr as-is, and only perform the+-- actual allocation at link-time.+--+-- Note that, as with top-level string literal bindings, this memory is never+-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for+-- top-level string literal bindings] in GHC.StgToByteCode for some discussion+-- about why.+--++data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)+                                  , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)+                                  , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )+                                  }++data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)+                                 , final_ptr_array :: !(SmallArray BCOPtr)+                                 , final_lit_array :: !(SmallArray BCONPtr) }++-- How many words we have written so far.+data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int }+++{-# NOINLINE inspectInstrs #-}+-- | Perform analysis of the bytecode to determine+--  1. How many instructions we will produce+--  2. If we are going to need long jumps.+--  3. The offsets that labels refer to+inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState+inspectInstrs platform long_jump e instrs =+  inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs)++{-# NOINLINE runInstrs #-}+-- | Assemble the bytecode from the instructions.+runInstrs ::  Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult+runInstrs platform long_jumps is_state instrs = do+  -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.+  isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1)+  ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined+  lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined+  let env :: LocalLabel -> Word+      env lbl = fromMaybe+        (pprPanic "assembleBCO.findLabel" (ppr lbl))+        (lookupUFM (lblEnv is_state) lbl)+  let initial_state  = AsmState 0 0 0+  let initial_reader = RunAsmReader{..}+  runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs)+  final_isn_array <- unsafeFreeze isn_array+  final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array+  final_lit_array <- unsafeFreezeSmallArrayIO lit_array+  return $ RunAsmResult {..}++assembleRunAsm :: Platform -> BCInstr -> RunAsm ()+assembleRunAsm p i = assembleI @RunAsm p i++assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()+assembleInspectAsm p i = assembleI @InspectAsm p i++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 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.+      is0 = inspectInstrs platform False initial_offset instrs+      (is1, long_jumps)+        | isLargeInspectState is0+                    = (inspectInstrs platform True initial_offset instrs, True)+        | otherwise = (is0, False)+++  -- pass 2: run assembler and generate instructions, literals and pointers+  RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs++  -- precomputed size should be equal to final size+  massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array+              && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array+              && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)+             (text "bytecode instruction count mismatch")++  let !insns_arr =  mkBCOByteArray $ final_isn_array+      !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap+      ul_bco = UnlinkedBCO { unlinkedBCOName = nm+                           , unlinkedBCOArity = arity+                           , unlinkedBCOInstrs = insns_arr+                           , unlinkedBCOBitmap = bitmap_arr+                           , unlinkedBCOLits = fromSmallArray final_lit_array+                           , unlinkedBCOPtrs = fromSmallArray final_ptr_array+                           }++  -- 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++-- | Construct a word-array containing an @StgLargeBitmap@.+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word+-- 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+++data Operand+  = Op Word+  | IOp Int+  | SmallOp Word16+  | LabelOp LocalLabel++wOp :: WordOff -> Operand+wOp = Op . fromIntegral++bOp :: ByteOff -> Operand+bOp = Op . fromIntegral++truncHalfWord :: Platform -> HalfWord -> Operand+truncHalfWord platform w = case platformWordSize platform of+  PW4 | w <= 65535      -> Op (fromIntegral w)+  PW8 | w <= 4294967295 -> Op (fromIntegral w)+  _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w)+++ptr :: MonadAssembler m => BCOPtr -> m Word+ptr = ioptr . return++type LabelEnv = LocalLabel -> Word++largeOp :: Bool -> Operand -> Bool+largeOp long_jumps op = case op of+   SmallOp _ -> False+   Op w      -> isLargeW w+   IOp i     -> isLargeI i+   LabelOp _ -> long_jumps++newtype RunAsm a = RunAsm' { runRunAsm :: Bool+                                       -> LabelEnv+                                       -> RunAsmReader+                                       -> AsmState+                                       -> IO (AsmState, a) }++pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))+                  -> RunAsm a+pattern RunAsm m <- RunAsm' m+  where+    RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d)+{-# COMPLETE RunAsm #-}++instance Functor RunAsm where+  fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s))++instance Applicative RunAsm where+  pure x = RunAsm $ \_ _ _ !s -> pure (s, x)+  (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do+                                  (!s', f') <- f a b c s+                                  (!s'', x') <- x a b c s'+                                  return (s'', f' x')+  {-# INLINE (<*>) #-}+++instance Monad RunAsm where+  return  = pure+  (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s'+  {-# INLINE (>>=) #-}++runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a+runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s++expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()+expand word_size largeArgs o = do+  e <- askEnv+  case o of+    (SmallOp w) -> writeIsn w+    (LabelOp w) -> let !r = e w in handleLargeArg r+    (Op w) -> handleLargeArg w+    (IOp i) -> handleLargeArg i++  where+    handleLargeArg :: Integral a => a -> RunAsm ()+    handleLargeArg w  =+      if largeArgs+        then largeArg word_size (fromIntegral w)+        else writeIsn (fromIntegral w)++lift :: IO a -> RunAsm a+lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a)++askLongJumps :: RunAsm Bool+askLongJumps = RunAsm $ \a _ _ s -> pure (s, a)++askEnv :: RunAsm LabelEnv+askEnv = RunAsm $ \_ b _ s -> pure (s, b)++writePtr :: BCOPtr -> RunAsm Word+writePtr w+            = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO ptr_array (nptr asm) w+              let !n' = nptr asm + 1+              let !asm' = asm { nptr = n' }+              return (asm', fromIntegral (nptr asm))++writeLit :: BCONPtr -> RunAsm Word+writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO lit_array (nlit asm) w+              let !n' = nlit asm + 1+              let !asm' = asm { nlit = n' }+              return (asm', fromIntegral (nlit asm))++writeLits :: OneOrTwo BCONPtr -> RunAsm Word+writeLits (OnlyOne l) = writeLit l+writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2++writeIsn :: Word16 -> RunAsm ()+writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+#if defined(DEBUG)+              Array.writeArray isn_array (nisn asm) w+#else+              unsafeWrite isn_array (nisn asm) w+#endif+              let !n' = nisn asm + 1+              let !asm' = asm { nisn = n' }+              return (asm', ())++{-# INLINE any #-}+-- Any is unrolled manually so that the call in `emit` can be eliminated without+-- relying on SpecConstr (which does not work across modules).+any :: (a -> Bool) -> [a] -> Bool+any _ [] = False+any f [x] = f x+any f [x,y] = f x || f y+any f [x,y,z] = f x || f y || f z+any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4+any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5+any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6+any f xs = List.any f xs++{-# INLINE mapM6_ #-}+mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()+mapM6_ _ [] = return ()+mapM6_ f [x] = () <$ f x+mapM6_ f [x,y] = () <$ f x <* f y+mapM6_ f [x,y,z] = () <$ f x <* f y <* f z+mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4+mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5+mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6+mapM6_ f xs = mapM_ f xs++instance MonadAssembler RunAsm where+  ioptr p_io = do+    p <- lift p_io+    writePtr p+  lit lits = writeLits lits++  label _ = return ()++  emit pwordsize w ops = do+    long_jumps <- askLongJumps+    -- See the definition of `any` above+    let largeArgs = any (largeOp long_jumps) ops+    let opcode+          | largeArgs = largeArgInstr w+          | otherwise = w+    writeIsn opcode+    mapM6_ (expand pwordsize largeArgs) ops++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++type LabelEnvMap = UniqFM LocalLabel Word++data InspectState = InspectState+  { instrCount :: !Word+  , ptrCount :: !Word+  , litCount :: !Word+  , lblEnv :: LabelEnvMap+  }++instance Outputable InspectState where+  ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)]++isLargeInspectState :: InspectState -> Bool+isLargeInspectState InspectState{..} =+  isLargeW (fromIntegral $ sizeUFM lblEnv)+    || isLargeW instrCount++newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool+                                }++newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState,  a #) }++pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))+                   -> InspectAsm a+pattern InspectAsm m <- InspectAsm' m+  where+    InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b)+{-# COMPLETE InspectAsm #-}++instance Functor InspectAsm where+  fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of+                                                  (# b', c #) -> (# b', f c #)++instance Applicative InspectAsm where+  pure x = InspectAsm $ \_ s -> (# s, x #)+  (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of+                                                              (# s', f' #) ->+                                                                case x a s' of+                                                                  (# s'', x' #) -> (# s'', f' x' #)++instance Monad InspectAsm where+  return = pure+  (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of+                                                (# s', a' #) -> runInspectAsm (f a') a s'++get_ :: InspectAsm InspectState+get_ = InspectAsm $ \_ b -> (# b, b #)++put_ :: InspectState -> InspectAsm ()+put_ !s = InspectAsm $ \_ _ -> (# s, () #)++modify_ :: (InspectState -> InspectState) -> InspectAsm ()+modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #)++ask_ :: InspectAsm InspectEnv+ask_ = InspectAsm $ \a b -> (# b, a #)++inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState+inspectAsm long_jumps initial_offset (InspectAsm s) =+  case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of+    (# res, () #) -> res+{-# INLINE inspectAsm #-}++++instance MonadAssembler InspectAsm where+  ioptr _ = do+    s <- get_+    let n = ptrCount s+    put_ (s { ptrCount = n + 1 })+    return n++  lit ls = do+    s <- get_+    let n = litCount s+    put_ (s { litCount = n + oneTwoLength ls })+    return n++  label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' })++  emit pwordsize _ ops = do+    InspectEnv long_jumps <- ask_+    -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed+    -- to unroll for arguments up to size 6.+    let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1+        largeOps = any (largeOp long_jumps) ops+        bigSize = largeArg16s pwordsize+        count' = if largeOps then countLarge bigSize else countSmall bigSize++    s <- get_+    put_ (s { instrCount = instrCount s + size })++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++count :: Word -> Bool -> Operand -> Word+count _ _ (SmallOp _)          = 1+count big largeOps (LabelOp _) = if largeOps then big else 1+count big largeOps (Op _)      = if largeOps then big else 1+count big largeOps (IOp _)     = if largeOps then big else 1+{-# INLINE count #-}++countSmall, countLarge :: Word -> Operand -> Word+countLarge big x = count big True x+countSmall big x = count big False x+++-- Bring in all the bci_ bytecode constants.+#include "Bytecodes.h"++largeArgInstr :: Word16 -> Word16+largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci++{-# INLINE largeArg #-}+largeArg :: PlatformWordSize -> Word64 -> RunAsm ()+largeArg wsize w = case wsize of+   PW8 ->  do writeIsn (fromIntegral (w `shiftR` 48))+              writeIsn (fromIntegral (w `shiftR` 32))+              writeIsn (fromIntegral (w `shiftR` 16))+              writeIsn (fromIntegral w)+   PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))+                    (text "largeArg too big:" <+> ppr w) $ do+          writeIsn (fromIntegral (w `shiftR` 16))+          writeIsn (fromIntegral w)++largeArg16s :: PlatformWordSize -> Word+largeArg16s pwordsize = case pwordsize of+   PW8 -> 4+   PW4 -> 2++data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor)++oneTwoLength :: OneOrTwo a -> Word+oneTwoLength (OnlyOne {}) = 1+oneTwoLength (OnlyTwo {}) = 2++class Monad m => MonadAssembler m where+  ioptr :: IO BCOPtr -> m Word+  lit :: OneOrTwo BCONPtr -> m Word+  label :: LocalLabel -> m ()+  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()++lit1 :: MonadAssembler m => BCONPtr -> m Word+lit1 p = lit (OnlyOne p)++{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}+{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}++assembleI :: forall m . MonadAssembler m+          => Platform+          -> BCInstr+          -> m ()+assembleI platform i = case i of+  STKCHECK n               -> emit_ bci_STKCHECK [Op n]+  PUSH_L o1                -> emit_ bci_PUSH_L [wOp o1]+  PUSH_LL o1 o2            -> emit_ bci_PUSH_LL [wOp o1, wOp o2]+  PUSH_LLL o1 o2 o3        -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]+  PUSH8 o1                 -> emit_ bci_PUSH8 [bOp o1]+  PUSH16 o1                -> emit_ bci_PUSH16 [bOp o1]+  PUSH32 o1                -> emit_ bci_PUSH32 [bOp o1]+  PUSH8_W o1               -> emit_ bci_PUSH8_W [bOp o1]+  PUSH16_W o1              -> emit_ bci_PUSH16_W [bOp o1]+  PUSH32_W o1              -> emit_ bci_PUSH32_W [bOp 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 pk+                           -> do let ul_bco = assembleBCO platform proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit_ (push_alts pk) [Op p]+  PUSH_ALTS_TUPLE proto call_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 <- word (fromIntegral $+                                              mkNativeCallInfoSig platform call_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, wOp nws]+  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode+  PUSH_ADDR nm             -> do np <- lit1 (BCONPtrAddr nm)+                                 emit_ bci_PUSH_UBX [Op np, SmallOp 1]++  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 [wOp n, wOp by]+  ALLOC_AP  n              -> emit_ bci_ALLOC_AP [truncHalfWord platform n]+  ALLOC_AP_NOUPD n         -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]+  ALLOC_PAP arity n        -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]+  MKAP      off sz         -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz]+  MKPAP     off sz         -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]+  UNPACK    n              -> emit_ bci_UNPACK [wOp n]+  PACK      dcon sz        -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))+                                 emit_ bci_PACK [Op itbl_no, wOp 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_I64  i l          -> do np <- word64 (fromIntegral i)+                                 emit_ bci_TESTLT_I64 [Op np, LabelOp l]+  TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)+                                 emit_ bci_TESTEQ_I64 [Op np, LabelOp l]+  TESTLT_I32  i l          -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I32 [Op np, LabelOp l]+  TESTEQ_I32 i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I32 [Op np, LabelOp l]+  TESTLT_I16  i l          -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I16 [Op np, LabelOp l]+  TESTEQ_I16 i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I16 [Op np, LabelOp l]+  TESTLT_I8  i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I8 [Op np, LabelOp l]+  TESTEQ_I8 i l            -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I8 [Op np, LabelOp l]+  TESTLT_W64  w l          -> do np <- word64 w+                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]+  TESTEQ_W64  w l          -> do np <- word64 w+                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]+  TESTLT_W32  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W32 [Op np, LabelOp l]+  TESTEQ_W32  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W32 [Op np, LabelOp l]+  TESTLT_W16  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W16 [Op np, LabelOp l]+  TESTEQ_W16  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W16 [Op np, LabelOp l]+  TESTLT_W8  w l           -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W8 [Op np, LabelOp l]+  TESTEQ_W8  w l           -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W8 [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 [wOp stkoff, IOp n]+  JMP       l              -> emit_ bci_JMP [LabelOp l]+  ENTER                    -> emit_ bci_ENTER []+  RETURN rep               -> emit_ (return_non_tuple rep) []+  RETURN_TUPLE             -> emit_ bci_RETURN_T []+  CCALL off ffi i          -> do np <- lit1 $ BCONPtrFFIInfo ffi+                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]+  PRIMCALL                 -> emit_ bci_PRIMCALL []++  OP_ADD w -> case w of+    W64                   -> emit_ bci_OP_ADD_64 []+    W32                   -> emit_ bci_OP_ADD_32 []+    W16                   -> emit_ bci_OP_ADD_16 []+    W8                    -> emit_ bci_OP_ADD_08 []+    _                     -> unsupported_width+  OP_SUB w -> case w of+    W64                   -> emit_ bci_OP_SUB_64 []+    W32                   -> emit_ bci_OP_SUB_32 []+    W16                   -> emit_ bci_OP_SUB_16 []+    W8                    -> emit_ bci_OP_SUB_08 []+    _                     -> unsupported_width+  OP_AND w -> case w of+    W64                   -> emit_ bci_OP_AND_64 []+    W32                   -> emit_ bci_OP_AND_32 []+    W16                   -> emit_ bci_OP_AND_16 []+    W8                    -> emit_ bci_OP_AND_08 []+    _                     -> unsupported_width+  OP_XOR w -> case w of+    W64                   -> emit_ bci_OP_XOR_64 []+    W32                   -> emit_ bci_OP_XOR_32 []+    W16                   -> emit_ bci_OP_XOR_16 []+    W8                    -> emit_ bci_OP_XOR_08 []+    _                     -> unsupported_width+  OP_OR w -> case w of+    W64                    -> emit_ bci_OP_OR_64 []+    W32                    -> emit_ bci_OP_OR_32 []+    W16                    -> emit_ bci_OP_OR_16 []+    W8                     -> emit_ bci_OP_OR_08 []+    _                      -> unsupported_width+  OP_NOT w -> case w of+    W64                   -> emit_ bci_OP_NOT_64 []+    W32                   -> emit_ bci_OP_NOT_32 []+    W16                   -> emit_ bci_OP_NOT_16 []+    W8                    -> emit_ bci_OP_NOT_08 []+    _                     -> unsupported_width+  OP_NEG w -> case w of+    W64                   -> emit_ bci_OP_NEG_64 []+    W32                   -> emit_ bci_OP_NEG_32 []+    W16                   -> emit_ bci_OP_NEG_16 []+    W8                    -> emit_ bci_OP_NEG_08 []+    _                     -> unsupported_width+  OP_MUL w -> case w of+    W64                   -> emit_ bci_OP_MUL_64 []+    W32                   -> emit_ bci_OP_MUL_32 []+    W16                   -> emit_ bci_OP_MUL_16 []+    W8                    -> emit_ bci_OP_MUL_08 []+    _                     -> unsupported_width+  OP_SHL w -> case w of+    W64                   -> emit_ bci_OP_SHL_64 []+    W32                   -> emit_ bci_OP_SHL_32 []+    W16                   -> emit_ bci_OP_SHL_16 []+    W8                    -> emit_ bci_OP_SHL_08 []+    _                     -> unsupported_width+  OP_ASR w -> case w of+    W64                   -> emit_ bci_OP_ASR_64 []+    W32                   -> emit_ bci_OP_ASR_32 []+    W16                   -> emit_ bci_OP_ASR_16 []+    W8                    -> emit_ bci_OP_ASR_08 []+    _                     -> unsupported_width+  OP_LSR w -> case w of+    W64                   -> emit_ bci_OP_LSR_64 []+    W32                   -> emit_ bci_OP_LSR_32 []+    W16                   -> emit_ bci_OP_LSR_16 []+    W8                    -> emit_ bci_OP_LSR_08 []+    _                     -> unsupported_width++  OP_NEQ w -> case w of+    W64                   -> emit_ bci_OP_NEQ_64 []+    W32                   -> emit_ bci_OP_NEQ_32 []+    W16                   -> emit_ bci_OP_NEQ_16 []+    W8                    -> emit_ bci_OP_NEQ_08 []+    _                     -> unsupported_width+  OP_EQ w -> case w of+    W64                    -> emit_ bci_OP_EQ_64 []+    W32                    -> emit_ bci_OP_EQ_32 []+    W16                    -> emit_ bci_OP_EQ_16 []+    W8                     -> emit_ bci_OP_EQ_08 []+    _                      -> unsupported_width++  OP_U_LT w -> case w of+    W64                  -> emit_ bci_OP_U_LT_64 []+    W32                  -> emit_ bci_OP_U_LT_32 []+    W16                  -> emit_ bci_OP_U_LT_16 []+    W8                   -> emit_ bci_OP_U_LT_08 []+    _                    -> unsupported_width+  OP_S_LT w -> case w of+    W64                  -> emit_ bci_OP_S_LT_64 []+    W32                  -> emit_ bci_OP_S_LT_32 []+    W16                  -> emit_ bci_OP_S_LT_16 []+    W8                   -> emit_ bci_OP_S_LT_08 []+    _                    -> unsupported_width+  OP_U_GE w -> case w of+    W64                  -> emit_ bci_OP_U_GE_64 []+    W32                  -> emit_ bci_OP_U_GE_32 []+    W16                  -> emit_ bci_OP_U_GE_16 []+    W8                   -> emit_ bci_OP_U_GE_08 []+    _                    -> unsupported_width+  OP_S_GE w -> case w of+    W64                  -> emit_ bci_OP_S_GE_64 []+    W32                  -> emit_ bci_OP_S_GE_32 []+    W16                  -> emit_ bci_OP_S_GE_16 []+    W8                   -> emit_ bci_OP_S_GE_08 []+    _                    -> unsupported_width+  OP_U_GT w -> case w of+    W64                  -> emit_ bci_OP_U_GT_64 []+    W32                  -> emit_ bci_OP_U_GT_32 []+    W16                  -> emit_ bci_OP_U_GT_16 []+    W8                   -> emit_ bci_OP_U_GT_08 []+    _                    -> unsupported_width+  OP_S_GT w -> case w of+    W64                  -> emit_ bci_OP_S_GT_64 []+    W32                  -> emit_ bci_OP_S_GT_32 []+    W16                  -> emit_ bci_OP_S_GT_16 []+    W8                   -> emit_ bci_OP_S_GT_08 []+    _                    -> unsupported_width+  OP_U_LE w -> case w of+    W64                  -> emit_ bci_OP_U_LE_64 []+    W32                  -> emit_ bci_OP_U_LE_32 []+    W16                  -> emit_ bci_OP_U_LE_16 []+    W8                   -> emit_ bci_OP_U_LE_08 []+    _                    -> unsupported_width+  OP_S_LE w -> case w of+    W64                  -> emit_ bci_OP_S_LE_64 []+    W32                  -> emit_ bci_OP_S_LE_32 []+    W16                  -> emit_ bci_OP_S_LE_16 []+    W8                   -> emit_ bci_OP_S_LE_08 []+    _                    -> unsupported_width++  OP_INDEX_ADDR w -> case w of+    W64                  -> emit_ bci_OP_INDEX_ADDR_64 []+    W32                  -> emit_ bci_OP_INDEX_ADDR_32 []+    W16                  -> emit_ bci_OP_INDEX_ADDR_16 []+    W8                   -> emit_ bci_OP_INDEX_ADDR_08 []+    _                    -> unsupported_width++  BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do+    p1 <- ptr $ BCOPtrBreakArray info_mod+    let -- cast that checks that round-tripping through Word32 doesn't change the value+        infoW32 = let r = fromIntegral infox :: Word32+                   in if fromIntegral r == infox+                    then r+                    else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox)+        ix_hi = fromIntegral (infoW32 `shiftR` 16)+        ix_lo = fromIntegral (infoW32 .&. 0xffff)+    info_addr        <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod+    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS     $ moduleUnitId info_mod+    np               <- lit1 $ BCONPtrCostCentre ibi+    emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr+                      , SmallOp ix_hi, SmallOp ix_lo, Op np ]++#if MIN_VERSION_rts(1,0,3)+  BCO_NAME name            -> do np <- lit1 (BCONPtrStr name)+                                 emit_ bci_BCO_NAME [Op np]+#endif++++  where+    unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"+    emit_ = emit word_size++    literal :: Literal -> m Word+    literal (LitLabel fs _)   = litlabel fs+    literal LitNullAddr       = word 0+    literal (LitFloat r)      = float (fromRational r)+    literal (LitDouble r)     = double (fromRational r)+    literal (LitChar c)       = int (ord c)+    literal (LitString bs)    = lit1 (BCONPtrStr bs)+       -- LitString requires a zero-terminator when emitted+    literal (LitNumber nt i) = case nt of+      LitNumInt     -> word (fromIntegral i)+      LitNumWord    -> word (fromIntegral i)+      LitNumInt8    -> word8 (fromIntegral i)+      LitNumWord8   -> word8 (fromIntegral i)+      LitNumInt16   -> word16 (fromIntegral i)+      LitNumWord16  -> word16 (fromIntegral i)+      LitNumInt32   -> word32 (fromIntegral i)+      LitNumWord32  -> word32 (fromIntegral i)+      LitNumInt64   -> word64 (fromIntegral i)+      LitNumWord64  -> word64 (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 {}) = word 0++    litlabel fs = lit1 (BCONPtrLbl fs)+    words ws = lit (fmap BCONPtrWord ws)+    word w = words (OnlyOne w)+    word2 w1 w2 = words (OnlyTwo w1 w2)+    word_size  = platformWordSize platform+    word_size_bits = platformWordSizeInBits platform++    -- 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.+    --+    -- Note that we only support host endianness == target endianness for now,+    -- even with the external interpreter. This would need to be fixed to+    -- support host endianness /= target endianness+    int :: Int -> m Word+    int  i = word (fromIntegral i)++    float :: Float -> m Word+    float f = word32 (castFloatToWord32 f)++    double :: Double -> m Word+    double d = word64 (castDoubleToWord64 d)++    word64 :: Word64 -> m Word+    word64 ww = case word_size of+       PW4 ->+        let !wl = fromIntegral ww+            !wh = fromIntegral (ww `unsafeShiftR` 32)+        in case platformByteOrder platform of+            LittleEndian -> word2 wl wh+            BigEndian    -> word2 wh wl+       PW8 -> word (fromIntegral ww)++    word8 :: Word8 -> m Word+    word8  x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))++    word16 :: Word16 -> m Word+    word16 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))++    word32 :: Word32 -> m Word+    word32 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> case word_size of+        PW4 -> word (fromIntegral x)+        PW8 -> word (fromIntegral x `unsafeShiftL` 32)+++isLargeW :: Word -> Bool+isLargeW n = n > 65535++isLargeI :: Int -> Bool+isLargeI n = n > 32767 || n < -32768++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_non_tuple :: ArgRep -> Word16+return_non_tuple V   = bci_RETURN_V+return_non_tuple P   = bci_RETURN_P+return_non_tuple N   = bci_RETURN_N+return_non_tuple L   = bci_RETURN_L+return_non_tuple F   = bci_RETURN_F+return_non_tuple D   = bci_RETURN_D+return_non_tuple V16 = error "return_non_tuple: vector"+return_non_tuple V32 = error "return_non_tuple: vector"+return_non_tuple V64 = error "return_non_tuple: 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+  Jumps.cmm, 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).+ -}+maxTupleReturnNativeStackSize :: WordOff+maxTupleReturnNativeStackSize = 62++{-+  Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall+  use to convert arguments between the native calling convention and the+  interpreter.++  See Note [GHCi and native call registers] for more information.+ -}+mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32+mkNativeCallInfoSig platform NativeCallInfo{..}+  | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize+  = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler"+             (ppr nativeCallStackSpillSize <+> text "stack words." <+>+              text "Use -fobject-code to get around this limit"+             )+  | otherwise+  = -- 24 bits for register bitmap+    assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))++    -- 8 bits for continuation offset (only for NativeTupleReturn)+    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)++    -- all regs accounted for+    assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))+      ( vcat+        [ text "not all registers accounted for"+        , text "argRegs:" <+> ppr argRegs+        , text "nativeCallRegs:" <+> ppr nativeCallRegs+        ] ) $+      -- SIMD GHCi TODO: the above assertion doesn't account for register overlap;+      -- it will need to be adjusted for SIMD vector support in the bytecode interpreter.++    foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)+  where+    cont_offset :: Word32+    cont_offset+      | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize+      | otherwise                           = 0 -- there is no continuation for primcalls++    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32+    reg_bit x (r, n)+      | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n+      | otherwise                     = x+    argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]+      -- The bytecode interpreter does not (currently) handle vector registers,+      -- so we only use the scalar argument-passing registers here.++mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal+mkNativeCallInfoLit platform call_info =+  mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info++iNTERP_STACK_CHECK_THRESH :: Int+iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
+ GHC/ByteCode/Breakpoints.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Breakpoint information constructed during ByteCode generation.+--+-- Specifically, code-generation breakpoints are referred to as "internal+-- breakpoints", the internal breakpoint data for a module is stored in+-- 'InternalModBreaks', and is uniquely identified at runtime by an+-- 'InternalBreakpointId'.+--+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]+module GHC.ByteCode.Breakpoints+  ( -- * Internal Mod Breaks+    InternalModBreaks(..), CgBreakInfo(..)+  , mkInternalModBreaks, imodBreaks_module++    -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex+  , InternalBreakLoc(..)++    -- * Operations++    -- ** Internal-level operations+  , getInternalBreak++    -- ** Source-level information operations+  , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS+  , getBreakSourceId, getBreakSourceMod++    -- * Utils+  , seqInternalModBreaks++  )+  where++import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Name.Occurrence+import Control.DeepSeq+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IM++import GHC.HsToCore.Breakpoints+import GHC.Iface.Syntax++import GHC.Unit.Module (Module)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Data.Array++{-+Note [ModBreaks vs InternalModBreaks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'ModBreaks' and 'BreakpointId's must not to be confused with+'InternalModBreaks' and 'InternalBreakId's.++'ModBreaks' is constructed once during HsToCore from the information attached+to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'+can be queried using 'BreakpointId's, which uniquely identifies a breakpoint+within the list of breakpoint information for a given module's 'ModBreaks'.++'InternalModBreaks' are constructed during bytecode generation and are indexed+by a 'InternalBreakpointId'. They contain all the information relevant to a+breakpoint for code generation that can be accessed during runtime execution+(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's+are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'+instruction receives 'InternalBreakpointId' as an argument.++We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used+to get source-level information about a breakpoint via the corresponding 'ModBreaks'.++Notably, 'InternalModBreaks' can contain entries for so-called internal+breakpoints, which do not necessarily have a source-level location attached to+it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to+introduce breakpoints during code generation for features such as stepping-out.++Note [Breakpoint identifiers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before optimization a breakpoint is identified uniquely with a tick module+and a tick index. See 'BreakpointId'. A tick module contains an array, indexed+with the tick indexes, which indicates breakpoint status.++When we generate ByteCode, we collect information for every breakpoint at+their *occurrence sites* (see CgBreakInfo) and these info+are stored in the ModIface of the occurrence module. Because of inlining, we+can't reuse the tick index to uniquely identify an occurrence; because of+cross-module inlining, we can't assume that the occurrence module is the same+as the tick module (#24712).++So every breakpoint occurrence gets assigned a module-unique *info index* and+we store it alongside the occurrence module (*info module*) in the+'InternalBreakpointId' datatype. This is the index that we use at runtime to+identify a breakpoint.++When the internal breakpoint has a matching tick-level breakpoint we can fetch+the related tick-level information by first looking up a mapping+@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@.+-}++--------------------------------------------------------------------------------+-- * Internal breakpoint identifiers+--------------------------------------------------------------------------------++-- | Internal breakpoint info index+type BreakInfoIndex = Int++-- | Internal breakpoint identifier+--+-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.+-- See Note [Breakpoint identifiers]+data InternalBreakpointId = InternalBreakpointId+  { ibi_info_mod   :: !Module         -- ^ Breakpoint info module+  , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index+  }+  deriving (Eq, Ord)++--------------------------------------------------------------------------------+-- * Internal Mod Breaks+--------------------------------------------------------------------------------++-- | Internal mod breaks store the runtime-relevant information of breakpoints.+--+-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'.+--+-- 'InternalModBreaks' are constructed during bytecode generation and stored in+-- 'CompiledByteCode' afterwards.+data InternalModBreaks = InternalModBreaks+      { imodBreaks_breakInfo :: !(IntMap CgBreakInfo)+        -- ^ Access code-gen time information about a breakpoint, indexed by+        -- 'InternalBreakpointId'.++      , imodBreaks_modBreaks :: !ModBreaks+        -- ^ Store the ModBreaks for this module+        --+        -- Recall Note [Breakpoint identifiers]: for some module A, an+        -- *occurrence* of a breakpoint in A may have been inlined from some+        -- breakpoint *defined* in module B.+        --+        -- This 'ModBreaks' contains information regarding all the breakpoints+        -- defined in the module this 'InternalModBreaks' corresponds to. It+        -- /does not/ necessarily have information regarding all the breakpoint+        -- occurrences registered in 'imodBreaks_breakInfo'. Some of those+        -- occurrences may refer breakpoints inlined from other modules.+      }++-- | Construct an 'InternalModBreaks'.+--+-- INVARIANT: The given 'ModBreaks' correspond to the same module as this+-- 'InternalModBreaks' module (the first argument) and its breakpoint infos+-- (the @IntMap CgBreakInfo@ argument)+mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks+mkInternalModBreaks mod im mbs =+  assertPpr (mod == modBreaks_module mbs)+    (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $+      InternalModBreaks im mbs++-- | Get the module to which these 'InternalModBreaks' correspond+imodBreaks_module :: InternalModBreaks -> Module+imodBreaks_module = modBreaks_module . imodBreaks_modBreaks++-- | Information about a breakpoint that we know at code-generation time+-- In order to be used, this needs to be hydrated relative to the current HscEnv by+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for+-- preventing space leaks (see #22530)+data CgBreakInfo+   = CgBreakInfo+   { cgb_tyvars  :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint+   , cgb_vars    :: ![Maybe (IfaceIdBndr, Word)]+   , cgb_resty   :: !IfaceType+   , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)+     -- ^ This field records the original breakpoint tick identifier for this+     -- internal breakpoint info. It is used to convert a breakpoint+     -- *occurrence* index ('InternalBreakpointId') into a *definition* index+     -- ('BreakpointId').+     --+     -- The modules of breakpoint occurrence and breakpoint definition are not+     -- necessarily the same: See Note [Breakpoint identifiers].+     --+     -- If there is no original tick identifier (that is, the breakpoint was+     -- created during code generation), we re-use the BreakpointId of something else.+     -- It would also be reasonable to have an @Either something BreakpointId@+     -- for @cgb_tick_id@, but currently we can always re-use a source-level BreakpointId.+     -- In the case of step-out, see Note [Debugger: Stepout internal break locs]+   }+-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval++-- | Breakpoints created during code generation don't have a source-level tick+-- location. Instead, we re-use an existing one.+newtype InternalBreakLoc = InternalBreakLoc { internalBreakLoc :: BreakpointId }+  deriving newtype (Eq, NFData, Outputable)++-- | Get an internal breakpoint info by 'InternalBreakpointId'+getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo+getInternalBreak (InternalBreakpointId mod ix) imbs =+  assert_modules_match mod (imodBreaks_module imbs) $+    imodBreaks_breakInfo imbs IM.! ix++-- | Assert that the module in the 'InternalBreakpointId' and in+-- 'InternalModBreaks' match.+assert_modules_match :: Module -> Module -> a -> a+assert_modules_match ibi_mod imbs_mod =+  assertPpr (ibi_mod == imbs_mod)+    (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod+        <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod)++--------------------------------------------------------------------------------+-- Tick-level Breakpoint information+--------------------------------------------------------------------------------++-- | Get the source module and tick index for this breakpoint+-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId+getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either internalBreakLoc id (cgb_tick_id cgb)++-- | Get the source module for this breakpoint (where the breakpoint is defined)+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either (bi_tick_mod . internalBreakLoc) bi_tick_mod (cgb_tick_id cgb)++-- | Get the source span for this breakpoint+getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan+getBreakLoc = getBreakXXX modBreaks_locs++-- | Get the vars for this breakpoint+getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]+getBreakVars = getBreakXXX modBreaks_vars++-- | Get the decls for this breakpoint+getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]+getBreakDecls = getBreakXXX modBreaks_decls++-- | Get the decls for this breakpoint+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))+getBreakCCS = getBreakXXX modBreaks_ccs++-- | Internal utility to access a ModBreaks field at a particular breakpoint index+--+-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the+-- *occurrence* module) doesn't necessarily match the module where the+-- tick breakpoint was defined with the relevant 'ModBreaks'.+--+-- When the tick module is the same as the internal module, we use the stored+-- 'ModBreaks'. When the tick module is different, we need to look up the+-- 'ModBreaks' in the HUG for that other module.+--+-- When there is no tick module (the breakpoint was generated at codegen), use+-- the function on internal mod breaks.+--+-- To avoid cyclic dependencies, we instead receive a function that looks up+-- the 'ModBreaks' given a 'Module'+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a+getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $ do+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+    case either internalBreakLoc id (cgb_tick_id cgb) of+      BreakpointId{bi_tick_mod, bi_tick_index}+        | bi_tick_mod == ibi_mod+        -> do+          let these_mbs = imodBreaks_modBreaks imbs+          return $ view these_mbs ! bi_tick_index+        | otherwise+        -> do+          other_mbs <- lookupModule bi_tick_mod+          return $ view other_mbs ! bi_tick_index++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++-- | Fully force an 'InternalModBreaks' value+seqInternalModBreaks :: InternalModBreaks -> ()+seqInternalModBreaks InternalModBreaks{..} =+    rnf (fmap seqCgBreakInfo imodBreaks_breakInfo)+  where+    seqCgBreakInfo :: CgBreakInfo -> ()+    seqCgBreakInfo CgBreakInfo{..} =+        rnf cgb_tyvars `seq`+        rnf cgb_vars `seq`+        rnf cgb_resty `seq`+        rnf cgb_tick_id++instance Outputable InternalBreakpointId where+  ppr InternalBreakpointId{..} =+    text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index++instance NFData InternalBreakpointId where+  rnf InternalBreakpointId{..} =+    rnf ibi_info_mod `seq` rnf ibi_info_index++instance Outputable CgBreakInfo where+   ppr info = text "CgBreakInfo" <+>+              parens (ppr (cgb_vars info) <+>+                      ppr (cgb_resty info) <+>+                      ppr (cgb_tick_id info))
+ GHC/ByteCode/InfoTable.hs view
@@ -0,0 +1,84 @@++{-# 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 GHCi.Message++import GHC.Types.Name       ( Name, getName )+import GHC.Types.RepType++import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )+import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDataCons )+import GHC.Core.Multiplicity     ( scaledThing )++import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )+import GHC.StgToCmm.Closure ( tagForCon )++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 :: Profile -> [TyCon] -> [(Name, ConInfoTable)]+mkITbls profile tcs = concatMap mkITbl (filter isBoxedDataTyCon tcs)+ where+  mkITbl :: TyCon -> [(Name, ConInfoTable)]+  mkITbl tc+    | dcs `lengthIs` n -- paranoia; this is an assertion.+    = make_constr_itbls profile dcs+       where+          dcs = tyConDataCons tc+          n   = tyConFamilySize tc+  mkITbl _ = panic "mkITbl"++-- Assumes constructors are numbered from zero, not one+make_constr_itbls :: Profile -> [DataCon] -> [(Name, ConInfoTable)]+make_constr_itbls profile cons =+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  map (uncurry mk_itbl) (zip cons [0..])+  where+    mk_itbl :: DataCon -> Int -> (Name, ConInfoTable)+    mk_itbl dcon conNo =+      ( getName dcon,+        ConInfoTable+          tables_next_to_code+          ptrs'+          nptrs_really+          conNo+          (tagForCon platform dcon)+          descr+      )+      where+         rep_args = [ 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
+ GHC/ByteCode/Instr.hs view
@@ -0,0 +1,591 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# 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 GHC.Cmm.Type (Width)+import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Utils.Outputable+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Types.Unique+import GHC.Core.DataCon+import GHC.Builtin.PrimOps+import GHC.Runtime.Heap.Layout ( StgWord )++import Data.Int+import Data.Word++#if MIN_VERSION_rts(1,0,3)+import Data.ByteString (ByteString)+#endif+++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 :: Word,+        protoBCOArity      :: Int,+        -- what the BCO came from, for debugging only+        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs+   }++-- | A local block label (e.g. identifying a case alternative).+newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }+  deriving (Eq, Ord)++-- Just so we can easily juse UniqFM.+instance Uniquable LocalLabel where+  getUnique (LocalLabel w) = mkUniqueGrimily $ fromIntegral w++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    !WordOff{-offset-}+   | PUSH_LL   !WordOff !WordOff{-2 offsets-}+   | PUSH_LLL  !WordOff !WordOff !WordOff{-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  !ByteOff+   | PUSH16 !ByteOff+   | PUSH32 !ByteOff++   -- 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  !ByteOff+   | PUSH16_W !ByteOff+   | PUSH32_W !ByteOff++   -- Push a (heap) 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) ArgRep+   | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation+                        !NativeCallInfo+                        (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 !WordOff+        -- push this int/float/double/addr, on the stack. Word+        -- 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.++   -- Push a top-level Addr#. This is a pseudo-instruction assembled to PUSH_UBX,+   -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+   | PUSH_ADDR Name++   -- 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++   -- | Drop entries @(n, n+by]@ entries from the stack. Graphically:+   -- @+   -- a_1  ← top+   -- ...+   -- a_n+   -- b_1              =>    a_1  ← top+   -- ...                    ...+   -- b_by                   a_n+   -- k                      k+   -- @+   | SLIDE     !WordOff -- ^ n = this many+               !WordOff -- ^ by = down by this much++   -- To do with the heap+   | ALLOC_AP  !HalfWord {- make an AP with this many payload words.+                            HalfWord matches the size of the n_args field in StgAP,+                            make sure that we handle truncation when generating+                            bytecode using this HalfWord type here -}+   | ALLOC_AP_NOUPD !HalfWord -- make an AP_NOUPD with this many payload words+   | ALLOC_PAP !HalfWord !HalfWord -- make a PAP with this arity / payload words+   | MKAP      !WordOff{-ptr to AP is this far down stack-} !HalfWord{-number of words-}+   | MKPAP     !WordOff{-ptr to PAP is this far down stack-} !HalfWord{-number of words-}+   | UNPACK    !WordOff -- unpack N words from t.o.s Constr+   | PACK      DataCon !WordOff+                        -- 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_I64 !Int64  LocalLabel+   | TESTEQ_I64 !Int64  LocalLabel+   | TESTLT_I32 !Int32  LocalLabel+   | TESTEQ_I32 !Int32  LocalLabel+   | TESTLT_I16 !Int16  LocalLabel+   | TESTEQ_I16 !Int16  LocalLabel+   | TESTLT_I8  !Int8   LocalLabel+   | TESTEQ_I8  !Int16  LocalLabel+   | TESTLT_W64 !Word64 LocalLabel+   | TESTEQ_W64 !Word64 LocalLabel+   | TESTLT_W32 !Word32 LocalLabel+   | TESTEQ_W32 !Word32 LocalLabel+   | TESTLT_W16 !Word16 LocalLabel+   | TESTEQ_W16 !Word16 LocalLabel+   | TESTLT_W8  !Word8  LocalLabel+   | TESTEQ_W8  !Word8  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.++   -- | Test whether the tag of a closure pointer is less than the given value.+   -- If not, jump to the given label.+   | TESTLT_P  !Word16 LocalLabel+   -- | Test whether the tag of a closure pointer is equal to the given value.+   -- If not, jump to the given label.+   | TESTEQ_P  !Word16 LocalLabel++   | CASEFAIL+   | JMP              LocalLabel++   -- For doing calls to C (via glue code generated by libffi)+   | CCALL            !WordOff  -- stack frame size+                      !FFIInfo  -- libffi ffi_cif function prototype+                      !Word16   -- flags.+                                --+                                -- 0x1: call is interruptible+                                -- 0x2: call is unsafe+                                --+                                -- (XXX: inefficient, but I don't know+                                -- what the alignment constraints are.)++   | PRIMCALL++   -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide+   -- instructions. But for generating code it's handy to have the width as argument+   -- to avoid duplication.+   | OP_ADD !Width+   | OP_SUB !Width+   | OP_AND !Width+   | OP_XOR !Width+   | OP_MUL !Width+   | OP_SHL !Width+   | OP_ASR !Width+   | OP_LSR !Width+   | OP_OR  !Width++   | OP_NOT !Width+   | OP_NEG !Width++   | OP_NEQ !Width+   | OP_EQ !Width++   | OP_U_LT !Width+   | OP_U_GE !Width+   | OP_U_GT !Width+   | OP_U_LE !Width++   | OP_S_LT !Width+   | OP_S_GE !Width+   | OP_S_GT !Width+   | OP_S_LE !Width++   -- Always puts at least a machine word on the stack.+   -- We zero extend the result we put on the stack according to host byte order.+   | OP_INDEX_ADDR !Width++   -- For doing magic ByteArray passing to foreign calls+   | SWIZZLE          !WordOff -- to the ptr N words down the stack,+                      !Int     -- add M++   -- To Infinity And Beyond+   | ENTER+   | RETURN ArgRep -- return a non-tuple value, here's its rep; see+                   -- Note [Return convention for non-tuple values] in GHC.StgToByteCode+   | RETURN_TUPLE  -- return an unboxed tuple (info already on stack); see+                   -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode++   -- Breakpoints+   | BRK_FUN          !InternalBreakpointId++#if MIN_VERSION_rts(1,0,3)+   -- | A "meta"-instruction for recording the name of a BCO for debugging purposes.+   -- These are ignored by the interpreter but helpfully printed by the disassmbler.+   | BCO_NAME         !ByteString+#endif+++{- Note [BCO_NAME]+   ~~~~~~~~~~~~~~~+   The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag.+   When enabled the bytecode assembler will prepend a BCO_NAME instruction to every+   generated bytecode object capturing the STG name of the binding the BCO implements.+   This is then printed by the bytecode disassembler, allowing bytecode objects to be+   readily correlated with their STG and Core source.+ -}++-- -----------------------------------------------------------------------------+-- Printing bytecode instructions++instance Outputable a => Outputable (ProtoBCO a) where+   ppr (ProtoBCO { protoBCOName       = name+                 , protoBCOInstrs     = instrs+                 , protoBCOBitmap     = bitmap+                 , protoBCOBitmapSize = bsize+                 , protoBCOArity      = arity+                 , protoBCOExpr       = origin })+      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity+                <> 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 _typ) =+  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 pk)    = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco)+   ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) =+                               hang (text "PUSH_ALTS_TUPLE" <+> ppr call_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_ADDR nm)        = text "PUSH_ADDR" <+> ppr nm+   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_I64  i lab)   = text "TESTLT_I64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I64  i lab)   = text "TESTEQ_I64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I32  i lab)   = text "TESTLT_I32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I32  i lab)   = text "TESTEQ_I32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I16  i lab)   = text "TESTLT_I16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I16  i lab)   = text "TESTEQ_I16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_I8  i lab)    = text "TESTLT_I8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_I8  i lab)    = text "TESTEQ_I8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W64  i lab)   = text "TESTLT_W64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W64  i lab)   = text "TESTEQ_W64" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W32  i lab)   = text "TESTLT_W32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W32  i lab)   = text "TESTEQ_W32" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W16  i lab)   = text "TESTLT_W16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W16  i lab)   = text "TESTEQ_W16" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTLT_W8  i lab)    = text "TESTLT_W8" <+> ppr i <+> text "__" <> ppr lab+   ppr (TESTEQ_W8  i lab)    = text "TESTEQ_W8" <+> ppr 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 ffi flags) = text "CCALL   " <+> ppr off+                                                <+> text "marshal code at"+                                               <+> text (show ffi)+                                               <+> (case flags of+                                                      0x1 -> text "(interruptible)"+                                                      0x2 -> text "(unsafe)"+                                                      _   -> empty)+   ppr PRIMCALL              = text "PRIMCALL"++   ppr (OP_ADD w)            = text "OP_ADD_" <> ppr w+   ppr (OP_SUB w)            = text "OP_SUB_" <> ppr w+   ppr (OP_AND w)            = text "OP_AND_" <> ppr w+   ppr (OP_XOR w)            = text "OP_XOR_" <> ppr w+   ppr (OP_OR w)             = text "OP_OR_" <> ppr w+   ppr (OP_NOT w)            = text "OP_NOT_" <> ppr w+   ppr (OP_NEG w)            = text "OP_NEG_" <> ppr w+   ppr (OP_MUL w)            = text "OP_MUL_" <> ppr w+   ppr (OP_SHL w)            = text "OP_SHL_" <> ppr w+   ppr (OP_ASR w)            = text "OP_ASR_" <> ppr w+   ppr (OP_LSR w)            = text "OP_LSR_" <> ppr w++   ppr (OP_EQ w)             = text "OP_EQ_" <> ppr w+   ppr (OP_NEQ w)            = text "OP_NEQ_" <> ppr w+   ppr (OP_S_LT w)           = text "OP_S_LT_" <> ppr w+   ppr (OP_S_GE w)           = text "OP_S_GE_" <> ppr w+   ppr (OP_S_GT w)           = text "OP_S_GT_" <> ppr w+   ppr (OP_S_LE w)           = text "OP_S_LE_" <> ppr w+   ppr (OP_U_LT w)           = text "OP_U_LT_" <> ppr w+   ppr (OP_U_GE w)           = text "OP_U_GE_" <> ppr w+   ppr (OP_U_GT w)           = text "OP_U_GT_" <> ppr w+   ppr (OP_U_LE w)           = text "OP_U_LE_" <> ppr w++   ppr (OP_INDEX_ADDR w)     = text "OP_INDEX_ADDR_" <> ppr w++   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff+                                               <+> text "by" <+> ppr n+   ppr ENTER                 = text "ENTER"+   ppr (RETURN pk)           = text "RETURN  " <+> ppr pk+   ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"+   ppr (BRK_FUN (InternalBreakpointId info_mod infox))+                             = text "BRK_FUN" <+> text "<breakarray>"+                               <+> ppr info_mod <+> ppr infox+                               <+> text "<cc>"+#if MIN_VERSION_rts(1,0,3)+   ppr (BCO_NAME nm)         = text "BCO_NAME" <+> text (show nm)+#endif++++-- -----------------------------------------------------------------------------+-- 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_TUPLE bco info _) =+   -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)+   -- tuple+   -- (call_info, tuple_bco, stg_ret_t)+   1 {- profiling only -} ++   7 + fromIntegral (nativeCallSize 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_ADDR{}           = 1+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_I64{}          = 0+bciStackUse TESTEQ_I64{}          = 0+bciStackUse TESTLT_I32{}          = 0+bciStackUse TESTEQ_I32{}          = 0+bciStackUse TESTLT_I16{}          = 0+bciStackUse TESTEQ_I16{}          = 0+bciStackUse TESTLT_I8{}           = 0+bciStackUse TESTEQ_I8{}           = 0+bciStackUse TESTLT_W64{}          = 0+bciStackUse TESTEQ_W64{}          = 0+bciStackUse TESTLT_W32{}          = 0+bciStackUse TESTEQ_W32{}          = 0+bciStackUse TESTLT_W16{}          = 0+bciStackUse TESTEQ_W16{}          = 0+bciStackUse TESTLT_W8{}           = 0+bciStackUse TESTEQ_W8{}           = 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{}              = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header+bciStackUse CCALL{}               = 0+bciStackUse PRIMCALL{}            = 1 -- pushes stg_primcall+bciStackUse OP_ADD{}              = 0 -- We overestimate, it's -1 actually ...+bciStackUse OP_SUB{}              = 0+bciStackUse OP_AND{}              = 0+bciStackUse OP_XOR{}              = 0+bciStackUse OP_OR{}               = 0+bciStackUse OP_NOT{}              = 0+bciStackUse OP_NEG{}              = 0+bciStackUse OP_MUL{}              = 0+bciStackUse OP_SHL{}              = 0+bciStackUse OP_ASR{}              = 0+bciStackUse OP_LSR{}              = 0++bciStackUse OP_NEQ{}              = 0+bciStackUse OP_EQ{}               = 0+bciStackUse OP_S_LT{}               = 0+bciStackUse OP_S_GT{}               = 0+bciStackUse OP_S_LE{}               = 0+bciStackUse OP_S_GE{}               = 0+bciStackUse OP_U_LT{}               = 0+bciStackUse OP_U_GT{}               = 0+bciStackUse OP_U_LE{}               = 0+bciStackUse OP_U_GE{}               = 0++bciStackUse OP_INDEX_ADDR{}         = 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+#if MIN_VERSION_rts(1,0,3)+bciStackUse BCO_NAME{}            = 0+#endif
+ GHC/ByteCode/Linker.hs view
@@ -0,0 +1,240 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MagicHash             #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE RecordWildCards       #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | Bytecode assembler and linker+module GHC.ByteCode.Linker+  ( linkBCO+  , lookupStaticPtr+  , lookupIE+  , linkFail+  )+where++import GHC.Prelude++import GHC.Runtime.Interpreter+import GHC.ByteCode.Types+import GHCi.RemoteTypes+import GHCi.ResolvedBCO++import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids++import GHC.Unit.Module.Env+import GHC.Unit.Types++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.SizedSeq++import GHC.Linker.Types++import GHC.Utils.Panic+import GHC.Utils.Outputable++import GHC.Types.Name+import GHC.Types.Name.Env+import qualified GHC.Types.Id as Id+import GHC.Types.Unique.DFM++-- Standard libraries+import Data.Array.Unboxed+import Foreign.Ptr+import GHC.Exts++{-+  Linking interpretables into something we can run+-}++linkBCO+  :: Interp+  -> PkgsLoaded+  -> LinkerEnv+  -> LinkedBreaks+  -> NameEnv Int+  -> UnlinkedBCO+  -> IO ResolvedBCO+linkBCO interp pkgs_loaded le lb bco_ix+           (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 :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)+  ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)+  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits+  return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian+                       , resolvedBCOArity  = arity+                       , resolvedBCOInstrs = insns+                       , resolvedBCOBitmap = bitmap+                       , resolvedBCOLits   = mkBCOByteArray lits'+                       , resolvedBCOPtrs   = addListToSS emptySS ptrs+                       }++lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word+lookupLiteral interp pkgs_loaded le lb 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 pkgs_loaded (itbl_env le) nm+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrAddr nm -> do+    Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrStr bs -> do+    RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs]+    pure $ fromIntegral p+  BCONPtrFS fs -> do+    RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bytesFS fs]+    pure $ fromIntegral p+  BCONPtrFFIInfo (FFIInfo {..}) -> do+    RemotePtr p <- interpCmd interp $ PrepFFI ffiInfoArgs ffiInfoRet+    pure $ fromIntegral p+  BCONPtrCostCentre InternalBreakpointId{..}+    | interpreterProfiled interp -> do+        case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of+          RemotePtr p -> pure $ fromIntegral p+    | otherwise ->+        case toRemotePtr nullPtr of+          RemotePtr p -> pure $ fromIntegral p++lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())+lookupStaticPtr interp addr_of_label_string = do+  m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)+  case m of+    Just ptr -> return ptr+    Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"+                  (ppr addr_of_label_string)++lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp pkgs_loaded 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 = IConInfoSymbol con_nm+       m <- lookupHsSymbol interp pkgs_loaded sym_to_find1+       case m of+          Just addr -> return addr+          Nothing+             -> do -- perhaps a nullary constructor?+                   let sym_to_find2 = IStaticInfoSymbol con_nm+                   n <- lookupHsSymbol interp pkgs_loaded sym_to_find2+                   case n of+                      Just addr -> return addr+                      Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"+                                      (ppr sym_to_find1 <> " or " <>+                                       ppr sym_to_find2)++-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())+lookupAddr interp pkgs_loaded ae addr_nm = do+  case lookupNameEnv ae addr_nm of+    Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)+    Nothing -> do -- try looking up in the object files.+      let sym_to_find = IBytesSymbol addr_nm+                          -- see Note [Bytes label] in GHC.Cmm.CLabel+      m <- lookupHsSymbol interp pkgs_loaded sym_to_find+      case m of+        Just ptr -> return ptr+        Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"+                     (ppr sym_to_find)++lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp pkgs_loaded primop = do+  let sym_to_find = primopToCLabel primop "closure"+  m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))+  case m of+    Just p -> return (toRemotePtr p)+    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)++resolvePtr+  :: Interp+  -> PkgsLoaded+  -> LinkerEnv+  -> LinkedBreaks+  -> NameEnv Int+  -> BCOPtr+  -> IO ResolvedBCOPtr+resolvePtr interp pkgs_loaded le lb bco_ix 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 (closure_env le) nm+    -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))++    | otherwise+    -> assertPpr (isExternalName nm) (ppr nm) $+       do+          let sym_to_find = IClosureSymbol nm+          m <- lookupHsSymbol interp pkgs_loaded sym_to_find+          case m of+            Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)++  BCOPtrPrimOp op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op++  BCOPtrBCO bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco++  BCOPtrBreakArray tick_mod ->+    withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $+      \ba -> pure $ ResolvedBCOPtrBreakArray ba++-- | Look up the address of a Haskell symbol in the currently+-- loaded units.+--+-- See Note [Looking up symbols in the relevant objects].+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))+lookupHsSymbol interp pkgs_loaded sym_to_find = do+  massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)+  let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)+      loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id++      go (dll:dlls) = do+        mb_ptr <- lookupSymbolInDLL interp dll sym_to_find+        case mb_ptr of+          Just ptr -> pure (Just ptr)+          Nothing -> go dlls+      go [] =+        -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types+        lookupSymbol interp sym_to_find++  go loaded_dlls++linkFail :: String -> SDoc -> IO a+linkFail who what+   = throwGhcExceptionIO (ProgramError $+        unlines [ "",who+                , "During interactive linking, GHCi couldn't find the following symbol:"+                , ' ' : ' ' : showSDocUnsafe 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"+                ])+++++++-- See Note [Primop wrappers] in GHC.Builtin.PrimOps+primopToCLabel :: PrimOp -> String -> String+primopToCLabel primop suffix = concat+    [ "ghczminternal_GHCziInternalziPrimopWrappers_"+    , zString (zEncodeFS (occNameFS (primOpOcc primop)))+    , '_':suffix+    ]
+ GHC/ByteCode/Types.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE UnliftedNewtypes           #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | Bytecode assembler types+module GHC.ByteCode.Types+  ( CompiledByteCode(..), seqCompiledByteCode+  , BCOByteArray(..), mkBCOByteArray+  , FFIInfo(..)+  , RegBitmap(..)+  , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo+  , ByteOff(..), WordOff(..), HalfWord(..)+  , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)+  , ItblEnv, ItblPtr(..)+  , AddrEnv, AddrPtr(..)+  , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag++  -- * Mod Breaks+  , ModBreaks (..), BreakpointId(..), BreakTickIndex++  -- * Internal Mod Breaks+  , InternalModBreaks(..), CgBreakInfo(..), seqInternalModBreaks+  -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex+  ) where++import GHC.Prelude++import GHC.Data.FastString+import GHC.Data.FlatBag+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Utils.Outputable+import GHC.Builtin.PrimOps+import GHC.Types.SptEntry+import GHC.HsToCore.Breakpoints+import GHC.ByteCode.Breakpoints+import GHCi.Message+import GHCi.RemoteTypes+import GHCi.FFI+import Control.DeepSeq+import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )++import Foreign+import Data.ByteString (ByteString)+import qualified GHC.Exts.Heap as Heap+import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )+import GHC.Unit.Module++-- -----------------------------------------------------------------------------+-- Compiled Byte Code++data CompiledByteCode = CompiledByteCode+  { bc_bcos   :: FlatBag UnlinkedBCO+    -- ^ Bunch of interpretable bindings++  , bc_itbls  :: [(Name, ConInfoTable)]+    -- ^ Mapping from DataCons to their info tables++  , bc_strs   :: [(Name, ByteString)]+    -- ^ top-level strings (heap allocated)++  , bc_breaks :: Maybe InternalModBreaks+    -- ^ All breakpoint information (no information if breakpoints are disabled).+    --+    -- This information is used when loading a bytecode object: we will+    -- construct the arrays to be used at runtime to trigger breakpoints at load time+    -- from it (in 'allocateBreakArrays' and 'allocateCCS' in 'GHC.ByteCode.Loader').++  , bc_spt_entries :: ![SptEntry]+    -- ^ Static pointer table entries which should be loaded along with the+    -- BCOs. See Note [Grand plan for static forms] in+    -- "GHC.Iface.Tidy.StaticPtrTable".+  }++-- | A libffi ffi_cif function prototype.+data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType }+  deriving (Show)++instance Outputable CompiledByteCode where+  ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos++-- Not a real NFData instance, because ModBreaks contains some things+-- we can't rnf+seqCompiledByteCode :: CompiledByteCode -> ()+seqCompiledByteCode CompiledByteCode{..} =+  rnf bc_bcos `seq`+  rnf bc_itbls `seq`+  rnf bc_strs `seq`+  case bc_breaks of+    Nothing -> ()+    Just ibks -> seqInternalModBreaks ibks++newtype ByteOff = ByteOff Int+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)++newtype WordOff = WordOff Int+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)++-- A type for values that are half the size of a word on the target+-- platform where the interpreter runs (which may be a different+-- wordsize than the compiler).+newtype HalfWord = HalfWord Word+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)++newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 }+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable)++{- Note [GHCi TupleInfo]+~~~~~~~~~~~~~~~~~~~~~~~~+   This contains the data we need for passing unboxed tuples between+   bytecode and native code++   In general we closely follow the native calling convention that+   GHC uses for unboxed tuples, but we don't use any registers in+   bytecode. All tuple elements are expanded to use a full register+   or a full word on the stack.++   The position of tuple elements that are returned on the stack in+   the native calling convention is unchanged when returning the same+   tuple in bytecode.++   The order of the remaining elements is determined by the register in+   which they would have been returned, rather than by their position in+   the tuple in the Haskell source code. This makes jumping between bytecode+   and native code easier: A map of live registers is enough to convert the+   tuple.++   See GHC.StgToByteCode.layoutTuple for more details.+-}++data NativeCallType = NativePrimCall+                    | NativeTupleReturn+  deriving (Eq)++data NativeCallInfo = NativeCallInfo+  { nativeCallType           :: !NativeCallType+  , nativeCallSize           :: !WordOff   -- total size of arguments in words+  , nativeCallRegs           :: !GlobalRegSet+  , nativeCallStackSpillSize :: !WordOff {- words spilled on the stack by+                                            GHCs native calling convention -}+  }++instance Outputable NativeCallInfo where+  ppr NativeCallInfo{..} = text "<arg_size" <+> ppr nativeCallSize <+>+                           text "stack" <+> ppr nativeCallStackSpillSize <+>+                           text "regs"  <+>+                           ppr (map (text @SDoc . show) $ regSetToList nativeCallRegs) <>+                           char '>'+++voidTupleReturnInfo :: NativeCallInfo+voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0++voidPrimCallInfo :: NativeCallInfo+voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0++type ItblEnv = NameEnv (Name, ItblPtr)+type AddrEnv = NameEnv (Name, AddrPtr)+        -- We need the Name in the range so we know which+        -- elements to filter out when unloading a module++newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)+  deriving (Show, NFData)+newtype AddrPtr = AddrPtr (RemotePtr ())+  deriving (NFData)++{-+--------------------------------------------------------------------------------+-- * Byte Code Objects (BCOs)+--------------------------------------------------------------------------------++Note [Case continuation BCOs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A stack with a BCO stack frame at the top looks like:++                                      (an StgBCO)+         |       ...        |      +---> +---------[1]--++         +------------------+      |     | info_tbl_ptr | ------++         |    OTHER FRAME   |      |     +--------------+       |+         +------------------+      |     | StgArrBytes* | <--- the byte code+         |       ...        |      |     +--------------+       |+         +------------------+      |     |     ...      |       |+         |       fvs1       |      |                            |+         +------------------+      |                            |+         |       ...        |      |        (StgInfoTable)      |+         +------------------+      |           +----------+ <---++         |      args1       |      |           |    ...   |+         +------------------+      |           +----------++         |   some StgBCO*   | -----+           | type=BCO |+         +------------------+                  +----------++      Sp | stg_apply_interp | -----+           |   ...    |+         +------------------+      |+                                   |+                                   |   (StgInfoTable)+                                   +----> +--------------++                                          |     ...      |+                                          +--------------++                                          | type=RET_BCO |+                                          +--------------++                                          |     ...      |+++In the case of bytecode objects found on the heap (e.g. thunks and functions),+the bytecode may refer to free variables recorded in the BCO closure itself.+By contrast, in /case continuation/ BCOs the code may additionally refer to free+variables in their stack frame. These are references by way of statically known+stack offsets (tracked using `BCEnv` in `StgToByteCode`).++For instance, consider the function:++    f x y = case y of ... -> g x++Here the RHS of the alternative refers to `x`, which will be recorded in the+continuation stack frame of the `case`.++Even less obvious is that case continuation BCOs may also refer to free+variables in *parent* stack frames. For instance,++    f x y = case y of+      ... -> case g x of+        ... -> x++Here, the RHS of the first alternative still refers to the `x` in the stack+frame of the `case`. Additionally, the RHS of the second alternative also+refers to `x` but it must traverse to its case's *parent* stack frame to find `x`.++However, in /case continuation/ BCOs, the code may additionally refer to free+variables that are outside of that BCO's stack frame -- some free variables of a+case continuation BCO may only be found in the stack frame of a parent BCO.++Yet, references to these out-of-frame variables are also done in terms of stack+offsets. Thus, they rely on the position of /another frame/ to be fixed. (See+Note [PUSH_L underflow] for more information about references to previous+frames and nested BCOs)++This makes case continuation BCOs special: unlike normal BCOs, case cont BCO+frames cannot be moved on the stack independently from their parent BCOs.+-}++data UnlinkedBCO+   = UnlinkedBCO {+        unlinkedBCOName   :: !Name,+        unlinkedBCOArity  :: {-# UNPACK #-} !Int,+        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns+        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap+        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs+        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs+   }++instance NFData UnlinkedBCO where+  rnf UnlinkedBCO{..} =+    rnf unlinkedBCOLits `seq`+    rnf unlinkedBCOPtrs++data BCOPtr+  = BCOPtrName   !Name+  | BCOPtrPrimOp !PrimOp+  | BCOPtrBCO    !UnlinkedBCO+  | BCOPtrBreakArray !Module+    -- ^ Converted to the actual 'BreakArray' remote pointer at link-time++instance NFData BCOPtr where+  rnf (BCOPtrBCO bco) = rnf bco+  rnf x = x `seq` ()++data BCONPtr+  = BCONPtrWord  {-# UNPACK #-} !Word+  | BCONPtrLbl   !FastString+  | BCONPtrItbl  !Name+  -- | A reference to a top-level string literal; see+  -- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.+  | BCONPtrAddr  !Name+  -- | A top-level string literal.+  -- Also see Note [Allocating string literals] in GHC.ByteCode.Asm.+  | BCONPtrStr   !ByteString+  -- | Same as 'BCONPtrStr' but with benefits of 'FastString' interning logic.+  | BCONPtrFS    !FastString+  -- | A libffi ffi_cif function prototype.+  | BCONPtrFFIInfo !FFIInfo+  -- | A 'CostCentre' remote pointer array's respective 'BreakpointId'+  | BCONPtrCostCentre !InternalBreakpointId++instance NFData BCONPtr where+  rnf x = x `seq` ()++instance Outputable UnlinkedBCO where+   ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)+      = sep [text "BCO", ppr nm, text "with",+             ppr (sizeFlatBag lits), text "lits",+             ppr (sizeFlatBag ptrs), text "ptrs" ]+
+ GHC/Cmm.hs view
@@ -0,0 +1,560 @@+-- Cmm representations using Hoopl's Graph CmmNode e x.+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE EmptyCase #-}++module GHC.Cmm (+     -- * Cmm top-level datatypes+     DCmmGroup,+     CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,+     CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..),+     CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph,+     CmmGraph, GenCmmGraph, GenGenCmmGraph(..),+     toBlockMap, revPostorder, toBlockList,+     CmmBlock, RawCmmDecl,+     Section(..), SectionType(..),+     GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),+     SectionProtection(..), sectionProtection,++     DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph,++     -- ** Blocks containing lists+     GenBasicBlock(..), blockId,+     ListGraph(..), pprBBlock,++     -- * Info Tables+     GenCmmTopInfo(..)+     , DCmmTopInfo+     , CmmTopInfo+     , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD,+     ClosureTypeInfo(..),+     ProfilingInfo(..), ConstrDescription,++     -- * Statements, expressions and types+     module GHC.Cmm.Node,+     module GHC.Cmm.Expr,++     -- * Pretty-printing+     pprCmmGroup, pprSection, pprStatic+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Types.Id+import GHC.Types.CostCentre+import GHC.Cmm.CLabel+import GHC.Cmm.BlockId+import GHC.Cmm.Node+import GHC.Runtime.Heap.Layout+import GHC.Cmm.Expr+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Utils.Outputable++import Data.Void (Void)+import Data.List (intersperse)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS++-----------------------------------------------------------------------------+--  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]+-- | Cmm group after STG generation+type DCmmGroup    = GenCmmGroup CmmStatics    DCmmTopInfo              DCmmGraph+-- | Cmm group before SRT generation+type CmmGroup     = GenCmmGroup CmmStatics    CmmTopInfo               CmmGraph+-- | Cmm group with SRTs+type CmmGroupSRTs = GenCmmGroup RawCmmStatics CmmTopInfo               CmmGraph+-- | "Raw" cmm group (TODO (osa): not sure what that means)+type RawCmmGroup  = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) 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+     [GlobalRegUse]    -- 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++  deriving (Functor)++instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+      => OutputableP Platform (GenCmmDecl d info i) where+    pdoc = pprTop++type DCmmDecl    = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph+type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph+type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+type CmmDataDecl = GenCmmDataDecl CmmStatics+type GenCmmDataDecl d = GenCmmDecl d Void Void -- When `CmmProc` case can be statically excluded++cmmDataDeclCmmDecl :: GenCmmDataDecl d -> GenCmmDecl d h g+cmmDataDeclCmmDecl = \ case+    CmmProc void _ _ _ -> case void of+    CmmData section d -> CmmData section d+{-# INLINE cmmDataDeclCmmDecl #-}++type RawCmmDecl+   = GenCmmDecl+        RawCmmStatics+        (LabelMap RawCmmStatics)+        CmmGraph++-----------------------------------------------------------------------------+--     Graphs+-----------------------------------------------------------------------------++type CmmGraph = GenCmmGraph CmmNode+type DCmmGraph = GenGenCmmGraph DWrap CmmNode++type GenCmmGraph n = GenGenCmmGraph LabelMap n++data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C }+type CmmBlock = Block CmmNode C C++instance OutputableP Platform CmmGraph where+    pdoc = pprCmmGraph++toBlockMap :: CmmGraph -> LabelMap CmmBlock+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body++pprCmmGraph :: Platform -> CmmGraph -> SDoc+pprCmmGraph platform g+   = text "{" <> text "offset"+  $$ nest 2 (vcat $ map (pdoc platform) 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.++revPostorder :: CmmGraph -> [CmmBlock]+revPostorder g = {-# SCC "revPostorder" #-}+    revPostorderFrom (toBlockMap g) (g_entry g)++toBlockList :: CmmGraph -> [CmmBlock]+toBlockList g = mapElems $ toBlockMap g++-----------------------------------------------------------------------------+--     Info Tables+-----------------------------------------------------------------------------++-- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains+-- the extra info (beyond the executable code) that belongs to that CmmDecl.+data GenCmmTopInfo f = TopInfo { info_tbls  :: f CmmInfoTable+                               , stack_info :: CmmStackInfo }++newtype DWrap a = DWrap [(BlockId, a)]++unDeterm :: DWrap a -> [(BlockId, a)]+unDeterm (DWrap f) = f++type DCmmTopInfo = GenCmmTopInfo DWrap+type CmmTopInfo  = GenCmmTopInfo LabelMap++instance OutputableP Platform CmmTopInfo where+    pdoc = pprTopInfo++pprTopInfo :: Platform -> CmmTopInfo -> SDoc+pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =+  vcat [text "info_tbls: " <> pdoc platform info_tbl,+        text "stack_info: " <> ppr stack_info]++topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable+topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of+                                          DWrap xs -> lookup (g_entry g) xs+topInfoTableD _                     = Nothing++topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s 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 GHC.StgToCmm.codeGen, and+               -- used by the stack allocator later.+       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.+  }++instance Outputable CmmStackInfo where+    ppr = pprStackInfo++pprStackInfo :: CmmStackInfo -> SDoc+pprStackInfo (StackInfo {arg_space=arg_space}) =+  text "arg_space: " <> ppr arg_space++-- | 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+        -- GHC.Cmm.Info.Build, 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+        -- GHC.Cmm.Info.Build.doSRTs.+    } deriving (Eq, Ord)++instance OutputableP Platform CmmInfoTable where+    pdoc = pprInfoTable++data ProfilingInfo+  = NoProfilingInfo+  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc+  deriving (Eq, Ord)++-----------------------------------------------------------------------------+--              Static Data+-----------------------------------------------------------------------------++data SectionType+  = Text+  | Data+  | ReadOnlyData+  | RelocatableReadOnlyData+  | UninitialisedData+    -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini+  | InitArray           -- .init_array on ELF, .ctor on Windows+  | FiniArray           -- .fini_array on ELF, .dtor on Windows+  | CString+  | OtherSection String+  deriving (Show)++data SectionProtection+  = ReadWriteSection+  | ReadOnlySection+  | WriteProtectedSection -- See Note [Relocatable Read-Only Data]+  deriving (Eq)++-- | Should a data in this section be considered constant at runtime+sectionProtection :: Section -> SectionProtection+sectionProtection (Section t _) = case t of+    Text                    -> ReadOnlySection+    ReadOnlyData            -> ReadOnlySection+    RelocatableReadOnlyData -> WriteProtectedSection+    InitArray               -> ReadOnlySection+    FiniArray               -> ReadOnlySection+    CString                 -> ReadOnlySection+    Data                    -> ReadWriteSection+    UninitialisedData       -> ReadWriteSection+    (OtherSection _)        -> ReadWriteSection++{-+Note [Relocatable Read-Only Data]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Relocatable data are only read-only after relocation at the start of the+program. They should be writable from the source code until then. Failure to+do so would end up in segfaults at execution when using linkers that do not+enforce writability of those sections, such as the gold linker.+-}++data Section = Section SectionType CLabel++data CmmStatic+  = CmmStaticLit CmmLit+        -- ^ a literal value, size given by cmmLitRep of the literal.+  | CmmUninitialised Int+        -- ^ uninitialised data, N bytes long+  | CmmString ByteString+        -- ^ string of 8-bit values only, not zero terminated.+  | CmmFileEmbed FilePath Int+        -- ^ an embedded binary file and its byte length++instance OutputableP Platform CmmStatic where+    pdoc = pprStatic++instance Outputable CmmStatic where+  ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit+  ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n+  ppr (CmmString _) = text "CmmString"+  ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp++-- | Static data before or after SRT generation+data GenCmmStatics (rawOnly :: Bool) where+    CmmStatics+      :: CLabel       -- Label of statics+      -> CmmInfoTable+      -> CostCentreStack+      -> [CmmLit]     -- Payload+      -> [CmmLit]     -- Non-pointers that go to the end of the closure+                      -- This is used by stg_unpack_cstring closures.+                      -- See Note [unpack_cstring closures] in StgStdThunks.cmm.+      -> GenCmmStatics 'False++    -- | Static data, after SRTs are generated+    CmmStaticsRaw+      :: CLabel       -- Label of statics+      -> [CmmStatic]  -- The static data itself+      -> GenCmmStatics a++instance OutputableP Platform (GenCmmStatics a) where+    pdoc = pprStatics++type CmmStatics    = GenCmmStatics 'False+type RawCmmStatics = GenCmmStatics 'True++{-+-----------------------------------------------------------------------------+--              Deterministic Cmm / Info Tables+-----------------------------------------------------------------------------++Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consulting Note [Object determinism] one will learn that in order to produce+deterministic objects just after cmm is produced we perform a renaming pass which+provides fresh uniques for all unique-able things in the input Cmm.++After this point, we use a deterministic unique supply (an incrementing counter)+so any resulting labels which make their way into object code have a deterministic name.++A key assumption to this process is that the input is deterministic modulo the uniques+and the order that bindings appear in the definitions is the same.++CmmGroup uses LabelMap in two places:++* In CmmProc for info tables+* In CmmGraph for the blocks of the graph++LabelMap is not a deterministic structure, so traversing a LabelMap can process+elements in different order (depending on the given uniques).++Therefore before we do the renaming we need to use a deterministic structure, one+which we can traverse in a guaranteed order. A list does the job perfectly.++Once the renaming happens it is converted back into a LabelMap, which is now deterministic+due to the uniques being generated and assigned in a deterministic manner.++We prefer using the renamed LabelMap rather than the list in the rest of the+code generation because it is much more efficient than lists for the needs of+the code generator.+-}++-- Converting out of deterministic Cmm++removeDeterm :: DCmmGroup -> CmmGroup+removeDeterm = map removeDetermDecl++removeDetermDecl :: DCmmDecl -> CmmDecl+removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g)+removeDetermDecl (CmmData a b) = CmmData a b++removeDetermTop :: DCmmTopInfo -> CmmTopInfo+removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b++removeDetermGraph :: DCmmGraph -> CmmGraph+removeDetermGraph (CmmGraph x y) =+  let y' = case y of+            GMany a (DWrap b) c -> GMany a (mapFromList b) c+  in CmmGraph x y'++-- -----------------------------------------------------------------------------+-- 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]+   deriving (Functor)+++-- | 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]+   deriving (Functor)++instance Outputable instr => Outputable (ListGraph instr) where+    ppr (ListGraph blocks) = vcat (map ppr blocks)++instance OutputableP env instr => OutputableP env (ListGraph instr) where+    pdoc env g = ppr (fmap (pdoc env) g)+++instance Outputable instr => Outputable (GenBasicBlock instr) where+    ppr = pprBBlock++instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where+    pdoc env block = ppr (fmap (pdoc env) block)++pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc+pprBBlock (BasicBlock ident stmts) =+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+++-- --------------------------------------------------------------------------+-- Pretty-printing Cmm+-- --------------------------------------------------------------------------+--+-- 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.++pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)+            => Platform -> GenCmmGroup d info g -> SDoc+pprCmmGroup platform tops+    = vcat $ intersperse blankLine $ map (pprTop platform) tops++-- --------------------------------------------------------------------------+-- Top level `procedure' blocks.+--++pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+       => Platform -> GenCmmDecl d info i -> SDoc++pprTop platform (CmmProc info lbl live graph)++  = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live+         , nest 8 $ lbrace <+> pdoc platform info $$ rbrace+         , nest 4 $ pdoc platform graph+         , rbrace ]++-- --------------------------------------------------------------------------+-- We follow [1], 4.5+--+--      section "data" { ... }+--++pprTop platform (CmmData section ds) =+    (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))+    $$ rbrace++-- --------------------------------------------------------------------------+-- Pretty-printing info tables+-- --------------------------------------------------------------------------++pprInfoTable :: Platform -> CmmInfoTable -> SDoc+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+                           , cit_prof = prof_info+                           , cit_srt = srt })+  = vcat [ text "label: " <> pdoc platform lbl+         , text "rep: " <> ppr rep+         , case prof_info of+             NoProfilingInfo -> empty+             ProfilingInfo ct cd ->+               vcat [ text "type: " <> text (show (BS.unpack ct))+                    , text "desc: " <> text (show (BS.unpack cd)) ]+         , text "srt: " <> pdoc platform srt ]++-- --------------------------------------------------------------------------+-- Static data.+--      Strings are printed as C strings, and we print them as I8[],+--      following C--+--++pprStatics :: Platform -> GenCmmStatics a -> SDoc+pprStatics platform (CmmStatics lbl itbl ccs payload extras) =+  pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)++pprStatic :: Platform -> CmmStatic -> SDoc+pprStatic platform s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pdoc platform lit <> semi+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')+    CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path)++-- --------------------------------------------------------------------------+-- data sections+--+pprSection :: Platform -> Section -> SDoc+pprSection platform (Section t suffix) =+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)+  where+    section = text "section"++pprSectionType :: SectionType -> SDoc+pprSectionType s = doubleQuotes $ case s of+  Text                    -> text "text"+  Data                    -> text "data"+  ReadOnlyData            -> text "readonly"+  RelocatableReadOnlyData -> text "relreadonly"+  UninitialisedData       -> text "uninitialised"+  InitArray               -> text "initarray"+  FiniArray               -> text "finiarray"+  CString                 -> text "cstring"+  OtherSection s'         -> text s'
+ GHC/Cmm/BlockId.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- BlockId module should probably go away completely, being superseded by Label -}+module GHC.Cmm.BlockId+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet+  , newBlockId+  , blockLbl, infoTblLbl+  ) where++import GHC.Prelude++import GHC.Cmm.CLabel+import GHC.Data.FastString+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.Unique+import qualified GHC.Types.Unique.DSM as DSM++import GHC.Cmm.Dataflow.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++-- If the monad unique instance uses a deterministic unique supply, this will+-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm+-- onwards (after deterministic renaming in 'codeGen'), there should only exist+-- deterministic block labels.+newBlockId :: DSM.MonadGetUnique m => m BlockId+newBlockId = mkBlockId <$> DSM.getUniqueM++blockLbl :: BlockId -> CLabel+blockLbl label = mkLocalBlockLabel (getUnique label)++infoTblLbl :: BlockId -> CLabel+infoTblLbl label+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs
+ GHC/Cmm/BlockId.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Cmm.BlockId (BlockId, mkBlockId) where++import GHC.Cmm.Dataflow.Label (Label)+import GHC.Types.Unique (Unique)++type BlockId = Label++mkBlockId :: Unique -> BlockId
+ GHC/Cmm/CLabel.hs view
@@ -0,0 +1,1962 @@+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+--+-- Object-file symbols (called CLabel for historical reasons).+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.Cmm.CLabel (+        CLabel, -- abstract type+        NeedExternDecl (..),+        ForeignLabelSource(..),+        DynamicLinkerLabelInfo(..),+        ConInfoTableLocation(..),+        getConInfoTableLocation,++        -- * Constructors+        mkClosureLabel,+        mkSRTLabel,+        mkInfoTableLabel,+        mkEntryLabel,+        mkRednCountsLabel,+        mkTagHitLabel,+        mkConInfoTableLabel,+        mkApEntryLabel,+        mkApInfoTableLabel,+        mkClosureTableLabel,+        mkBytesLabel,++        mkLocalBlockLabel,++        mkBlockInfoTableLabel,++        mkBitmapLabel,+        mkStringLitLabel,++        mkInitializerStubLabel,+        mkInitializerArrayLabel,+        mkFinalizerStubLabel,+        mkFinalizerArrayLabel,++        mkAsmTempLabel,+        mkAsmTempDerivedLabel,+        mkAsmTempEndLabel,+        mkAsmTempProcEndLabel,+        mkAsmTempDieLabel,++        mkDirty_MUT_VAR_Label,+        mkMUT_VAR_CLEAN_infoLabel,+        mkNonmovingWriteBarrierEnabledLabel,+        mkOrigThunkInfoLabel,+        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,+        mkOutOfBoundsAccessLabel,+        mkMemcpyRangeOverlapLabel,+        mkArrWords_infoLabel,+        mkSRTInfoLabel,++        mkTopTickyCtrLabel,+        mkCAFBlackHoleInfoTableLabel,+        mkRtsPrimOpLabel,+        mkRtsSlowFastTickyCtrLabel,+        mkRtsUnpackCStringLabel,+        mkRtsUnpackCStringUtf8Label,++        mkSelectorInfoLabel,+        mkSelectorEntryLabel,+        mkCmmInfoLabel,+        mkCmmEntryLabel,+        mkCmmRetInfoLabel,+        mkCmmRetLabel,+        mkCmmCodeLabel,+        mkCmmDataLabel,+        mkRtsCmmDataLabel,+        mkCmmClosureLabel,+        mkRtsApFastLabel,+        mkPrimCallLabel,+        mkForeignLabel,+        mkCCLabel,+        mkCCSLabel,+        mkIPELabel,+        InfoProvEnt(..),++        mkDynamicLinkerLabel,+        mkPicBaseLabel,+        mkDeadStripPreventer,+        mkHpcTicksLabel,++        -- * Predicates+        hasCAF,+        needsCDecl,+        maybeLocalBlockLabel,+        externallyVisibleCLabel,+        isLibcFun,+        isCFunctionLabel,+        isGcPtrLabel,+        labelDynamic,+        isLocalCLabel,+        mayRedirectTo,+        isInfoTableLabel,+        isCmmInfoTableLabel,+        isConInfoTableLabel,+        isIdLabel,+        isTickyLabel,+        hasHaskellName,+        hasIdLabelInfo,+        isBytesLabel,+        isForeignLabel,+        isSomeRODataLabel,+        isStaticClosureLabel,++        -- * Conversions+        toClosureLbl,+        toSlowEntryLbl,+        toEntryLbl,+        toInfoLbl,+        toProcDelimiterLbl,++        -- * Pretty-printing+        LabelStyle (..),+        pprDebugCLabel,+        pprCLabel,+        pprAsmLabel,+        ppInternalProcLabel,++        -- * Others+        dynamicLinkerLabelInfo,+        CStubLabel (..),+        cStubLabel,+        fromCStubLabel,+        mapInternalNonDetUniques+    ) where++import GHC.Prelude++import GHC.Types.Id.Info+import GHC.Types.Basic+import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)+import GHC.Unit.Types+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Builtin.PrimOps+import GHC.Types.CostCentre+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Platform+import GHC.Types.Unique.Set+import GHC.Core.Ppr ( {- instances -} )+import GHC.Types.SrcLoc++import qualified Data.Semigroup as S++-- -----------------------------------------------------------------------------+-- 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.+        NeedExternDecl          -- ^ does the label need an "extern .." declaration+        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.++        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+  | IPE_Label InfoProvEnt++    -- | A per-module metadata label.+  | ModuleLabel !Module ModuleLabelKind++  -- | These labels are generated and used inside the NCG only.+  --    They are special variants of a label used for dynamic linking+  --    see module "GHC.CmmToAsm.PIC" 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++instance Show CLabel where+  show = showPprUnsafe . pprDebugCLabel genericPlatform++data ModuleLabelKind+    = MLK_Initializer LexicalFastString+    | MLK_InitializerArray+    | MLK_Finalizer LexicalFastString+    | MLK_FinalizerArray+    | MLK_IPEBuffer+    deriving (Eq, Ord)++pprModuleLabelKind :: IsLine doc => ModuleLabelKind -> doc+pprModuleLabelKind MLK_InitializerArray                    = text "init_arr"+pprModuleLabelKind (MLK_Initializer (LexicalFastString s)) = text "init__" <> ftext s+pprModuleLabelKind MLK_FinalizerArray                      = text "fini_arr"+pprModuleLabelKind (MLK_Finalizer (LexicalFastString s))   = text "fini__" <> ftext s+pprModuleLabelKind MLK_IPEBuffer                           = text "ipe_buf"+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> SDoc #-}+{-# SPECIALIZE pprModuleLabelKind :: ModuleLabelKind -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++isIdLabel :: CLabel -> Bool+isIdLabel IdLabel{} = True+isIdLabel _ = False++-- Used in SRT analysis. See Note [Ticky labels in SRT analysis] in+-- GHC.Cmm.Info.Build.+isTickyLabel :: CLabel -> Bool+isTickyLabel (IdLabel _ _ IdTickyInfo{}) = True+isTickyLabel _ = False++-- | Indicate if "GHC.CmmToC" has to generate an extern declaration for the+-- label (e.g. "extern StgWordArray(foo)").  The type is fixed to StgWordArray.+--+-- Symbols from the RTS don't need "extern" declarations because they are+-- exposed via "rts/include/Stg.h" with the appropriate type. See 'needsCDecl'.+--+-- The fixed StgWordArray type led to "conflicting types" issues with user+-- provided Cmm files (not in the RTS) that declare data of another type (#15467+-- and test for #17920).  Hence the Cmm parser considers that labels in data+-- sections don't need the "extern" declaration (just add one explicitly if you+-- need it).+--+-- See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/backends/ppr-c#prototypes+-- for why extern declaration are needed at all.+newtype NeedExternDecl+   = NeedExternDecl Bool+   deriving (Ord,Eq)++-- This is laborious, but necessary. We can't derive Ord because+-- Unique has a special Ord instance that cares for object determinism.+-- Note nonDetCmpUnique and stableNameCmp in the implementation:+--  * If -fobject-determinism, the internal uniques will be renamed, thus the+--  comparison will actually be deterministic+--  * Stable name compare guarantees deterministic ordering of Names despite+--  the non-deterministic uniques underlying external names (which aren't+--  renamed on -fobject-determinism).+-- See Note [Unique Determinism and code generation] and Note [Object determinism]+instance Ord CLabel where+  compare (IdLabel a1 b1 c1)+          (IdLabel a2 b2 c2)+          | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2+          | isExternalName a1 = GT+          | isExternalName a2 = LT++  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =+    -- Comparing names here should deterministic because all unique should have+    -- been renamed deterministically, and external names compared above.+    compare a1 a2 S.<>+    compare b1 b2 S.<>+    compare c1 c2+  compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =+    compare a1 a2 S.<>+    compare b1 b2 S.<>+    -- This is not non-deterministic because the uniques have been deterministically renamed.+    -- See Note [Object determinism]+    uniqCompareFS c1 c2 S.<>+    compare d1 d2+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2+  compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) =+    uniqCompareFS a1 a2 S.<>+    compare b1 b2 S.<>+    compare c1 c2+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =+    compare a1 a2 S.<>+    lexicalCompareFS 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 (IPE_Label a1) (IPE_Label a2) =+    compare a1 a2+  compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) =+    compare m1 m2 S.<>+    compare k1 k2+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =+    compare a1 a2 S.<>+    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+  compare (IPE_Label {}) _ = LT+  compare  _ (IPE_Label{}) = GT+  compare (ModuleLabel {}) _ = LT+  compare  _ (ModuleLabel{}) = 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 currently 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 :: Platform -> CLabel -> SDoc+pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra+   where+      extra = case lbl of+         IdLabel _ _ info+            -> text "IdLabel" <> whenPprDebug (text ":" <> ppr info)++         CmmLabel pkg _ext _name _info+            -> text "CmmLabel" <+> ppr pkg++         RtsLabel{}+            -> text "RtsLabel"++         ForeignLabel _name src funOrData+             -> text "ForeignLabel" <+> ppr src <+> ppr funOrData++         _  -> text "other CLabel"++-- Dynamic ticky info for the id.+data TickyIdInfo+  = TickyRednCounts           -- ^ Used for dynamic allocations+  | TickyInferedTag !Unique    -- ^ Used to track dynamic hits of tag inference.+  deriving (Eq,Show)++instance Outputable TickyIdInfo where+    ppr TickyRednCounts = text "ct_rdn"+    ppr (TickyInferedTag unique) = text "ct_tag[" <> ppr unique <> char ']'++-- | Don't depend on this if you need determinism.+-- No determinism in the ncg backend, so we use the unique for Ord.+-- Even if it pains me slightly.+instance Ord TickyIdInfo where+    compare TickyRednCounts TickyRednCounts = EQ+    compare TickyRednCounts _ = LT+    compare _ TickyRednCounts = GT+    compare (TickyInferedTag unique1) (TickyInferedTag unique2) =+      nonDetCmpUnique unique1 unique2+++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++  | IdTickyInfo !TickyIdInfo -- ^ Label of place to keep Ticky-ticky hit info for this Id++  | ConEntry ConInfoTableLocation+  -- ^ Constructor entry point, when `-fdistinct-info-tables` is enabled then+  -- each usage of a constructor will be given a unique number and a fresh info+  -- table will be created in the module where the constructor is used. The+  -- argument is used to keep track of which info table a usage of a constructor+  -- should use. When the argument is 'Nothing' then it uses the info table which+  -- is defined in the module where the datatype is declared, this is the usual case.+  -- When it is (Just (m, k)) it will use the kth info table defined in module m. The+  -- point of this inefficiency is so that you can work out where allocations of data+  -- constructors are coming from when you are debugging.++  | ConInfoTable ConInfoTableLocation        -- ^ 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-points].++  deriving (Eq, Ord)++-- | Which module is the info table from, and which number was it.+data ConInfoTableLocation = UsageSite Module Int+                          | DefinitionSite+                              deriving (Eq, Ord)++instance Outputable ConInfoTableLocation where+  ppr (UsageSite m n) = text "Loc(" <> ppr n <> text "):" <+> ppr m+  ppr DefinitionSite = empty++getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation+getConInfoTableLocation (ConInfoTable ci) = Just ci+getConInfoTableLocation _ = Nothing++instance Outputable IdLabelInfo where+  ppr Closure    = text "Closure"+  ppr InfoTable  = text "InfoTable"+  ppr Entry      = text "Entry"+  ppr Slow       = text "Slow"++  ppr LocalInfoTable  = text "LocalInfoTable"+  ppr LocalEntry      = text "LocalEntry"++  ppr (ConEntry mn) = text "ConEntry" <+> ppr mn+  ppr (ConInfoTable mn) = text "ConInfoTable" <+> ppr mn+  ppr ClosureTable = text "ClosureTable"+  ppr Bytes        = text "Bytes"+  ppr BlockInfoTable  = text "BlockInfoTable"+  ppr (IdTickyInfo info) = text "IdTickyInfo" <+> ppr info+++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-}++  | RtsUnpackCStringInfoTable+  | RtsUnpackCStringUtf8InfoTable+  | RtsPrimOp            PrimOp+  | RtsApFast            NonDetFastString    -- ^ _fast versions of generic apply+  | RtsSlowFastTickyCtr String++  deriving (Eq,Ord)+++-- | 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++-- See Note [ticky for LNE]+mkRednCountsLabel :: Name -> CLabel+mkRednCountsLabel name = IdLabel name NoCafRefs (IdTickyInfo TickyRednCounts)++mkTagHitLabel :: Name -> Unique -> CLabel+mkTagHitLabel name !uniq = IdLabel name NoCafRefs (IdTickyInfo (TickyInferedTag uniq))++mkClosureLabel              :: Name -> CafInfo -> CLabel+mkInfoTableLabel            :: Name -> CafInfo -> CLabel+mkEntryLabel                :: Name -> CafInfo -> CLabel+mkClosureTableLabel         :: Name -> CafInfo -> CLabel+mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel+mkBytesLabel                :: Name -> CLabel+mkClosureLabel name         c     = IdLabel name c Closure+-- | Decides between external and local labels based on the names externality.+mkInfoTableLabel name       c+  | isExternalName name = IdLabel name c InfoTable+  | otherwise           = IdLabel name c LocalInfoTable+mkEntryLabel name           c     = IdLabel name c Entry+mkClosureTableLabel name    c     = IdLabel name c ClosureTable+-- Special case for the normal 'DefinitionSite' case so that the 'ConInfoTable' application can be floated to a CAF.+mkConInfoTableLabel name DefinitionSite = IdLabel name NoCafRefs (ConInfoTable DefinitionSite)+mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k)+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes++mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable+                               -- See Note [Proc-point local block entry-points].++-- Constructing Cmm Labels+mkDirty_MUT_VAR_Label,+    mkNonmovingWriteBarrierEnabledLabel,+    mkOrigThunkInfoLabel, 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,+    mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,+    mkMUT_VAR_CLEAN_infoLabel :: CLabel+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction+mkNonmovingWriteBarrierEnabledLabel+                                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData+mkOrigThunkInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo+mkUpdInfoLabel                  = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame")         CmmInfo+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" )     CmmInfo+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC")        CmmInfo+mkMainCapabilityLabel           = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "MainCapability")        CmmData+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "top_ct")                CmmData+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_CAF_BLACKHOLE")     CmmInfo+mkArrWords_infoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_ARR_WORDS")         CmmInfo+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo+mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction+mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo++mkSRTInfoLabel :: Int -> CLabel+mkSRTInfoLabel n = CmmLabel rtsUnitId (NeedExternDecl False) 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, mkCmmClosureLabel+        :: UnitId -> FastString -> CLabel++mkCmmDataLabel    :: UnitId -> NeedExternDecl -> FastString -> CLabel+mkRtsCmmDataLabel :: FastString -> CLabel++mkCmmInfoLabel       pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmInfo+mkCmmEntryLabel      pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmEntry+mkCmmRetInfoLabel    pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmRetInfo+mkCmmRetLabel        pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmRet+mkCmmCodeLabel       pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmCode+mkCmmClosureLabel    pkg str     = CmmLabel pkg (NeedExternDecl True) str CmmClosure+mkCmmDataLabel       pkg ext str = CmmLabel pkg ext  str CmmData+mkRtsCmmDataLabel    str         = CmmLabel rtsUnitId (NeedExternDecl False)  str CmmData+                                    -- RTS symbols don't need "GHC.CmmToC" to+                                    -- generate \"extern\" declaration (they are+                                    -- exposed via rts/include/Stg.h)++mkLocalBlockLabel :: Unique -> CLabel+mkLocalBlockLabel u = LocalBlockLabel u++-- Constructing RtsLabels+mkRtsPrimOpLabel :: PrimOp -> CLabel+mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)++mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel+mkSelectorInfoLabel platform upd offset =+   assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $+   RtsLabel (RtsSelectorInfoTable upd offset)++mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel+mkSelectorEntryLabel platform upd offset =+   assert (offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform)) $+   RtsLabel (RtsSelectorEntry upd offset)++mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel+mkApInfoTableLabel platform upd arity =+   assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $+   RtsLabel (RtsApInfoTable upd arity)++mkApEntryLabel :: Platform -> Bool -> Int -> CLabel+mkApEntryLabel platform upd arity =+   assert (arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform)) $+   RtsLabel (RtsApEntry upd arity)++-- A call to some primitive hand written Cmm code+mkPrimCallLabel :: PrimCall -> CLabel+mkPrimCallLabel (PrimCall str pkg)+        = CmmLabel (toUnitId pkg) (NeedExternDecl True) str CmmPrimCall+++-- Constructing ForeignLabels++-- | Make a foreign label+mkForeignLabel+        :: FastString           -- name+        -> ForeignLabelSource   -- what package it's in+        -> FunctionOrData+        -> CLabel++mkForeignLabel = ForeignLabel++-- | 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 (CmmLabel _ _ _ CmmRetInfo) = 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 (CmmLabel _ _ _ CmmInfo)     = True+isInfoTableLabel _                            = False++-- | Whether label points to an info table defined in Cmm+isCmmInfoTableLabel :: CLabel -> Bool+isCmmInfoTableLabel (CmmLabel _ _ _ CmmInfo) = True+isCmmInfoTableLabel _ = False++-- | Whether label is points to constructor info table+isConInfoTableLabel :: CLabel -> Bool+isConInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True+isConInfoTableLabel _                            = False++-- Constructing Large*Labels+mkBitmapLabel   :: Unique -> CLabel+mkBitmapLabel   uniq            = LargeBitmapLabel uniq++-- | Info Table Provenance Entry+-- See Note [Mapping Info Tables to Source Positions]+data InfoProvEnt = InfoProvEnt+                               { infoTablePtr :: !CLabel+                               -- Address of the info table+                               , infoProvEntClosureType :: !Int+                               -- The closure type of the info table (from ClosureMacros.h)+                               , infoTableType :: !String+                               -- The rendered Haskell type of the closure the table represents+                               , infoProvModule :: !Module+                               -- Origin module+                               , infoTableProv :: !(Maybe (RealSrcSpan, LexicalFastString)) }+                               -- Position and information about the info table+                               deriving (Eq, Ord)++instance OutputableP Platform InfoProvEnt where+  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel++-- Constructing Cost Center Labels+mkCCLabel  :: CostCentre      -> CLabel+mkCCSLabel :: CostCentreStack -> CLabel+mkIPELabel :: Module          -> CLabel+mkCCLabel           cc          = CC_Label cc+mkCCSLabel          ccs         = CCS_Label ccs+mkIPELabel          mod         = ModuleLabel mod MLK_IPEBuffer++mkRtsApFastLabel :: FastString -> CLabel+mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))++mkRtsSlowFastTickyCtrLabel :: String -> CLabel+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)++-- | A standard string unpacking thunk. See Note [unpack_cstring closures] in+-- StgStdThunks.cmm.+mkRtsUnpackCStringLabel, mkRtsUnpackCStringUtf8Label :: CLabel+mkRtsUnpackCStringLabel = RtsLabel RtsUnpackCStringInfoTable+mkRtsUnpackCStringUtf8Label = RtsLabel RtsUnpackCStringUtf8InfoTable++-- 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++mkInitializerStubLabel :: Module -> FastString -> CLabel+mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer (LexicalFastString s))++mkInitializerArrayLabel :: Module -> CLabel+mkInitializerArrayLabel mod     = ModuleLabel mod MLK_InitializerArray+++mkFinalizerStubLabel :: Module -> FastString -> CLabel+mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer (LexicalFastString s))++mkFinalizerArrayLabel :: Module -> CLabel+mkFinalizerArrayLabel mod       = ModuleLabel mod MLK_FinalizerArray++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")++-- | A label indicating the end of a procedure.+mkAsmTempProcEndLabel :: CLabel -> CLabel+mkAsmTempProcEndLabel l = mkAsmTempDerivedLabel l (fsLit "_proc_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 :: Platform -> CLabel -> CLabel+toClosureLbl platform lbl = case lbl of+   IdLabel n c _        -> IdLabel n c Closure+   CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure+   _                    -> pprPanic "toClosureLbl" (pprDebugCLabel platform lbl)++toSlowEntryLbl :: Platform -> CLabel -> CLabel+toSlowEntryLbl platform lbl = case lbl of+   IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n)+   IdLabel n c _              -> IdLabel n c Slow+   _                          -> pprPanic "toSlowEntryLbl" (pprDebugCLabel platform lbl)++toEntryLbl :: Platform -> CLabel -> CLabel+toEntryLbl platform lbl = case lbl of+   IdLabel n c LocalInfoTable    -> IdLabel n c LocalEntry+   IdLabel n c (ConInfoTable k)  -> IdLabel n c (ConEntry k)++   IdLabel n _ BlockInfoTable    -> mkLocalBlockLabel (nameUnique n)+                   -- See Note [Proc-point local block entry-points].+   IdLabel n c _                 -> IdLabel n c Entry+   CmmLabel m ext str CmmInfo    -> CmmLabel m ext str CmmEntry+   CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet+   _                             -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl)++-- | Generate a CmmProc delimiter label from the actual entry label.+--+-- This delimiter label might be the entry label itself, except when the entry+-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc,+-- we would generate redundant labels (see #22792)+toProcDelimiterLbl :: CLabel -> CLabel+toProcDelimiterLbl lbl = case lbl of+  LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry")+  _                  -> lbl++toInfoLbl :: Platform -> CLabel -> CLabel+toInfoLbl platform lbl = case lbl of+   IdLabel n c LocalEntry      -> IdLabel n c LocalInfoTable+   IdLabel n c (ConEntry k)    -> IdLabel n c (ConInfoTable k)++   IdLabel n c _               -> IdLabel n c InfoTable+   CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo+   CmmLabel m ext str CmmRet   -> CmmLabel m ext str CmmRetInfo+   _                           -> pprPanic "CLabel.toInfoLbl" (pprDebugCLabel platform lbl)++hasHaskellName :: CLabel -> Maybe Name+hasHaskellName (IdLabel n _ _) = Just n+hasHaskellName _               = Nothing++hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo+hasIdLabelInfo (IdLabel _ _ l) = Just l+hasIdLabelInfo _ = Nothing++-- -----------------------------------------------------------------------------+-- Does a CLabel's referent itself refer to a CAF?+hasCAF :: CLabel -> Bool+hasCAF (IdLabel _ _ (IdTickyInfo TickyRednCounts)) = False -- See Note [ticky for LNE]+hasCAF (IdLabel _ MayHaveCafRefs _) = True+hasCAF (RtsLabel RtsUnpackCStringInfoTable) = True+hasCAF (RtsLabel RtsUnpackCStringUtf8InfoTable) = True+  -- The info table stg_MK_STRING_info is for thunks+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+-- GHC.Cmm.Info.Build.cafTransfers would consider such a ticky label+-- reason to add the name to the CAFEnv (and thus eventually the SRT),+-- but it was harmless because the ticky was only used if the closure+-- was also.+--+-- Since we now have ticky counters for LNEs, it is no longer the case+-- that every ticky counter has an actual closure. So I changed the+-- generation of ticky counters' CLabels to not result in their+-- associated id ending up in the SRT.+--+-- NB IdLabel is still appropriate for ticky ids (as opposed to+-- CmmLabel) because the LNE's counter is still related to an .hs Id,+-- that Id just isn't for a proper closure.++-- -----------------------------------------------------------------------------+-- Does a CLabel need declaring before use or not?+--+-- See wiki:commentary/compiler/backends/ppr-c#prototypes++needsCDecl :: CLabel -> Bool+  -- False <=> it's pre-declared; don't bother+  -- don't bother declaring Bitmap labels, we always make sure+  -- they are defined before use.+needsCDecl (SRTLabel _)                 = True+needsCDecl (LargeBitmapLabel _)         = False+needsCDecl (IdLabel _ _ _)              = True+needsCDecl (LocalBlockLabel _)          = True++needsCDecl (StringLitLabel _)           = False+needsCDecl (AsmTempLabel _)             = False+needsCDecl (AsmTempDerivedLabel _ _)    = False+needsCDecl (RtsLabel _)                 = False++needsCDecl (CmmLabel pkgId (NeedExternDecl external) _ _)+        -- local labels mustn't have it+        | not external                  = False++        -- Prototypes for labels defined in the runtime system are imported+        --      into HC files via rts/include/Stg.h.+        | pkgId == rtsUnitId            = False++        -- For other labels we inline one into the HC file directly.+        | otherwise                     = True++needsCDecl l@(ForeignLabel{})           = not (isLibcFun l)+needsCDecl (CC_Label _)                 = True+needsCDecl (CCS_Label _)                = True+needsCDecl (IPE_Label {})               = True+needsCDecl (ModuleLabel _ kind)         = modLabelNeedsCDecl kind+needsCDecl (HpcTicksLabel _)            = True+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"++modLabelNeedsCDecl :: ModuleLabelKind -> Bool+-- Code for finalizers and initializers are emitted in stub objects+modLabelNeedsCDecl (MLK_Initializer _)  = True+modLabelNeedsCDecl (MLK_Finalizer   _)  = True+modLabelNeedsCDecl MLK_IPEBuffer        = True+-- The finalizer and initializer arrays are emitted in the code of the module+modLabelNeedsCDecl MLK_InitializerArray = False+modLabelNeedsCDecl MLK_FinalizerArray   = False++-- | 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 somewhere, or is built-in+-- to the C compiler. For these labels we avoid generating our+-- own C prototypes.+isLibcFun :: CLabel -> Bool+isLibcFun (ForeignLabel fs _ _)  = fs `elementOfUniqSet` libc_funs+isLibcFun _ = False++libc_funs :: UniqSet FastString+libc_funs = mkUniqSet [+        ---------------------+        -- Math functions+        ---------------------++        -- _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 (IPE_Label {})          = True+externallyVisibleCLabel (ModuleLabel {})        = 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 (RtsSelectorEntry _ _))     = CodeLabel+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel+labelType (RtsLabel (RtsApEntry _ _))           = CodeLabel+labelType (RtsLabel (RtsApFast _))              = CodeLabel+labelType (RtsLabel RtsUnpackCStringInfoTable)  = DataLabel+labelType (RtsLabel RtsUnpackCStringUtf8InfoTable)+                                                = DataLabel+labelType (RtsLabel (RtsPrimOp _))              = CodeLabel+labelType (RtsLabel (RtsSlowFastTickyCtr _))    = 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 (IPE_Label {})                        = DataLabel+labelType (ModuleLabel _ kind)                  = moduleLabelKindType kind+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?+labelType PicBaseLabel                          = DataLabel+labelType (DeadStripPreventer _)                = DataLabel+labelType (HpcTicksLabel _)                     = DataLabel+labelType (LargeBitmapLabel _)                  = DataLabel++moduleLabelKindType :: ModuleLabelKind -> CLabelType+moduleLabelKindType kind =+  case kind of+    MLK_Initializer _    -> CodeLabel+    MLK_InitializerArray -> DataLabel+    MLK_Finalizer _      -> CodeLabel+    MLK_FinalizerArray   -> DataLabel+    MLK_IPEBuffer        -> DataLabel++idInfoLabelType :: IdLabelInfo -> CLabelType+idInfoLabelType info =+  case info of+    InfoTable     -> DataLabel+    LocalInfoTable -> DataLabel+    BlockInfoTable -> DataLabel+    Closure       -> GcPtrLabel+    ConInfoTable {} -> DataLabel+    ClosureTable  -> DataLabel+    IdTickyInfo{} -> 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 :: Module -> Platform -> Bool -> CLabel -> Bool+labelDynamic this_mod platform external_dynamic_refs lbl =+  case lbl of+   -- is the RTS in a DLL or not?+   RtsLabel _ ->+     external_dynamic_refs && (this_unit /= rtsUnitId)++   IdLabel n _ _ ->+     external_dynamic_refs && isDynLinkName platform this_mod n++   -- When compiling in the "dyn" way, each package is to be linked into+   -- its own shared library.+   CmmLabel lbl_unit _ _ _+    | os == OSMinGW32 -> external_dynamic_refs && (this_unit /= lbl_unit)+    | otherwise       -> external_dynamic_refs++   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 ->+                external_dynamic_refs && (this_unit /= 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 ->+     external_dynamic_refs && not (ccFromThisModule cc this_mod)++   -- CCS_Label always contains a CostCentre defined in the current module+   CCS_Label _ -> False+   IPE_Label {} -> True++   HpcTicksLabel m ->+     external_dynamic_refs && this_mod /= m++   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.+   _                 -> False+  where+    os        = platformOS platform+    this_unit = toUnitId (moduleUnit 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_entry:    The entry code for the worker function+    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.++Note [Bangs in CLabel]+~~~~~~~~~~~~~~~~~~~~~~+There are some carefully placed strictness annotations in this module,+which were discovered in !5226 to significantly reduce compile-time+allocation.  Take care if you want to remove them!++-}++-- | Style of label pretty-printing.+--+-- When we produce C sources or headers, we have to take into account+-- that C compilers transform C labels when they convert them into+-- symbols. For example, they can add prefixes (e.g., "_" on Darwin).+-- So we provide two ways to pretty-print CLabels: C style or Asm+-- style.+--+data LabelStyle+   = CStyle   -- ^ C label style (used by C and LLVM backends)+   | AsmStyle -- ^ Asm label style (used by NCG backend)++pprAsmLabel :: IsLine doc => Platform -> CLabel -> doc+pprAsmLabel platform lbl = pprCLabelStyle platform AsmStyle lbl+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> SDoc #-}+{-# SPECIALIZE pprAsmLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++pprCLabel :: IsLine doc => Platform -> CLabel -> doc+pprCLabel platform lbl = pprCLabelStyle platform CStyle lbl+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> SDoc #-}+{-# SPECIALIZE pprCLabel :: Platform -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++instance OutputableP Platform CLabel where+  {-# INLINE pdoc #-} -- see Note [Bangs in CLabel]+  pdoc !platform lbl = getPprStyle $ \pp_sty ->+                        case pp_sty of+                          PprDump{} -> pprCLabel platform lbl+                          _         -> let lbl_doc = (pprCLabel platform lbl)+                                       in pprTraceUserWarning (text "Labels in code should be printed with pprCLabel or pprAsmLabel" <> lbl_doc) lbl_doc++pprCLabelStyle :: forall doc. IsLine doc => Platform -> LabelStyle -> CLabel -> doc+pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]+  let+    !use_leading_underscores = platformLeadingUnderscore platform++    -- some platform (e.g. Darwin) require a leading "_" for exported asm+    -- symbols+    maybe_underscore :: doc -> doc+    maybe_underscore doc = case sty of+      AsmStyle | use_leading_underscores -> pp_cSEP <> doc+      _                                  -> doc++    tempLabelPrefixOrUnderscore :: doc+    tempLabelPrefixOrUnderscore = case sty of+      AsmStyle -> asmTempLabelPrefix platform+      CStyle   -> char '_'+++  in case lbl of+   LocalBlockLabel u -> case sty of+      AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u+      CStyle   -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u++   AsmTempLabel u+      -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u++   AsmTempDerivedLabel l suf+         -- we print a derived label, so we just print the parent label+         -- recursively. However we don't want to print the temp prefix (e.g.+         -- ".L") twice, so we must explicitely handle these cases.+      -> let skipTempPrefix = \case+                AsmTempLabel u            -> pprUniqueAlways u+                AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf+                LocalBlockLabel u         -> pprUniqueAlways u+                lbl                       -> pprAsmLabel platform lbl+         in+         asmTempLabelPrefix platform+         <> skipTempPrefix l+         <> ftext suf++   DynamicLinkerLabel info lbl+      -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl)++   PicBaseLabel+      -> text "1b"++   DeadStripPreventer lbl+      ->+      {-+         `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_" <> pprCLabelStyle platform sty lbl <> text "_dsp"++   StringLitLabel u+      -> maybe_underscore $ pprUniqueAlways u <> text "_str"++   ForeignLabel fs _ _+      -> maybe_underscore $ ftext fs++   IdLabel name _cafs flavor -> case sty of+      AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor+                   where+                      isRandomGenerated = not (isExternalName name)+                      internalNamePrefix =+                         if isRandomGenerated+                            then asmTempLabelPrefix platform+                            else empty+      CStyle   -> pprName name <> ppIdFlavor flavor++   SRTLabel u+      -> maybe_underscore $ tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"++   RtsLabel (RtsApFast (NonDetFastString str))+      -> maybe_underscore $ ftext str <> text "_fast"++   RtsLabel (RtsSelectorInfoTable upd_reqd offset)+      -> maybe_underscore $ hcat [ text "stg_sel_", int offset+                                 , if upd_reqd+                                    then text "_upd_info"+                                    else text "_noupd_info"+                                 ]++   RtsLabel (RtsSelectorEntry upd_reqd offset)+      -> maybe_underscore $ hcat [ text "stg_sel_", int offset+                                 , if upd_reqd+                                    then text "_upd_entry"+                                    else text "_noupd_entry"+                                 ]++   RtsLabel (RtsApInfoTable upd_reqd arity)+      -> maybe_underscore $ hcat [ text "stg_ap_", int arity+                                 , if upd_reqd+                                    then text "_upd_info"+                                    else text "_noupd_info"+                                 ]++   RtsLabel (RtsApEntry upd_reqd arity)+      -> maybe_underscore $ hcat [ text "stg_ap_", int arity+                                 , if upd_reqd+                                    then text "_upd_entry"+                                    else text "_noupd_entry"+                                 ]++   RtsLabel (RtsPrimOp primop)+      -> maybe_underscore $ text "stg_" <> pprPrimOp primop++   RtsLabel (RtsSlowFastTickyCtr pat)+      -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> text "_ctr"++   RtsLabel RtsUnpackCStringInfoTable+      -> maybe_underscore $ text "stg_unpack_cstring_info"+   RtsLabel RtsUnpackCStringUtf8InfoTable+      -> maybe_underscore $ text "stg_unpack_cstring_utf8_info"++   LargeBitmapLabel u+      -> maybe_underscore $ tempLabelPrefixOrUnderscore+                            <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"+                            -- Some bitmaps 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.++   HpcTicksLabel mod+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> pprModule mod <> text "_hpc"++   CC_Label cc   -> maybe_underscore $ pprCostCentre cc+   CCS_Label ccs -> maybe_underscore $ pprCostCentreStack ccs+   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCLabel platform l <> text "_" <> pprModule m <> text "_ipe")+   ModuleLabel mod kind        -> maybe_underscore $ pprModule mod <> text "_" <> pprModuleLabelKind kind++   CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmPrimCall -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmInfo     -> maybe_underscore $ ftext fs <> text "_info"+   CmmLabel _ _ fs CmmEntry    -> maybe_underscore $ ftext fs <> text "_entry"+   CmmLabel _ _ fs CmmRetInfo  -> maybe_underscore $ ftext fs <> text "_info"+   CmmLabel _ _ fs CmmRet      -> maybe_underscore $ ftext fs <> text "_ret"+   CmmLabel _ _ fs CmmClosure  -> maybe_underscore $ ftext fs <> text "_closure"+{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> SDoc #-}+{-# SPECIALIZE pprCLabelStyle :: Platform -> LabelStyle -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++-- Note [Internal proc labels]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Some tools (e.g. the `perf` utility on Linux) rely on the symbol table+-- for resolution of function names. To help these tools we provide the+-- (enabled by default) -fexpose-all-symbols flag which causes GHC to produce+-- symbols even for symbols with are internal to a module (although such+-- symbols will have only local linkage).+--+-- Note that these labels are *not* referred to by code. They are strictly for+-- diagnostics purposes.+--+-- To avoid confusion, it is desirable to add a module-qualifier to the+-- symbol name. However, the Name type's Internal constructor doesn't carry+-- knowledge of the current Module. Consequently, we have to pass this around+-- explicitly.++-- | Generate a label for a procedure internal to a module (if+-- 'Opt_ExposeAllSymbols' is enabled).+-- See Note [Internal proc labels].+ppInternalProcLabel :: IsLine doc+                    => Module     -- ^ the current module+                    -> CLabel+                    -> Maybe doc -- ^ the internal proc label+ppInternalProcLabel this_mod (IdLabel nm _ flavour)+  | isInternalName nm+  = Just+     $ text "_" <> pprModule this_mod+    <> char '_'+    <> ztext (zEncodeFS (occNameFS (occName nm)))+    <> char '_'+    <> pprUniqueAlways (getUnique nm)+    <> ppIdFlavor flavour+ppInternalProcLabel _ _ = Nothing+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc #-}+{-# SPECIALIZE ppInternalProcLabel :: Module -> CLabel -> Maybe HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++ppIdFlavor :: IsLine doc => IdLabelInfo -> doc+ppIdFlavor x = pp_cSEP <> case x of+   Closure          -> text "closure"+   InfoTable        -> text "info"+   LocalInfoTable   -> text "info"+   Entry            -> text "entry"+   LocalEntry       -> text "entry"+   Slow             -> text "slow"+   IdTickyInfo TickyRednCounts+      -> text "ct"+   IdTickyInfo (TickyInferedTag unique)+      -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique+   ConEntry loc      ->+      case loc of+        DefinitionSite -> text "con_entry"+        UsageSite m n ->+          pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry"+   ConInfoTable k   ->+    case k of+      DefinitionSite -> text "con_info"+      UsageSite m n ->+        pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info"+   ClosureTable     -> text "closure_tbl"+   Bytes            -> text "bytes"+   BlockInfoTable   -> text "info"++pp_cSEP :: IsLine doc => doc+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"++-- -----------------------------------------------------------------------------+-- Machine-dependent knowledge about labels.++asmTempLabelPrefix :: IsLine doc => Platform -> doc  -- for formatting labels+asmTempLabelPrefix !platform = case platformOS platform of+    OSDarwin -> text "L"+    OSAIX    -> text "__L" -- follow IBM XL C's convention+    _        -> text ".L"++pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc+pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =+    case platformOS platform of+      OSDarwin+        | platformArch platform == ArchX86_64 ->+          case dllInfo of+            CodeStub        -> char 'L' <> ppLbl <> text "$stub"+            SymbolPtr       -> char 'L' <> ppLbl <> text "$non_lazy_ptr"+            GotSymbolPtr    -> ppLbl <> text "@GOTPCREL"+            GotSymbolOffset -> ppLbl+        | platformArch platform == ArchAArch64 -> ppLbl+        | otherwise -> panic "pprDynamicLinkerAsmLabel"++      OSAIX ->+          case dllInfo of+            SymbolPtr -> text "LC.." <> ppLbl -- GCC's naming convention+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ | osElfTarget (platformOS platform) -> elfLabel++      OSMinGW32 ->+          case dllInfo of+            SymbolPtr -> text "__imp_" <> ppLbl+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ -> panic "pprDynamicLinkerAsmLabel"+  where+    elfLabel+      | platformArch platform == ArchPPC+      = case dllInfo of+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]+                       ppLbl <> text "+32768@plt"+          SymbolPtr -> text ".LC_" <> ppLbl+          _         -> panic "pprDynamicLinkerAsmLabel"++      | platformArch platform == ArchAArch64+      = ppLbl++      | platformArch platform == ArchRISCV64+      = ppLbl++      | platformArch platform == ArchLoongArch64+      = ppLbl++      | platformArch platform == ArchX86_64+      = case dllInfo of+          CodeStub        -> ppLbl <> text "@plt"+          GotSymbolPtr    -> ppLbl <> text "@gotpcrel"+          GotSymbolOffset -> ppLbl+          SymbolPtr       -> text ".LC_" <> ppLbl++      | platformArch platform == ArchPPC_64 ELF_V1+        || platformArch platform == ArchPPC_64 ELF_V2+      = case dllInfo of+          GotSymbolPtr    -> text ".LC_"  <> ppLbl <> text "@toc"+          GotSymbolOffset -> ppLbl+          SymbolPtr       -> text ".LC_" <> ppLbl+          _               -> panic "pprDynamicLinkerAsmLabel"++      | otherwise+      = case dllInfo of+          CodeStub        -> ppLbl <> text "@plt"+          SymbolPtr       -> text ".LC_" <> ppLbl+          GotSymbolPtr    -> ppLbl <> text "@got"+          GotSymbolOffset -> ppLbl <> text "@gotoff"++-- Figure out whether `symbol` may serve as an alias+-- to `target` within one compilation unit.+--+-- This is true if any of these holds:+-- * `target` is a module-internal haskell name.+-- * `target` is an exported name, but comes from the same+--   module as `symbol`+--+-- These are sufficient conditions for establishing e.g. a+-- GNU assembly alias ('.equiv' directive). Sadly, there is+-- no such thing as an alias to an imported symbol (conf.+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)+-- See Note [emit-time elimination of static indirections].+--+-- Precondition is that both labels represent the+-- same semantic value.++mayRedirectTo :: CLabel -> CLabel -> Bool+mayRedirectTo symbol target+ | Just nam <- haskellName+ , staticClosureLabel+ , isExternalName nam+ , Just mod <- nameModule_maybe nam+ , Just anam <- hasHaskellName symbol+ , Just amod <- nameModule_maybe anam+ = amod == mod++ | Just nam <- haskellName+ , staticClosureLabel+ , isInternalName nam+ = True++ | otherwise = False+   where staticClosureLabel = isStaticClosureLabel target+         haskellName = hasHaskellName target+++{-+Note [emit-time elimination of static indirections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in #15155, certain static values are representationally+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).++             newtype A = A Int+             {-# NOINLINE a #-}+             a = A 42++a1_rYB :: Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []]+a1_rYB = GHC.Types.I# 42#++a [InlPrag=NOINLINE] :: A+[GblId, Unf=OtherCon []]+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)++Formerly we created static indirections for these (IND_STATIC), which+consist of a statically allocated forwarding closure that contains+the (possibly tagged) indirectee. (See CMM/assembly below.)+This approach is suboptimal for two reasons:+  (a) they occupy extra space,+  (b) they need to be entered in order to obtain the indirectee,+      thus they cannot be tagged.++Fortunately there is a common case where static indirections can be+eliminated while emitting assembly (native or LLVM), viz. when the+indirectee is in the same module (object file) as the symbol that+points to it. In this case an assembly-level identification can+be created ('.equiv' directive), and as such the same object will+be assigned two names in the symbol table. Any of the identified+symbols can be referenced by a tagged pointer.++Currently the 'mayRedirectTo' predicate will+give a clue whether a label can be equated with another, already+emitted, label (which can in turn be an alias). The general mechanics+is that we identify data (IND_STATIC closures) that are amenable+to aliasing while pretty-printing of assembly output, and emit the+'.equiv' directive instead of static data in such a case.++Here is a sketch how the output is massaged:++                     Consider+newtype A = A Int+{-# NOINLINE a #-}+a = A 42                                -- I# 42# is the indirectee+                                        -- 'a' is exported++                 results in STG++a1_rXq :: GHC.Types.Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =+    CCS_DONT_CARE GHC.Types.I#! [42#];++T15155.a [InlPrag=NOINLINE] :: T15155.A+[GblId, Unf=OtherCon []] =+    CAF_ccs  \ u  []  a1_rXq;++                 and CMM++[section ""data" . a1_rXq_closure" {+     a1_rXq_closure:+         const GHC.Types.I#_con_info;+         const 42;+ }]++[section ""data" . T15155.a_closure" {+     T15155.a_closure:+         const stg_IND_STATIC_info;+         const a1_rXq_closure+1;+         const 0;+         const 0;+ }]++The emitted assembly is++==== INDIRECTEE+a1_rXq_closure:                         -- module local haskell value+        .quad   GHC.Types.I#_con_info   -- an Int+        .quad   42++==== BEFORE+.globl T15155.a_closure                 -- exported newtype wrapped value+T15155.a_closure:+        .quad   stg_IND_STATIC_info     -- the closure info+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)+        .quad   0+        .quad   0++==== AFTER+.globl T15155.a_closure                 -- exported newtype wrapped value+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared++The transformation is performed because+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1+returns True.+-}++-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign+-- declarations for the purpose of serializing to interface files.+--+-- See Note [Foreign stubs and TH bytecode linking]+data CStubLabel =+  CStubLabel {+    csl_is_initializer :: Bool,+    csl_module :: Module,+    csl_name :: FastString+  }++instance Outputable CStubLabel where+  ppr CStubLabel {csl_is_initializer, csl_module, csl_name} =+    text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name)+    where+      ini = if csl_is_initializer then "initializer" else "finalizer"++-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an+-- initializer or finalizer.+cStubLabel :: CLabel -> Maybe CStubLabel+cStubLabel = \case+  ModuleLabel csl_module label_kind -> do+    (csl_is_initializer, csl_name) <- case label_kind of+      MLK_Initializer (LexicalFastString s) -> Just (True, s)+      MLK_Finalizer (LexicalFastString s) -> Just (False, s)+      _ -> Nothing+    Just (CStubLabel {csl_is_initializer, csl_module, csl_name})+  _ -> Nothing++-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'.+fromCStubLabel :: CStubLabel -> CLabel+fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =+  ModuleLabel csl_module (label_kind (LexicalFastString csl_name))+  where+    label_kind =+      if csl_is_initializer+      then MLK_Initializer+      else MLK_Finalizer++-- | A utility for renaming uniques in CLabels to produce deterministic object.+-- Note that not all Uniques are mapped over. Only those that can be safely alpha+-- renamed, e.g. uniques of local symbols, but not of external ones.+-- See Note [Renaming uniques deterministically].+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel+-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel?+mapInternalNonDetUniques f x = case x of+  IdLabel name cafInfo idLabelInfo+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo+    | otherwise -> pure x+  cl@CmmLabel{} -> pure cl+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique+  fl@ForeignLabel{} -> pure fl+  AsmTempLabel unique -> AsmTempLabel <$> f unique+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs+  StringLitLabel unique -> StringLitLabel <$> f unique+  CC_Label  cc -> pure $ CC_Label cc+  CCS_Label ccs -> pure $ CCS_Label ccs+  IPE_Label ipe@InfoProvEnt{infoTablePtr} ->+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr+  ml@ModuleLabel{} -> pure ml+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl+  PicBaseLabel -> pure PicBaseLabel+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod+  SRTLabel unique -> SRTLabel <$> f unique+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique+-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma:+{-# INLINABLE mapInternalNonDetUniques #-}+
+ GHC/Cmm/CLabel.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Cmm.CLabel where++import GHC.Utils.Outputable+import GHC.Platform++data CLabel++pprCLabel :: IsLine doc => Platform -> CLabel -> doc
+ GHC/Cmm/CallConv.hs view
@@ -0,0 +1,324 @@+module GHC.Cmm.CallConv (+  ParamLocation(..),+  assignArgumentsPos,+  assignStack,+  realArgRegsCover,+  allArgRegsCover+) where++import GHC.Prelude++import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..))+import GHC.Runtime.Heap.Layout+import GHC.Cmm (Convention(..))++import GHC.Platform+import GHC.Platform.Reg.Class+import GHC.Platform.Profile+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Maybe ( maybeToList )+import Data.List (nub)++-- 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 regs of+                      AvailRegs vs fs ds ls (s:ss)+                        | passVectorInReg w profile+                          -> let reg_class = case w of+                                    W128 -> XmmReg+                                    W256 -> YmmReg+                                    W512 -> ZmmReg+                                    _    -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width"+                              in k (RegisterParam (reg_class s), AvailRegs vs fs ds ls ss)+                      _ -> (assts, r:rs)+              float = case (w, regs) of+                        (W32, AvailRegs vs fs ds ls (s:ss))+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss)+                        (W32, AvailRegs vs (f:fs) ds ls ss)+                            | not passFloatInXmm      -> k (RegisterParam f, AvailRegs vs fs ds ls ss)+                        (W64, AvailRegs vs fs ds ls (s:ss))+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), AvailRegs vs fs ds ls ss)+                        (W64, AvailRegs vs fs (d:ds) ls ss)+                            | not passFloatInXmm      -> k (RegisterParam d, AvailRegs vs fs ds ls ss)+                        _ -> (assts, (r:rs))+              int = case (w, regs) of+                      (W128, _) -> panic "W128 unsupported register type"+                      (_, AvailRegs (v:vs) fs ds ls ss) | widthInBits w <= widthInBits (wordWidth platform)+                          -> k (RegisterParam v, AvailRegs vs fs ds ls ss)+                      (_, AvailRegs vs fs ds (l:ls) ss) | widthInBits w > widthInBits (wordWidth platform)+                          -> k (RegisterParam l, AvailRegs 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+              passFloatInXmm = passFloatArgsInXmm platform++passFloatArgsInXmm :: Platform -> Bool+passFloatArgsInXmm platform =+  -- TODO: replace the following logic by casing on @registerArch (platformArch platform)@.+  --+  -- This will mean we start saying "True" for AArch64, which the rest of the AArch64+  -- compilation pipeline will need to be able to handle (e.g. the AArch64 NCG).+  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++-- | Keep track of locally available registers.+data AvailRegs+  = AvailRegs+    { availVanillaRegs :: [GlobalReg]+       -- ^ Available vanilla registers+    , availFloatRegs   :: [GlobalReg]+       -- ^ Available float registers+    , availDoubleRegs  :: [GlobalReg]+       -- ^ Available double registers+    , availLongRegs    :: [GlobalReg]+       -- ^ Available long registers+    , availXMMRegs     :: [Int]+       -- ^ Available vector XMM registers+    }++noAvailRegs :: AvailRegs+noAvailRegs = AvailRegs [] [] [] [] []++-- 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 =+  AvailRegs+   { availVanillaRegs = filter (\r -> r /= node) (realVanillaRegs platform)+   , availFloatRegs   = realFloatRegs platform+   , availDoubleRegs  = realDoubleRegs platform+   , availLongRegs    = realLongRegs platform+   , availXMMRegs     = realXmmRegNos platform }++-- getRegsWithNode uses R1/node even if it isn't a register+getRegsWithNode platform =+  AvailRegs+   { availVanillaRegs = if null (realVanillaRegs platform)+                        then [VanillaReg 1]+                        else realVanillaRegs platform+   , availFloatRegs   = realFloatRegs platform+   , availDoubleRegs  = realDoubleRegs platform+   , availLongRegs    = realLongRegs platform+   , availXMMRegs     = realXmmRegNos platform }++allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]+allVanillaRegs :: Platform -> [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 -> [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 || platformArch platform == ArchAArch64+    = regList (pc_MAX_Real_XMM_REG (platformConstants platform))+    | otherwise+    = []++regList :: Int -> [Int]+regList n = [1 .. n]++allRegs :: Platform -> AvailRegs+allRegs platform =+  AvailRegs+   { availVanillaRegs = allVanillaRegs platform+   , availFloatRegs   = allFloatRegs   platform+   , availDoubleRegs  = allDoubleRegs  platform+   , availLongRegs    = allLongRegs    platform+   , availXMMRegs     = allXmmRegs     platform }++nodeOnly :: AvailRegs+nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] }++-- | A set of global registers that cover the machine registers used+-- for argument passing.+--+-- See Note [realArgRegsCover].+realArgRegsCover :: Platform+                 -> GlobalArgRegs+                    -- ^ which kinds of registers do we want to cover?+                 -> [GlobalReg]+realArgRegsCover platform argRegs+  =  realVanillaRegs platform+  ++ realLongRegs    platform+  ++ concat+      (  [ realFloatRegs platform  | wantFP, not (passFloatArgsInXmm platform) ]+           -- TODO: the line above is legacy logic, but removing it breaks+           -- the bytecode interpreter on AArch64. Probably easy to fix.+           -- AK: I believe this might be because we map REG_F1..4 and REG_D1..4 to different+           -- machine registers on AArch64.+      ++ [ realDoubleRegs platform | wantFP ]+      )+  ++ [ mkVecReg i | mkVecReg <- maybeToList mbMkVecReg+                  , i <- realXmmRegNos platform ]++  where+    wantFP = case registerArch (platformArch platform) of+      Unified   -> argRegs == SCALAR_ARG_REGS+      Separate  -> argRegs >= SCALAR_ARG_REGS+      NoVectors -> argRegs >= SCALAR_ARG_REGS+    mbMkVecReg = case registerArch (platformArch platform) of+      Unified   -> mb_xyzmm+      Separate  -> mb_xyzmm+      NoVectors -> Nothing+    mb_xyzmm = case argRegs of+      V16_ARG_REGS -> Just XmmReg+      V32_ARG_REGS -> Just YmmReg+      V64_ARG_REGS -> Just ZmmReg+      _ -> Nothing++-- | Like "realArgRegsCover", but always includes the node.+--+-- See Note [realArgRegsCover].+allArgRegsCover :: Platform+                -> GlobalArgRegs+                    -- ^ which kinds of registers do we want to cover?+                -> [GlobalReg]+allArgRegsCover platform argRegs =+  nub (node : realArgRegsCover platform argRegs)+  where+    node = VanillaReg 1++{- Note [realArgRegsCover]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In low-level Cmm, jumps must be annotated with a set of live registers,+allowing precise control of global STG register contents across function calls.+However, in some places (in particular in the RTS), the registers we want to+preserve depend on the *caller*. For example, if we intercept a function call+via a stack underflow frame, we want to preserve exactly those registers+containing function arguments.+Since we can't know exactly how many arguments the caller passed, we settle on+simply preserving all global regs which might be used for argument passing.+To do this, we specify a collection of registers that *covers* all the registers+we want to preserve; this is done by "realArgRegsCover".++The situation is made somewhat tricky by the need to handle vector registers.+For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way+          ┌─┬─┬───┬───────┬───────────────┐+          │F┆D┆XMM┆  YMM  ┆     ZMM       │+          └─┴─┴───┴───────┴───────────────┘+where each register extends all the way to the left.++Based on this register architecture, on X86_64 we might want to annotate a jump+in which we (might) want to preserve the contents of all argument-passing+registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible+in general, because preserving e.g. a ZMM register across a C call requires the+availability of the AVX-512F instruction set. If we did this, the RTS would+crash at runtime with an "invalid instruction" error on X86_64 machines which+do not support AVX-512F.++Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which+specifies which registers it is sufficient to preserve. For example, it might+suffice to only preserve general-purpose registers, or to only preserve up to+XMM (not YMM or ZMM).++Then, to handle certain functions in the RTS such as "stack_underflow_frame", we+proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which+respectively annotate the jump at the end of the function with SCALAR_ARG_REGS,+V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect,+amounts to compiling "stack_underflow_frame" four times, once for each level of+vector support. Then, in the RTS, we dispatch at runtime based on the support+for vectors provided by the architecture on the current machine (see e.g.+'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.)++Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we+compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM+backend is liable to compile code using e.g. the ZMM1 STG register to uses of+X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would+mean that LLVM produces ABI-incompatible code that would result in segfaults in+the RTS.+-}
+ GHC/Cmm/CommonBlockElim.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE GADTs #-}++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 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 GHC.Utils.Word64 (truncateWord64ToWord32)+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++        -- Since we are hashing, we can savely downcast Word64 to Word32 here.+        -- Although a different hashing function may be more effective.+        hash_unique :: Uniquable a => a -> Word32+        hash_unique = truncateWord64ToWord32 . 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
+ GHC/Cmm/Config.hs view
@@ -0,0 +1,32 @@+-- | 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+  , cmmOptThreadSanitizer  :: !Bool    -- ^ Instrument memory accesses for ThreadSanitizer+  , 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+
+ GHC/Cmm/ContFlowOpt.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE GADTs #-}+module GHC.Cmm.ContFlowOpt+    ( cmmCfgOpts+    , cmmCfgOptsProc+    , removeUnreachableBlocksProc+    , replaceLabels+    )+where++import GHC.Prelude hiding (succ, unzip, zip)++import GHC.Cmm.Dataflow.Block hiding (blockConcat)+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')
+ GHC/Cmm/Dataflow.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# 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 UniqDSM 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.DSM++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.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 @UniqDSM@ 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 -> UniqDSM (CmmBlock, FactBase f)++-- | `RewriteFun` abstracted over `n` (the node type)+type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =+    Block n C C -> FactBase f -> UniqDSM (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+    -> UniqDSM (GenCmmGraph node, FactBase f)+rewriteCmmBwd = rewriteCmm Bwd++rewriteCmm+    :: (NonLocal node)+    => Direction+    -> DataflowLattice f+    -> RewriteFun' node f+    -> GenCmmGraph node+    -> FactBase f+    -> UniqDSM (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+    -> UniqDSM (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.+        -> UniqDSM (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 -> UniqDSM (Block node O O, f))+    -> Block node O O+    -> f+    -> UniqDSM (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
+ GHC/Cmm/Dataflow/Block.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+module GHC.Cmm.Dataflow.Block+    ( Extensibility (..)+    , O+    , C+    , MaybeO(..)+    , IndexedCO+    , Block(..)+    , blockAppend+    , blockConcat+    , blockCons+    , blockFromList+    , blockJoin+    , blockJoinHead+    , blockJoinTail+    , blockSnoc+    , blockSplit+    , blockSplitHead+    , blockSplitTail+    , blockToList+    , emptyBlock+    , firstNode+    , foldBlockNodesB+    , foldBlockNodesB3+    , foldBlockNodesF+    , isEmptyBlock+    , lastNode+    , mapBlock+    , mapBlock'+    , mapBlock3'+    , replaceFirstNode+    , replaceLastNode+    ) where++import GHC.Prelude++-- -----------------------------------------------------------------------------+-- Shapes: Open and Closed++-- | Used at the type level to indicate "open" vs "closed" structure.+data Extensibility+  -- | An "open" structure with a unique, unnamed control-flow edge flowing in+  -- or out. \"Fallthrough\" and concatenation are permitted at an open point.+  = Open+  -- | 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.+  | Closed++type O = 'Open+type C = 'Closed++-- | Either type indexed by closed/open using type families+type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k+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++deriving instance Functor (MaybeO ex)++-- -----------------------------------------------------------------------------+-- 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++blockConcat :: [Block n O O] -> Block n O O+blockConcat = foldr blockAppend emptyBlock++-- 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)+
+ GHC/Cmm/Dataflow/Graph.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+module GHC.Cmm.Dataflow.Graph+    ( Body+    , Graph+    , Graph'(..)+    , NonLocal(..)+    , addBlock+    , bodyList+    , bodyToBlockList+    , emptyBody+    , labelsDefined+    , mapGraph+    , mapGraphBlocks+    , revPostorderFrom+    ) where+++import GHC.Prelude+import GHC.Utils.Misc++import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block++import Data.Kind++-- | A (possibly empty) collection of closed/closed blocks+type Body s n = Body' s Block n++-- | @Body@ abstracted over @block@+type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (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' LabelMap block n+emptyBody = mapEmpty++bodyList :: Body' LabelMap block n -> [(Label,block n C C)]+bodyList body = mapToList body++bodyToBlockList :: Body LabelMap n -> [Block n C C]+bodyToBlockList body = mapElems 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' LabelMap 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' s block (n :: Extensibility -> Extensibility -> Type) e x where+  GNil  :: Graph' s block n O O+  GUnit :: block n O O -> Graph' s block n O O+  GMany :: MaybeO e (block n O C)+        -> Body' s block n+        -> MaybeO x (block n C O)+        -> Graph' s 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 mapMap (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 s block n block' n' e x .+                  (forall a b . (a -> b) -> s a -> s b)+               -> (forall e x . block n e x -> block' n' e x)+               -> (Graph' s block n e x -> Graph' s block' n' e x)++mapGraphBlocks f g = map+  where map :: Graph' s block n e x -> Graph' s block' n' e x+        map GNil = GNil+        map (GUnit b) = GUnit (g b)+        map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x)++-- -----------------------------------------------------------------------------+-- Extracting Labels from graphs++labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap 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 -> Label -> 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
+ GHC/Cmm/Dataflow/Label.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module GHC.Cmm.Dataflow.Label+    ( Label+    , LabelMap+    , LabelSet+    , FactBase+    , lookupFact+    , mkHooplLabel+    -- * Set+    , setEmpty+    , setNull+    , setSize+    , setMember+    , setSingleton+    , setInsert+    , setDelete+    , setUnion+    , setUnions+    , setDifference+    , setIntersection+    , setIsSubsetOf+    , setFilter+    , setFoldl+    , setFoldr+    , setFromList+    , setElems+    -- * Map+    , mapNull+    , mapSize+    , mapMember+    , mapLookup+    , mapFindWithDefault+    , mapEmpty+    , mapSingleton+    , mapInsert+    , mapInsertWith+    , mapDelete+    , mapAlter+    , mapAdjust+    , mapUnion+    , mapUnions+    , mapUnionWithKey+    , mapDifference+    , mapIntersection+    , mapIsSubmapOf+    , mapMap+    , mapMapWithKey+    , mapFoldl+    , mapFoldr+    , mapFoldlWithKey+    , mapFoldMapWithKey+    , mapFilter+    , mapFilterWithKey+    , mapElems+    , mapKeys+    , mapToList+    , mapFromList+    , mapFromListWith+    , mapMapMaybe+    ) where++import GHC.Prelude++import GHC.Utils.Misc+import GHC.Utils.Outputable++import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)++-- The code generator will eventually be using all the labels stored in a+-- LabelSet and LabelMap. For these reasons we use the strict variants of these+-- data structures. We inline selectively to enable the RULES in Word64Map/Set+-- to fire.+import GHC.Data.Word64Set (Word64Set)+import qualified GHC.Data.Word64Set as S+import GHC.Data.Word64Map.Strict (Word64Map)+import qualified GHC.Data.Word64Map.Strict as M+import GHC.Data.TrieMap++import Data.Word (Word64)+++-----------------------------------------------------------------------------+--              Label+-----------------------------------------------------------------------------++newtype Label = Label { lblToUnique :: Word64 }+  deriving newtype (Eq, Ord)++mkHooplLabel :: Word64 -> Label+mkHooplLabel = Label++instance Show Label where+  show (Label n) = "L" ++ show n++instance Uniquable Label where+  getUnique label = mkUniqueGrimily (lblToUnique label)++instance Outputable Label where+  ppr label = ppr (getUnique label)++instance OutputableP env Label where+  pdoc _ l = ppr l++-----------------------------------------------------------------------------+-- LabelSet++newtype LabelSet = LS Word64Set+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup)++setNull :: LabelSet -> Bool+setNull (LS s) = S.null s++setSize :: LabelSet -> Int+setSize (LS s) = S.size s++setMember :: Label -> LabelSet -> Bool+setMember (Label k) (LS s) = S.member k s++setEmpty :: LabelSet+setEmpty = LS S.empty++setSingleton :: Label -> LabelSet+setSingleton (Label k) = LS (S.singleton k)++setInsert :: Label -> LabelSet -> LabelSet+setInsert (Label k) (LS s) = LS (S.insert k s)++setDelete :: Label -> LabelSet -> LabelSet+setDelete (Label k) (LS s) = LS (S.delete k s)++setUnion :: LabelSet -> LabelSet -> LabelSet+setUnion (LS x) (LS y) = LS (S.union x y)++{-# INLINE setUnions #-}+setUnions :: [LabelSet] -> LabelSet+setUnions = foldl1WithDefault' setEmpty setUnion++setDifference :: LabelSet -> LabelSet -> LabelSet+setDifference (LS x) (LS y) = LS (S.difference x y)++setIntersection :: LabelSet -> LabelSet -> LabelSet+setIntersection (LS x) (LS y) = LS (S.intersection x y)++setIsSubsetOf :: LabelSet -> LabelSet -> Bool+setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y++setFilter :: (Label -> Bool) -> LabelSet -> LabelSet+setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s)++{-# INLINE setFoldl #-}+setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t+setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s++{-# INLINE setFoldr #-}+setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t+setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s++{-# INLINE setElems #-}+setElems :: LabelSet -> [Label]+setElems (LS s) = map mkHooplLabel (S.elems s)++{-# INLINE setFromList #-}+setFromList :: [Label] -> LabelSet+setFromList ks  = LS (S.fromList (map lblToUnique ks))++-----------------------------------------------------------------------------+-- LabelMap++newtype LabelMap v = LM (Word64Map v)+  deriving newtype (Eq, Ord, Show, Functor, Foldable)+  deriving stock   Traversable++mapNull :: LabelMap a -> Bool+mapNull (LM m) = M.null m++{-# INLINE mapSize #-}+mapSize :: LabelMap a -> Int+mapSize (LM m) = M.size m++mapMember :: Label -> LabelMap a -> Bool+mapMember (Label k) (LM m) = M.member k m++mapLookup :: Label -> LabelMap a -> Maybe a+mapLookup (Label k) (LM m) = M.lookup k m++mapFindWithDefault :: a -> Label -> LabelMap a -> a+mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m++mapEmpty :: LabelMap v+mapEmpty = LM M.empty++mapSingleton :: Label -> v -> LabelMap v+mapSingleton (Label k) v = LM (M.singleton k v)++mapInsert :: Label -> v -> LabelMap v -> LabelMap v+mapInsert (Label k) v (LM m) = LM (M.insert k v m)++mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v+mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m)++mapDelete :: Label -> LabelMap v -> LabelMap v+mapDelete (Label k) (LM m) = LM (M.delete k m)++mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v+mapAlter f (Label k) (LM m) = LM (M.alter f k m)++mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v+mapAdjust f (Label k) (LM m) = LM (M.adjust f k m)++mapUnion :: LabelMap v -> LabelMap v -> LabelMap v+mapUnion (LM x) (LM y) = LM (M.union x y)++{-# INLINE mapUnions #-}+mapUnions :: [LabelMap a] -> LabelMap a+mapUnions = foldl1WithDefault' mapEmpty mapUnion++mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v+mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y)++mapDifference :: LabelMap v -> LabelMap b -> LabelMap v+mapDifference (LM x) (LM y) = LM (M.difference x y)++mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v+mapIntersection (LM x) (LM y) = LM (M.intersection x y)++mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool+mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y++mapMap :: (a -> v) -> LabelMap a -> LabelMap v+mapMap f (LM m) = LM (M.map f m)++mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v+mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m)++{-# INLINE mapFoldl #-}+mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a+mapFoldl k z (LM m) = M.foldl k z m++{-# INLINE mapFoldr #-}+mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b+mapFoldr k z (LM m) = M.foldr k z m++{-# INLINE mapFoldlWithKey #-}+mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t+mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m++mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m+mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m++{-# INLINEABLE mapFilter #-}+mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v+mapFilter f (LM m) = LM (M.filter f m)++{-# INLINEABLE mapFilterWithKey #-}+mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v+mapFilterWithKey f (LM m)  = LM (M.filterWithKey (f . mkHooplLabel) m)++{-# INLINE mapElems #-}+mapElems :: LabelMap a -> [a]+mapElems (LM m) = M.elems m++{-# INLINE mapKeys #-}+mapKeys :: LabelMap a -> [Label]+mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)++{-# INLINE mapToList #-}+mapToList :: LabelMap b -> [(Label, b)]+mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]++{-# INLINE mapFromList #-}+mapFromList :: [(Label, v)] -> LabelMap v+mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs])++mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v+mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs])++mapMapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b+mapMapMaybe f (LM m) = LM (M.mapMaybe f m)++-----------------------------------------------------------------------------+-- Instances++instance Outputable LabelSet where+  ppr = ppr . setElems++instance Outputable a => Outputable (LabelMap a) where+  ppr = ppr . mapToList++instance OutputableP env a => OutputableP env (LabelMap a) where+  pdoc env = pdoc env . 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+  filterTM f    = mapFilter f+  mapMaybeTM f  = mapMapMaybe f++-----------------------------------------------------------------------------+-- FactBase++type FactBase f = LabelMap f++lookupFact :: Label -> FactBase f -> Maybe f+lookupFact = mapLookup
+ GHC/Cmm/DebugBlock.hs view
@@ -0,0 +1,583 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE EmptyCase #-}++-----------------------------------------------------------------------------+--+-- 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, pprGlobalRegUse )+import GHC.Cmm.Utils+import GHC.Data.FastString ( LexicalFastString, 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.Graph+import GHC.Cmm.Dataflow.Label++import Data.Maybe+import Data.List     ( nubBy )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Ord      ( comparing )+import qualified Data.Map as Map+import Data.Foldable ( toList )+import Data.Either ( partitionEithers )+import Data.Void++-- | 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, RawCmmDeclNoStatics)++-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM+-- code). (The first argument is `Void` rather than `RawCmmStatics`.+type RawCmmDeclNoStatics+   = GenCmmDecl+        Void+        (LabelMap RawCmmStatics)+        CmmGraph++-- | 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 -> [RawCmmDecl] -> [DebugBlock]+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes+  where+      blockCtxs :: Map.Map CmmTickScope (NonEmpty 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 (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs++      findP tsc GlobalScope = Left tsc -- top scope+      findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x)+                    | 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'++      scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') 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 $ maybe [] toList $ 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 (span, _)+        | srcSpanFile span == thisFile = 1+        | otherwise                    = 2 :: Int+      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 (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock+      blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx+        where nested = fromMaybe [] $ Map.lookup scope scopeMap+              childs = map (mkBlock False) bctxs +++                       map (blocksForScope stick) nested++              mkBlock :: Bool -> BlockContext -> DebugBlock+              mkBlock top (block, prc)+                = DebugBlock { dblProcedure    = g_entry graph+                             , dblLabel        = label+                             , dblCLabel       = blockLbl label+                             , dblHasInfoTbl   = isJust info+                             , dblParent       = Nothing+                             , dblTicks        = ticks+                             , dblPosition     = Nothing -- see cmmDebugLink+                             , dblSourceTick   = uncurry SourceNote <$> stick+                             , dblBlocks       = blocks+                             , dblUnwind       = []+                             }+                where (infos, graph) = case prc of+                          CmmProc infos _ _ graph -> (infos, graph)+                          CmmData _ v -> case v of+                      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 span a) = Just (span, a)+              isSourceTick _ = Nothing+              -- 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 nonEmpty $ mapMaybe isSourceTick ticks of+                Nothing -> cstick+                Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` 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 :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext)+blockContexts = Map.map NE.reverse . foldr walkProc Map.empty+  where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)+                 -> Map.Map CmmTickScope (NonEmpty 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 :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C]+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))+        walkBlock _   []             c            = c+        walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of+            (CmmProc x y z graph, False) ->+                let succs = flip mapFind (toBlockMap graph) <$>+                        successors (lastNode block) in+                walkBlock prc blocks $+                walkBlock prc succs+                  ( lbl `setInsert` visited+                  , insertMultiNE scope (block, CmmProc x y z graph) m )+            _ -> walkBlock prc blocks (visited, m)+          where CmmEntry lbl scope = firstNode 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]++insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a)+insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v)++cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]+cmmDebugLabels is_valid_label 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 = filter is_valid_label $ 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 = mapMaybe link blocks+  where blockPos :: LabelMap Int+        blockPos = mapFromList $ flip zip [0..] labels+        link block = case mapLookup (dblLabel block) blockPos of+          -- filter dead blocks: we generated debug infos from Cmm blocks but+          -- asm-shortcutting may remove some blocks later (#22792)+          Nothing  -> Nothing+          pos      -> Just $ block+                         { dblPosition = pos+                         , dblBlocks   = mapMaybe 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 !GlobalRegUse !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     -> pprGlobalRegUse 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)
+ GHC/Cmm/Dominators.hs view
@@ -0,0 +1,217 @@+{-# 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 qualified Data.Tree as Tree++import Data.Word++import qualified GHC.CmmToAsm.CFG.Dominators as LT++import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+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+import GHC.Utils.Word64 (intToWord64)+import qualified GHC.Data.Word64Map as WM+import qualified GHC.Data.Word64Set as WS+++-- | =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.++-- Technically, we do not need Word64 here, however the dominators code+-- has to accomodate Word64 for other uses.++graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap+      where rpblocks = revPostorderFrom (graphMap g) (g_entry g)+            rplabels' = map entryLabel rpblocks+            rplabels :: Array Word64 Label+            rplabels = listArray bounds rplabels'++            rpmap :: LabelMap RPNum+            rpmap = mapFromList $ zipWith kvpair rpblocks [0..]+              where kvpair block i = (entryLabel block, RPNum i)++            labelIndex :: Label -> Word64+            labelIndex = flip findLabelIn imap+              where imap :: LabelMap Word64+                    imap = mapFromList $ zip rplabels' [0..]+            blockIndex = labelIndex . entryLabel++            bounds :: (Word64, Word64)+            bounds = (0, intToWord64 (length rpblocks - 1))++            ltGraph :: [Block node C C] -> LT.Graph+            ltGraph [] = WM.empty+            ltGraph (block:blocks) =+                WM.insert+                      (blockIndex block)+                      (WS.fromList $ map labelIndex $ successors block)+                      (ltGraph blocks)++            idom_array :: Array Word64 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
+ GHC/Cmm/Expr.hs view
@@ -0,0 +1,581 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.Cmm.Expr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr+    , CmmReg(..), cmmRegType, cmmRegWidth+    , CmmLit(..), cmmLitType+    , AlignmentSpec(..)+      -- TODO: Remove:+    , LocalReg(..), localRegType+    , GlobalReg(..), isArgReg, globalRegSpillType+    , GlobalRegUse(..)+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+    , node, baseReg++    , DefinerOfRegs, UserOfRegs+    , foldRegsDefd, foldRegsUsed+    , foldLocalRegsDefd, foldLocalRegsUsed++    , RegSet, LocalRegSet, GlobalRegSet+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet+    , regSetToList++    , isTrivialCmmExpr+    , hasNoGlobalRegs+    , isLit+    , isComparisonExpr++    , Area(..)+    , module GHC.Cmm.MachOp+    , module GHC.Cmm.Type+    )+where++import GHC.Prelude++import GHC.Platform+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.MachOp+import GHC.Cmm.Type+import GHC.Cmm.Reg+import GHC.Utils.Panic (panic)+import GHC.Utils.Outputable++import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import Numeric ( fromRat )++import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)++-----------------------------------------------------------------------------+--              CmmExpr+-- An expression.  Expressions have no side effects.+-----------------------------------------------------------------------------++data CmmExpr+  = CmmLit !CmmLit              -- Literal+  | CmmLoad !CmmExpr !CmmType !AlignmentSpec+                                -- 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)+  deriving Show++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++instance OutputableP Platform CmmExpr where+    pdoc = pprExpr++data AlignmentSpec = NaturallyAligned | Unaligned+  deriving (Eq, Ord, Show)++-- | 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 BlockIds] in GHC.Cmm.Node.+  deriving (Eq, Ord, Show)++instance Outputable Area where+    ppr e = pprArea e++pprArea :: Area -> SDoc+pprArea Old        = text "old"+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]+++{- 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 BlockIds] in GHC.Cmm.Node.++  | 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, Show)++instance OutputableP Platform CmmLit where+    pdoc = pprLit++instance Outputable CmmLit where+  ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w+  ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w+  ppr (CmmVec xs) = text "CmmVec" <+> ppr xs+  ppr (CmmLabel _) = text "CmmLabel"+  ppr (CmmLabelOff _ _) = text "CmmLabelOff"+  ppr (CmmLabelDiffOff _ _ _ _) = text "CmmLabelDiffOff"+  ppr (CmmBlock blk) = text "CmmBlock" <+> ppr blk+  ppr CmmHighStackMark = text "CmmHighStackMark"++cmmExprType :: Platform -> CmmExpr -> CmmType+cmmExprType platform = \case+   (CmmLit lit)        -> cmmLitType platform lit+   (CmmLoad _ rep _)   -> rep+   (CmmReg reg)        -> cmmRegType reg+   (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)+   (CmmRegOff reg _)   -> cmmRegType reg+   (CmmStackSlot _ _)  -> bWord platform -- an address+   -- Careful though: what is stored at the stack slot may be bigger than+   -- an address++cmmLitType :: Platform -> CmmLit -> CmmType+cmmLitType platform = \case+   (CmmInt _ width)     -> cmmBits  width+   (CmmFloat _ width)   -> cmmFloat width+   (CmmVec [])          -> panic "cmmLitType: CmmVec []"+   (CmmVec (l:ls))      -> let ty = cmmLitType platform l+                          in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)+                               then cmmVec (1+length ls) ty+                               else panic "cmmLitType: CmmVec"+   (CmmLabel lbl)       -> cmmLabelType platform lbl+   (CmmLabelOff lbl _)  -> cmmLabelType platform lbl+   (CmmLabelDiffOff _ _ _ width) -> cmmBits width+   (CmmBlock _)         -> bWord platform+   (CmmHighStackMark)   -> bWord platform++cmmLabelType :: Platform -> CLabel -> CmmType+cmmLabelType platform lbl+ | isGcPtrLabel lbl = gcWord platform+ | otherwise        = bWord platform++cmmExprWidth :: Platform -> CmmExpr -> Width+cmmExprWidth platform e = typeWidth (cmmExprType platform e)++-- | Returns an alignment in bytes of a CmmExpr when it's a statically+-- known integer constant, otherwise returns an alignment of 1 byte.+-- The caller is responsible for using with a sensible CmmExpr+-- argument.+cmmExprAlignment :: CmmExpr -> Alignment+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)+cmmExprAlignment _                          = mkAlignment 1+--------+--- Negation for conditional branches++maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op+                                            return (CmmMachOp op' args)+maybeInvertCmmExpr _ = Nothing++---------------------------------------------------+--         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+++-----------------------------------------------------------------------------+--    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 :: Platform -> (b -> r -> b) -> b -> a -> b++foldLocalRegsUsed :: UserOfRegs LocalReg a+                  => Platform -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsUsed = foldRegsUsed++class Ord r => DefinerOfRegs r a where+  foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b++foldLocalRegsDefd :: DefinerOfRegs LocalReg a+                  => Platform -> (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+    {-# INLINEABLE foldRegsUsed #-}+    foldRegsUsed _ _ z (CmmLocal _)    = z+    foldRegsUsed _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg++instance UserOfRegs GlobalRegUse CmmReg where+    {-# INLINEABLE foldRegsUsed #-}+    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 (GlobalRegUse reg _)) = f z reg++instance DefinerOfRegs GlobalRegUse 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 GHC.Tc.TyCl.Instance+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform f !z e = expr z e+    where expr z (CmmLit _)          = z+          expr z (CmmLoad addr _ _)  = foldRegsUsed platform f z addr+          expr z (CmmReg r)          = foldRegsUsed platform f z r+          expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs+          expr z (CmmRegOff r _)     = foldRegsUsed platform f z r+          expr z (CmmStackSlot _ _)  = z++instance UserOfRegs r a => UserOfRegs r [a] where+  foldRegsUsed platform f set as = foldl' (foldRegsUsed platform f) set as+  {-# INLINABLE foldRegsUsed #-}++instance DefinerOfRegs r a => DefinerOfRegs r [a] where+  foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as+  {-# INLINABLE foldRegsDefd #-}++-- --------------------------------------------------------------------------+-- Pretty-printing expressions+-- --------------------------------------------------------------------------++pprExpr :: Platform -> CmmExpr -> SDoc+pprExpr platform e+    = case e of+        CmmRegOff reg i ->+                pprExpr platform (CmmMachOp (MO_Add rep)+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])+                where rep = typeWidth (cmmRegType reg)+        CmmLit lit -> pprLit platform lit+        _other     -> pprExpr1 platform e++-- Here's the precedence table from GHC.Cmm.Parser:+-- %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 :: Platform -> CmmExpr -> SDoc+pprExpr1 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp1 op+   = pprExpr7 platform x <+> doc <+> pprExpr7 platform y+pprExpr1 platform e = pprExpr7 platform 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 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0+   = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])+pprExpr7 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp7 op+   = pprExpr7 platform x <+> doc <+> pprExpr8 platform y+pprExpr7 platform e = pprExpr8 platform e++infixMachOp7 (MO_Add _)  = Just (char '+')+infixMachOp7 (MO_Sub _)  = Just (char '-')+infixMachOp7 _           = Nothing++-- %left '/' '*' '%'+pprExpr8 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp8 op+   = pprExpr8 platform x <+> doc <+> pprExpr9 platform y+pprExpr8 platform e = pprExpr9 platform e++infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _)    = Just (char '*')+infixMachOp8 (MO_U_Rem _)  = Just (char '%')+infixMachOp8 _             = Nothing++pprExpr9 :: Platform -> CmmExpr -> SDoc+pprExpr9 platform e =+   case e of+        CmmLit    lit       -> pprLit1 platform lit+        CmmLoad   expr rep align+                            -> let align_mark =+                                       case align of+                                         NaturallyAligned -> empty+                                         Unaligned        -> text "^"+                                in ppr rep <> align_mark <> brackets (pdoc platform 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 platform mop args++genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc+genMachOp platform (MO_RelaxedRead w) [x] =+    ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x)+genMachOp platform mop args+   | Just doc <- infixMachOp mop = case args of+        -- dyadic+        [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y++        -- unary+        [x]   -> doc <> pprExpr9 platform x++        _     -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args"+                          (pprMachOp mop <+>+                            parens (hcat $ punctuate comma (map (pprExpr platform) args)))+                          empty++   | isJust (infixMachOp1 mop)+   || isJust (infixMachOp7 mop)+   || isJust (infixMachOp8 mop)  = parens (pprExpr platform (CmmMachOp mop args))++   | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) 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++-- --------------------------------------------------------------------------+-- Pretty-printing 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 :: Platform -> CmmLit -> SDoc+pprLit platform lit = case lit of+    CmmInt i rep ->+        hcat [ (if i < 0 then parens else id)(integer i)+             , ppUnless (rep == wordWidth platform) $+               space <> dcolon <+> ppr rep ]++    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]+    CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'+    CmmLabel clbl      -> pdoc platform clbl+    CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i+    CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'+                                       <> pdoc platform clbl2 <> ppr_offset i+    CmmBlock id        -> ppr id+    CmmHighStackMark -> text "<highSp>"++pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)+pprLit1 platform lit                  = pprLit platform lit++ppr_offset :: Int -> SDoc+ppr_offset i+    | i==0      = empty+    | i>=0      = char '+' <> int i+    | otherwise = char '-' <> int (-i)++commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
+ GHC/Cmm/GenericOpt.hs view
@@ -0,0 +1,212 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+--+-- -----------------------------------------------------------------------------++{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++module GHC.Cmm.GenericOpt+   ( cmmToCmm+   )+where++import GHC.Prelude hiding (head)+import GHC.Platform+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Opt           ( cmmMachOpFold )+import GHC.Cmm.CLabel+import GHC.Data.FastString+import GHC.Unit+import Control.Monad.Trans.Reader+import GHC.Utils.Monad.State.Strict as Strict++-- -----------------------------------------------------------------------------+-- 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, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))++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 (GlobalRegUse EagerBlackholeInfo _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))+        CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))+        CmmReg (CmmGlobal (GlobalRegUse GCFun _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))++        other+           -> return other
+ GHC/Cmm/Graph.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE 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.DSM+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.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 -> DCmmGraph+flattenCmmAGraph id (stmts_t, tscope) =+    CmmGraph { g_entry = id,+               g_graph = GMany NothingO body NothingO }+  where+  body = DWrap [(entryLabel b, b) | b <- 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 -> UniqDSM DCmmGraph+lgraphOfAGraph g = do+  u <- getUniqueDSM+  return (labelAGraph (mkBlockId u) g)++-- | use the given BlockId as the label of the entry point+labelAGraph    :: BlockId -> CmmAGraphScoped -> DCmmGraph+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 -> [GlobalRegUse]+                -> 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, [GlobalRegUse], 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, [GlobalRegUse], [CmmNode O O])+copyIn profile conv area formals extra_stk+  = (stk_size, [GlobalRegUse r (localRegType lr)| (lr, RegisterParam r) <- args], map ci (stk_args ++ args))+  where+    platform = profilePlatform profile++    ci :: (LocalReg, ParamLocation) -> CmmNode O O+    ci (reg, RegisterParam r@(VanillaReg {})) =+        let local = CmmLocal reg+            width = cmmRegWidth local+            (expr, ty)+              -- See Note [Width of parameters]+                | width == wordWidth platform+                = (global, localRegType reg)+                | width < wordWidth platform+                = (CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]+                  ,setCmmTypeWidth (wordWidth platform) (localRegType reg))+                | otherwise+                = panic "Parameter width greater than word width"+            global = CmmReg (CmmGlobal $ GlobalRegUse r ty)++        in CmmAssign local expr++    -- Non VanillaRegs+    ci (reg, RegisterParam r) =+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal $ GlobalRegUse r (localRegType reg)))++    ci (reg, StackParam off)+      | isBitsType $ localRegType reg+      -- See Note [Width of parameters]+      , typeWidth (localRegType reg) < wordWidth platform =+        let+          stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned+          local = CmmLocal reg+          width = cmmRegWidth 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, [GlobalRegUse], 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)++    co :: (CmmExpr, ParamLocation)+       -> ([GlobalRegUse], CmmAGraph)+       -> ([GlobalRegUse], CmmAGraph)+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =+        let width = cmmExprWidth platform v+            value+              -- See Note [Width of parameters]+                | width == wordWidth platform = v+                | width < wordWidth platform =+                    CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]+                | otherwise = panic "Parameter width greater than word width"+            ru = GlobalRegUse r (cmmExprType platform value)++        in (ru:rs, mkAssign (CmmGlobal ru) value <*> ms)++    -- Non VanillaRegs+    co (v, RegisterParam r) (rs, ms) =+      let ru = GlobalRegUse r (cmmExprType platform v)+      in (ru:rs, mkAssign (CmmGlobal ru) v <*> ms)++    co (v, StackParam off)  (rs, ms)+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)++    -- See Note [Width of parameters]+    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:+-- * 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).+--   This is because the generated Cmm application functions (such as stg_ap_n)+--   always load the full width from the stack.+-- 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, [GlobalRegUse], CmmAGraph)+mkCallEntry profile conv formals extra_stk+  = copyInOflow profile conv Old formals extra_stk++lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset+             -> (ByteOff -> [GlobalRegUse] -> 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 -> [GlobalRegUse] -> 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 -> [GlobalRegUse]+       -> CmmAGraph+toCall e cont updfr_off res_space arg_space regs =+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+ GHC/Cmm/Info.hs view
@@ -0,0 +1,599 @@++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.StgToCmm.CgUtils (CgStream)+import GHC.Runtime.Heap.Layout+import GHC.Data.Bitmap+import qualified GHC.Data.Stream as Stream+import GHC.Cmm.Dataflow.Label++import GHC.Platform+import GHC.Platform.Profile+import GHC.Data.Maybe+import GHC.Utils.Error (withTimingSilent)+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Utils.Monad+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Unique.DSM++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 -> CgStream CmmGroupSRTs a+            -> IO (CgStream RawCmmGroup a)+cmmToRawCmm logger profile cmms+  = do { let do_one :: [CmmDeclSRTs] -> UniqDSMT IO [RawCmmDecl]+             do_one cmm = setTagUDSMT 'i' $ do+               -- NB. strictness fixes a space leak.  DO NOT REMOVE.+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) $ do+                 liftUniqDSM $+                   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 -> UniqDSM [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?+                    -> UniqDSM ([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]+              -> UniqDSM ( 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 -> UniqDSM (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 <- getUniqueDSM+       ; 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 -> UniqDSM ((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 -> UniqDSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)+newStringLit bytes+  = do { uniq <- getUniqueDSM+       ; 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 =+    CmmMachOp (MO_RelaxedRead (wordWidth 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
+ GHC/Cmm/Info/Build.hs view
@@ -0,0 +1,1333 @@+{-# LANGUAGE GADTs, RecordWildCards,+    NondecreasingIndentation,+    OverloadedStrings, LambdaCase #-}+{-# LANGUAGE DerivingStrategies #-}+{-# 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+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.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+import GHC.Types.Unique.DSM++{- 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+  -> DUniqSupply+  -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks+  -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's+  -> IO (ModuleSRTInfo, DUniqSupply, [CmmDeclSRTs])++doSRTs cfg moduleSRTInfo dus0 procs data_ = do++  let origtag = getTagDUniqSupply dus0+      profile = cmmProfile cfg+      dus1    = newTagDUniqSupply 'u' dus0++  -- Ignore the original grouping of decls, and combine all the+  -- CAFEnvs into a single CAFEnv.+      static_data_env :: DataCAFEnv+      static_data_env =+        Map.fromList $+        flip map data_ $+        \(set, decl) ->+          case decl of+            CmmProc void _ _ _ -> case void of+            CmmData _ static ->+              case static of+                CmmStatics lbl _ _ _ _ -> (lbl, set)+                CmmStaticsRaw lbl _ -> (lbl, set)++      (proc_envs, procss) = unzip procs+      cafEnv = mapUnions proc_envs+      decls = map (cmmDataDeclCmmDecl . 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'), dus2) =+        runUniqueDSM dus1 $+        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 void _ _ _ -> case void of)+               (moduleSRTMap moduleSRTInfo') data_+      dus3 = newTagDUniqSupply origtag dus2 -- restore original tag+  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, dus3, 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 UniqDSM+        ( [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 UniqDSM+       ( [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 UniqDSM ()+    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]+   -> UniqDSM+        ( [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] -> UniqDSM (CmmDeclSRTs, SRTEntry)+buildSRT profile refs = do+  id <- getUniqueDSM+  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 ())
+ GHC/Cmm/InitFini.hs view
@@ -0,0 +1,78 @@+-- | 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
+ GHC/Cmm/LRegSet.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Cmm.LRegSet (+    LRegSet,++    emptyLRegSet,+    nullLRegSet,+    insertLRegSet,+    elemLRegSet,++    deleteFromLRegSet,+    sizeLRegSet,++    unionLRegSet,+    unionsLRegSet,+    elemsLRegSet+  ) where++import GHC.Prelude+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Cmm.Expr++-- Compact sets for membership tests of local variables.++type LRegSet = UniqueSet++{-# INLINE emptyLRegSet #-}+emptyLRegSet :: LRegSet+emptyLRegSet = emptyUniqueSet++{-# INLINE nullLRegSet #-}+nullLRegSet :: LRegSet -> Bool+nullLRegSet = nullUniqueSet++{-# INLINE insertLRegSet #-}+insertLRegSet :: LocalReg -> LRegSet -> LRegSet+insertLRegSet l = insertUniqueSet (getUnique l)++{-# INLINE elemLRegSet #-}+elemLRegSet :: LocalReg -> LRegSet -> Bool+elemLRegSet l = memberUniqueSet (getUnique l)++{-# INLINE deleteFromLRegSet #-}+deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet+deleteFromLRegSet set reg = deleteUniqueSet (getUnique reg) set++{-# INLINE sizeLRegSet #-}+sizeLRegSet :: LRegSet -> Int+sizeLRegSet = sizeUniqueSet++{-# INLINE unionLRegSet #-}+unionLRegSet :: LRegSet -> LRegSet -> LRegSet+unionLRegSet = unionUniqueSet++{-# INLINE unionsLRegSet #-}+unionsLRegSet :: [LRegSet] -> LRegSet+unionsLRegSet = unionsUniqueSet++{-# INLINE elemsLRegSet #-}+elemsLRegSet :: LRegSet -> [Unique]+elemsLRegSet = elemsUniqueSet
+ GHC/Cmm/LayoutStack.hs view
@@ -0,0 +1,1243 @@+{-# LANGUAGE 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+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Data.Maybe+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+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)+import Data.List.NonEmpty ( NonEmpty (..) )++{- 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+               -> UniqDSM (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++       -> UniqDSM+          ( 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 :: [Block CmmNode C C]+       -> LabelMap StackMap+       -> StackLoc+       -> [CmmBlock]+       -> UniqDSM (LabelMap StackMap, StackLoc, [CmmBlock])+    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 (GlobalRegUse 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 (expectNonEmpty 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+   -> UniqDSM+      ( [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 :: UniqDSM ( [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 -> UniqDSM (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]+               -> UniqDSM (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 platform) (cmmOffset platform (spExpr platform) 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 platform) (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 platform) (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 platform) (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 (GlobalRegUse Sp _)) x_off+                      , CmmLit (CmmInt y_lit _)]+                , CmmReg (CmmGlobal (GlobalRegUse 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]+    -> UniqDSM [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 platform) (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 -> UniqDSM 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 $ baseReg platform)+    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 platform) (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 platform)+                       , 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 (removeDetermGraph 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 platform, 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]
+ GHC/Cmm/Lexer.hs view
@@ -0,0 +1,1087 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LINE 13 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-}+module GHC.Cmm.Lexer (+   CmmToken(..), cmmlex,+  ) where++import GHC.Prelude++import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..))++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.Platform+import GHC.Utils.Error+import GHC.Utils.Misc+--import TRACE++import Data.Word+import Data.Char+#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array.Base (unsafeAt)+import GHC.Exts+#else+import GlaExts+#endif+alex_tab_size :: Int+alex_tab_size = 8+alex_base :: AlexAddr+alex_base = AlexA#+  "\x01\x00\x00\x00\xc9\x00\x00\x00\x57\x00\x00\x00\xb9\x00\x00\x00\x2a\x01\x00\x00\x29\x02\x00\x00\x28\x03\x00\x00\x27\x04\x00\x00\x26\x05\x00\x00\x25\x06\x00\x00\x25\x07\x00\x00\xf8\x07\x00\x00\xcb\x08\x00\x00\x9e\x09\x00\x00\x93\xff\xff\xff\xa6\xff\xff\xff\xc2\xff\xff\xff\xce\xff\xff\xff\xd2\xff\xff\xff\x00\x00\x00\x00\xe1\xff\xff\xff\xd7\xff\xff\xff\xe6\xff\xff\xff\x00\x00\x00\x00\xe9\xff\xff\xff\xde\xff\xff\xff\xdb\xff\xff\xff\xef\xff\xff\xff\xe0\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x03\x00\x00\x00\xf9\xff\xff\xff\x05\x00\x00\x00\xf1\xff\xff\xff\x06\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xff\xff\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x71\x0a\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x71\x00\x00\x00\xc4\x00\x00\x00\xb7\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xc2\x00\x00\x00\xc1\x00\x00\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x44\x0b\x00\x00\x17\x0c\x00\x00\xea\x0c\x00\x00\xbd\x0d\x00\x00\x90\x0e\x00\x00\x63\x0f\x00\x00\x36\x10\x00\x00\x09\x11\x00\x00\xdc\x11\x00\x00\xaf\x12\x00\x00\x82\x13\x00\x00\x55\x14\x00\x00\x28\x15\x00\x00\xfb\x15\x00\x00\xce\x16\x00\x00\xa1\x17\x00\x00\x74\x18\x00\x00\x47\x19\x00\x00\x1a\x1a\x00\x00\xd7\x00\x00\x00\xd9\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xd8\x00\x00\x00\x7a\x00\x00\x00\x6a\x00\x00\x00\x72\x00\x00\x00\x82\x00\x00\x00\xed\x1a\x00\x00\xc0\x1b\x00\x00\x93\x1c\x00\x00\x66\x1d\x00\x00\x39\x1e\x00\x00\x0c\x1f\x00\x00\xdf\x1f\x00\x00\xb2\x20\x00\x00\x85\x21\x00\x00\x58\x22\x00\x00\x2b\x23\x00\x00\xfe\x23\x00\x00\xd1\x24\x00\x00\xa4\x25\x00\x00\x77\x26\x00\x00\x4a\x27\x00\x00\x1d\x28\x00\x00\xf0\x28\x00\x00\xc3\x29\x00\x00\x96\x2a\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x8c\x00\x00\x00\x03\x01\x00\x00\x84\x01\x00\x00\x87\x00\x00\x00\x83\x00\x00\x00\x8e\x00\x00\x00\x34\x2b\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x00\x00\xa3\x03\x00\x00\x7d\x2b\x00\x00\xa4\x01\x00\x00\x00\x02\x00\x00\x81\x04\x00\x00\xa1\x04\x00\x00\x96\x2b\x00\x00\xbc\x2b\x00\x00\xfd\x04\x00\x00\xd5\x2b\x00\x00\x80\x05\x00\x00\x49\x2c\x00\x00\x1c\x2d\x00\x00\xef\x2d\x00\x00\xc2\x2e\x00\x00\x95\x2f\x00\x00\x68\x30\x00\x00\x3b\x31\x00\x00\x0e\x32\x00\x00\xe1\x32\x00\x00\xb4\x33\x00\x00\x87\x34\x00\x00\x5a\x35\x00\x00\x2d\x36\x00\x00\x00\x37\x00\x00\xd3\x37\x00\x00\xa6\x38\x00\x00\x79\x39\x00\x00\x4c\x3a\x00\x00\x1f\x3b\x00\x00\xf2\x3b\x00\x00\xc5\x3c\x00\x00\x98\x3d\x00\x00\x6b\x3e\x00\x00\x3e\x3f\x00\x00\x11\x40\x00\x00\xe4\x40\x00\x00\xb7\x41\x00\x00\x8a\x42\x00\x00\x5d\x43\x00\x00\x30\x44\x00\x00\x03\x45\x00\x00\xd6\x45\x00\x00\x9e\x46\x00\x00\x9d\x47\x00\x00\x9d\x48\x00\x00\x70\x49\x00\x00\x43\x4a\x00\x00\x16\x4b\x00\x00\xe9\x4b\x00\x00\xbc\x4c\x00\x00\x8f\x4d\x00\x00\x62\x4e\x00\x00\x35\x4f\x00\x00\x08\x50\x00\x00\xdb\x50\x00\x00\xae\x51\x00\x00\x81\x52\x00\x00\x54\x53\x00\x00\x27\x54\x00\x00\xfa\x54\x00\x00\xcd\x55\x00\x00\xa0\x56\x00\x00\x73\x57\x00\x00\x46\x58\x00\x00\x19\x59\x00\x00\xec\x59\x00\x00\xbf\x5a\x00\x00\x92\x5b\x00\x00\x65\x5c\x00\x00\x38\x5d\x00\x00\x0b\x5e\x00\x00\xde\x5e\x00\x00\xb1\x5f\x00\x00\x84\x60\x00\x00\x57\x61\x00\x00\x2a\x62\x00\x00\xfd\x62\x00\x00\xd0\x63\x00\x00\xa3\x64\x00\x00\x76\x65\x00\x00\x49\x66\x00\x00\x1c\x67\x00\x00\xef\x67\x00\x00\xc2\x68\x00\x00\x95\x69\x00\x00\x68\x6a\x00\x00\x3b\x6b\x00\x00\x0e\x6c\x00\x00\xe1\x6c\x00\x00\xb4\x6d\x00\x00\x87\x6e\x00\x00\x5a\x6f\x00\x00\x2d\x70\x00\x00\x00\x71\x00\x00\xd3\x71\x00\x00\xa6\x72\x00\x00\x79\x73\x00\x00\x4c\x74\x00\x00\x1f\x75\x00\x00\xf2\x75\x00\x00\xc5\x76\x00\x00\x98\x77\x00\x00\x6b\x78\x00\x00\x3e\x79\x00\x00\x11\x7a\x00\x00\xe4\x7a\x00\x00\xb7\x7b\x00\x00\x8a\x7c\x00\x00\x5d\x7d\x00\x00\x25\x7e\x00\x00\x24\x7f\x00\x00\x24\x80\x00\x00\xf7\x80\x00\x00\xbf\x81\x00\x00\xbe\x82\x00\x00\xbe\x83\x00\x00\x91\x84\x00\x00\x59\x85\x00\x00\x58\x86\x00\x00\x57\x87\x00\x00\x56\x88\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+  "\x00\x00\xff\xff\x8d\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x3a\x00\x81\x00\x81\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x2b\x00\x84\x00\x5e\x00\x11\x00\x1f\x00\x29\x00\xff\xff\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x39\x00\xaf\x00\x38\x00\x8e\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x35\x00\x38\x00\x31\x00\x2d\x00\x33\x00\xff\xff\x12\x00\x15\x00\x69\x00\xa9\x00\xb1\x00\x13\x00\xb0\x00\xb4\x00\xaa\x00\x16\x00\x17\x00\x19\x00\xfe\x00\x45\x00\x1a\x00\x1b\x00\x08\x00\x1d\x00\x06\x00\x4b\x00\x9d\x00\xa5\x00\xb6\x00\x1c\x00\xb3\x00\xfa\x00\xf6\x00\x38\x00\xff\xff\x38\x00\x38\x00\x81\x00\x38\x00\x81\x00\x81\x00\x81\x00\x22\x00\x23\x00\x1e\x00\x21\x00\x24\x00\x14\x00\x25\x00\x26\x00\x71\x00\x28\x00\x2a\x00\x2c\x00\x2e\x00\x32\x00\x2f\x00\x30\x00\x34\x00\x36\x00\x81\x00\x80\x00\x5a\x00\x5e\x00\xff\xff\x38\x00\x27\x00\x38\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\xff\xff\xff\xff\x18\x00\x5c\x00\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\x81\x00\x60\x00\x81\x00\x81\x00\x81\x00\x89\x00\xff\xff\x3d\x00\x20\x00\x82\x00\x43\x00\xff\xff\xff\xff\x59\x00\x61\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x5c\x00\x5f\x00\x76\x00\x78\x00\x81\x00\x77\x00\xff\xff\x5e\x00\x7b\x00\x7c\x00\x7f\x00\x7d\x00\x80\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\xff\xff\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5b\x00\x7a\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x04\x00\x00\x00\x90\x00\x90\x00\x42\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x3c\x00\x5d\x00\x44\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x3d\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x3d\x00\x00\x00\x81\x00\x00\x00\x00\x00\x81\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x89\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x88\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x79\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x8b\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x86\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x66\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x04\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x4a\x00\x00\x00\x49\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbb\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+  "\xff\xff\x00\x00\x01\x00\x02\x00\x71\x00\x5f\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x63\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x73\x00\x61\x00\x42\x00\x43\x00\x44\x00\x74\x00\x46\x00\x47\x00\x48\x00\x73\x00\x65\x00\x63\x00\x4c\x00\x4d\x00\x71\x00\x75\x00\x50\x00\x72\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x69\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x09\x00\x60\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x61\x00\x65\x00\x65\x00\x78\x00\x65\x00\x65\x00\x64\x00\x6c\x00\x7c\x00\x26\x00\x3d\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x61\x00\x01\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x69\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\xd7\x00\x20\x00\x72\x00\x73\x00\x23\x00\x0a\x00\x0a\x00\x6e\x00\x6e\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x01\x00\x6c\x00\x65\x00\x72\x00\x20\x00\x70\x00\x0a\x00\x23\x00\x61\x00\x67\x00\x61\x00\x6d\x00\x0a\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\x01\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x69\x00\x65\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xa0\x00\xff\xff\x20\x00\xff\xff\xff\xff\xa0\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\xff\xff\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x01\x00\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x78\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+  "\x90\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x58\x00\x58\x00\x5a\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 254)+  [ AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 209+  , AlexAcc 208+  , AlexAcc 207+  , AlexAcc 206+  , AlexAcc 205+  , AlexAcc 204+  , AlexAcc 203+  , AlexAcc 202+  , AlexAcc 201+  , AlexAcc 200+  , AlexAcc 199+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 198+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 197+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 196+  , AlexAcc 195+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 194+  , AlexAcc 193+  , AlexAcc 192+  , AlexAcc 191+  , AlexAcc 190+  , AlexAcc 189+  , AlexAcc 188+  , AlexAcc 187+  , AlexAcc 186+  , AlexAcc 185+  , AlexAcc 184+  , AlexAcc 183+  , AlexAcc 182+  , AlexAcc 181+  , AlexAcc 180+  , AlexAcc 179+  , AlexAcc 178+  , AlexAcc 177+  , AlexAcc 176+  , AlexAcc 175+  , AlexAccSkip+  , AlexAcc 174+  , AlexAcc 173+  , AlexAccSkip+  , AlexAcc 172+  , AlexAcc 171+  , AlexAcc 170+  , AlexAcc 169+  , AlexAcc 168+  , AlexAccPred 167 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 166)+  , AlexAcc 165+  , AlexAcc 164+  , AlexAcc 163+  , AlexAcc 162+  , AlexAcc 161+  , AlexAcc 160+  , AlexAcc 159+  , AlexAcc 158+  , AlexAcc 157+  , AlexAcc 156+  , AlexAcc 155+  , AlexAcc 154+  , AlexAcc 153+  , AlexAcc 152+  , AlexAcc 151+  , AlexAcc 150+  , AlexAcc 149+  , AlexAcc 148+  , AlexAcc 147+  , AlexAcc 146+  , AlexAcc 145+  , AlexAcc 144+  , AlexAccNone+  , AlexAcc 143+  , AlexAcc 142+  , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 140)+  , AlexAccPred 139 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 138+  , AlexAcc 137+  , AlexAcc 136+  , AlexAcc 135+  , AlexAcc 134+  , AlexAcc 133+  , AlexAcc 132+  , AlexAcc 131+  , AlexAcc 130+  , AlexAcc 129+  , AlexAcc 128+  , AlexAcc 127+  , AlexAcc 126+  , AlexAcc 125+  , AlexAcc 124+  , AlexAcc 123+  , AlexAcc 122+  , AlexAcc 121+  , AlexAcc 120+  , AlexAcc 119+  , AlexAccPred 118 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 117+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccSkip+  , AlexAccNone+  , AlexAcc 116+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 115+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 114+  , AlexAccNone+  , AlexAcc 113+  , AlexAcc 112+  , AlexAcc 111+  , AlexAcc 110+  , AlexAcc 109+  , AlexAcc 108+  , AlexAcc 107+  , AlexAcc 106+  , AlexAcc 105+  , AlexAcc 104+  , AlexAcc 103+  , AlexAcc 102+  , AlexAcc 101+  , AlexAcc 100+  , AlexAcc 99+  , AlexAcc 98+  , AlexAcc 97+  , AlexAcc 96+  , AlexAcc 95+  , AlexAcc 94+  , AlexAcc 93+  , AlexAcc 92+  , AlexAcc 91+  , AlexAcc 90+  , AlexAcc 89+  , AlexAcc 88+  , AlexAcc 87+  , AlexAcc 86+  , AlexAcc 85+  , AlexAcc 84+  , AlexAcc 83+  , AlexAcc 82+  , AlexAcc 81+  , AlexAcc 80+  , AlexAcc 79+  , AlexAcc 78+  , AlexAcc 77+  , AlexAcc 76+  , AlexAcc 75+  , AlexAcc 74+  , AlexAcc 73+  , AlexAcc 72+  , AlexAcc 71+  , AlexAcc 70+  , AlexAcc 69+  , AlexAcc 68+  , AlexAcc 67+  , AlexAcc 66+  , AlexAcc 65+  , AlexAcc 64+  , AlexAcc 63+  , AlexAcc 62+  , AlexAcc 61+  , AlexAcc 60+  , AlexAcc 59+  , AlexAcc 58+  , AlexAcc 57+  , AlexAcc 56+  , AlexAcc 55+  , AlexAcc 54+  , AlexAcc 53+  , AlexAcc 52+  , AlexAcc 51+  , AlexAcc 50+  , AlexAcc 49+  , AlexAcc 48+  , AlexAcc 47+  , AlexAcc 46+  , AlexAcc 45+  , AlexAcc 44+  , AlexAcc 43+  , AlexAcc 42+  , AlexAcc 41+  , AlexAcc 40+  , AlexAcc 39+  , AlexAcc 38+  , AlexAcc 37+  , AlexAcc 36+  , AlexAcc 35+  , AlexAcc 34+  , AlexAcc 33+  , AlexAcc 32+  , AlexAcc 31+  , AlexAcc 30+  , AlexAcc 29+  , AlexAcc 28+  , AlexAcc 27+  , AlexAcc 26+  , AlexAcc 25+  , AlexAcc 24+  , AlexAcc 23+  , AlexAcc 22+  , AlexAcc 21+  , AlexAcc 20+  , AlexAcc 19+  , AlexAcc 18+  , AlexAcc 17+  , AlexAcc 16+  , AlexAcc 15+  , AlexAcc 14+  , AlexAcc 13+  , AlexAcc 12+  , AlexAcc 11+  , AlexAcc 10+  , AlexAcc 9+  , AlexAcc 8+  , AlexAcc 7+  , AlexAcc 6+  , AlexAcc 5+  , AlexAcc 4+  , AlexAcc 3+  , AlexAcc 2+  , AlexAcc 1+  , AlexAcc 0+  ]++alex_actions = array (0 :: Int, 210)+  [ (209,alex_action_5)+  , (208,alex_action_28)+  , (207,alex_action_27)+  , (206,alex_action_49)+  , (205,alex_action_26)+  , (204,alex_action_49)+  , (203,alex_action_25)+  , (202,alex_action_24)+  , (201,alex_action_23)+  , (200,alex_action_49)+  , (199,alex_action_22)+  , (198,alex_action_21)+  , (197,alex_action_20)+  , (196,alex_action_19)+  , (195,alex_action_7)+  , (194,alex_action_18)+  , (193,alex_action_7)+  , (192,alex_action_17)+  , (191,alex_action_7)+  , (190,alex_action_16)+  , (189,alex_action_7)+  , (188,alex_action_15)+  , (187,alex_action_7)+  , (186,alex_action_14)+  , (185,alex_action_13)+  , (184,alex_action_12)+  , (183,alex_action_7)+  , (182,alex_action_11)+  , (181,alex_action_7)+  , (180,alex_action_10)+  , (179,alex_action_7)+  , (178,alex_action_9)+  , (177,alex_action_8)+  , (176,alex_action_7)+  , (175,alex_action_7)+  , (174,alex_action_5)+  , (173,alex_action_5)+  , (172,alex_action_5)+  , (171,alex_action_5)+  , (170,alex_action_5)+  , (169,alex_action_5)+  , (168,alex_action_5)+  , (167,alex_action_2)+  , (166,alex_action_5)+  , (165,alex_action_5)+  , (164,alex_action_49)+  , (163,alex_action_49)+  , (162,alex_action_49)+  , (161,alex_action_49)+  , (160,alex_action_49)+  , (159,alex_action_49)+  , (158,alex_action_49)+  , (157,alex_action_49)+  , (156,alex_action_49)+  , (155,alex_action_49)+  , (154,alex_action_49)+  , (153,alex_action_49)+  , (152,alex_action_49)+  , (151,alex_action_49)+  , (150,alex_action_49)+  , (149,alex_action_49)+  , (148,alex_action_49)+  , (147,alex_action_49)+  , (146,alex_action_49)+  , (145,alex_action_5)+  , (144,alex_action_5)+  , (143,alex_action_4)+  , (142,alex_action_3)+  , (141,alex_action_2)+  , (140,alex_action_5)+  , (139,alex_action_2)+  , (138,alex_action_49)+  , (137,alex_action_49)+  , (136,alex_action_49)+  , (135,alex_action_49)+  , (134,alex_action_49)+  , (133,alex_action_49)+  , (132,alex_action_49)+  , (131,alex_action_49)+  , (130,alex_action_49)+  , (129,alex_action_49)+  , (128,alex_action_49)+  , (127,alex_action_49)+  , (126,alex_action_49)+  , (125,alex_action_49)+  , (124,alex_action_49)+  , (123,alex_action_49)+  , (122,alex_action_49)+  , (121,alex_action_49)+  , (120,alex_action_49)+  , (119,alex_action_49)+  , (118,alex_action_2)+  , (117,alex_action_53)+  , (116,alex_action_54)+  , (115,alex_action_53)+  , (114,alex_action_52)+  , (113,alex_action_51)+  , (112,alex_action_51)+  , (111,alex_action_50)+  , (110,alex_action_49)+  , (109,alex_action_49)+  , (108,alex_action_49)+  , (107,alex_action_49)+  , (106,alex_action_49)+  , (105,alex_action_49)+  , (104,alex_action_49)+  , (103,alex_action_49)+  , (102,alex_action_49)+  , (101,alex_action_49)+  , (100,alex_action_49)+  , (99,alex_action_49)+  , (98,alex_action_49)+  , (97,alex_action_49)+  , (96,alex_action_49)+  , (95,alex_action_49)+  , (94,alex_action_49)+  , (93,alex_action_49)+  , (92,alex_action_49)+  , (91,alex_action_49)+  , (90,alex_action_49)+  , (89,alex_action_49)+  , (88,alex_action_49)+  , (87,alex_action_49)+  , (86,alex_action_49)+  , (85,alex_action_49)+  , (84,alex_action_49)+  , (83,alex_action_49)+  , (82,alex_action_49)+  , (81,alex_action_49)+  , (80,alex_action_49)+  , (79,alex_action_49)+  , (78,alex_action_49)+  , (77,alex_action_49)+  , (76,alex_action_49)+  , (75,alex_action_49)+  , (74,alex_action_49)+  , (73,alex_action_49)+  , (72,alex_action_49)+  , (71,alex_action_48)+  , (70,alex_action_49)+  , (69,alex_action_49)+  , (68,alex_action_49)+  , (67,alex_action_49)+  , (66,alex_action_49)+  , (65,alex_action_49)+  , (64,alex_action_49)+  , (63,alex_action_49)+  , (62,alex_action_49)+  , (61,alex_action_47)+  , (60,alex_action_49)+  , (59,alex_action_49)+  , (58,alex_action_49)+  , (57,alex_action_49)+  , (56,alex_action_49)+  , (55,alex_action_49)+  , (54,alex_action_49)+  , (53,alex_action_49)+  , (52,alex_action_49)+  , (51,alex_action_46)+  , (50,alex_action_49)+  , (49,alex_action_49)+  , (48,alex_action_49)+  , (47,alex_action_49)+  , (46,alex_action_49)+  , (45,alex_action_49)+  , (44,alex_action_49)+  , (43,alex_action_49)+  , (42,alex_action_49)+  , (41,alex_action_45)+  , (40,alex_action_49)+  , (39,alex_action_49)+  , (38,alex_action_49)+  , (37,alex_action_49)+  , (36,alex_action_49)+  , (35,alex_action_49)+  , (34,alex_action_49)+  , (33,alex_action_49)+  , (32,alex_action_49)+  , (31,alex_action_44)+  , (30,alex_action_49)+  , (29,alex_action_43)+  , (28,alex_action_49)+  , (27,alex_action_49)+  , (26,alex_action_49)+  , (25,alex_action_42)+  , (24,alex_action_49)+  , (23,alex_action_41)+  , (22,alex_action_40)+  , (21,alex_action_39)+  , (20,alex_action_49)+  , (19,alex_action_38)+  , (18,alex_action_37)+  , (17,alex_action_36)+  , (16,alex_action_49)+  , (15,alex_action_49)+  , (14,alex_action_35)+  , (13,alex_action_34)+  , (12,alex_action_33)+  , (11,alex_action_32)+  , (10,alex_action_49)+  , (9,alex_action_49)+  , (8,alex_action_49)+  , (7,alex_action_31)+  , (6,alex_action_49)+  , (5,alex_action_49)+  , (4,alex_action_49)+  , (3,alex_action_30)+  , (2,alex_action_49)+  , (1,alex_action_29)+  , (0,alex_action_49)+  ]+++line_prag,line_prag1,line_prag2 :: Int+line_prag = 1+line_prag1 = 2+line_prag2 = 3+alex_action_2 = begin line_prag+alex_action_3 = setLine line_prag1+alex_action_4 = setFile line_prag2+alex_action_5 = pop+alex_action_7 = special_char+alex_action_8 = kw CmmT_DotDot+alex_action_9 = kw CmmT_DoubleColon+alex_action_10 = kw CmmT_Shr+alex_action_11 = kw CmmT_Shl+alex_action_12 = kw CmmT_Ge+alex_action_13 = kw CmmT_Le+alex_action_14 = kw CmmT_Eq+alex_action_15 = kw CmmT_Ne+alex_action_16 = kw CmmT_BoolAnd+alex_action_17 = kw CmmT_BoolOr+alex_action_18 = kw CmmT_Relaxed+alex_action_19 = kw CmmT_Acquire+alex_action_20 = kw CmmT_Release+alex_action_21 = kw CmmT_SeqCst+alex_action_22 = kw CmmT_True+alex_action_23 = kw CmmT_False+alex_action_24 = kw CmmT_likely+alex_action_25 = global_regN 1 VanillaReg      gcWord+alex_action_26 = global_regN 1 VanillaReg       bWord+alex_action_27 = global_regN 1 FloatReg  (const $ cmmFloat W32)+alex_action_28 = global_regN 1 DoubleReg (const $ cmmFloat W64)+alex_action_29 = global_regN 1 LongReg   (const $ cmmBits  W64)+alex_action_30 = global_regN 3 XmmReg    (const $ cmmVec 2 (cmmFloat W64))+alex_action_31 = global_regN 3 YmmReg    (const $ cmmVec 4 (cmmFloat W64))+alex_action_32 = global_regN 3 ZmmReg    (const $ cmmVec 8 (cmmFloat W64))+alex_action_33 = global_reg  Sp               bWord+alex_action_34 = global_reg  SpLim            bWord+alex_action_35 = global_reg  Hp              gcWord+alex_action_36 = global_reg  HpLim            bWord+alex_action_37 = global_reg  CCCS             bWord+alex_action_38 = global_reg  CurrentTSO       bWord+alex_action_39 = global_reg  CurrentNursery   bWord+alex_action_40 = global_reg  HpAlloc          bWord+alex_action_41 = global_reg  BaseReg          bWord+alex_action_42 = global_reg  MachSp           bWord+alex_action_43 = global_reg  UnwindReturnReg  bWord+alex_action_44 = kw (CmmT_GlobalArgRegs GP_ARG_REGS)+alex_action_45 = kw (CmmT_GlobalArgRegs SCALAR_ARG_REGS)+alex_action_46 = kw (CmmT_GlobalArgRegs V16_ARG_REGS)+alex_action_47 = kw (CmmT_GlobalArgRegs V32_ARG_REGS)+alex_action_48 = kw (CmmT_GlobalArgRegs V64_ARG_REGS)+alex_action_49 = name+alex_action_50 = tok_octal+alex_action_51 = tok_decimal+alex_action_52 = tok_hexadecimal+alex_action_53 = strtoken tok_float+alex_action_54 = strtoken tok_string++#define ALEX_GHC 1+#define ALEX_LATIN1 1+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++#ifdef ALEX_GHC+#  define ILIT(n) n#+#  define IBOX(n) (I# (n))+#  define FAST_INT Int#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#  if __GLASGOW_HASKELL__ > 706+#    define GTE(n,m) (tagToEnum# (n >=# m))+#    define EQ(n,m) (tagToEnum# (n ==# m))+#  else+#    define GTE(n,m) (n >=# m)+#    define EQ(n,m) (n ==# m)+#  endif+#  define PLUS(n,m) (n +# m)+#  define MINUS(n,m) (n -# m)+#  define TIMES(n,m) (n *# m)+#  define NEGATE(n) (negateInt# (n))+#  define IF_GHC(x) (x)+#else+#  define ILIT(n) (n)+#  define IBOX(n) (n)+#  define FAST_INT Int+#  define GTE(n,m) (n >= m)+#  define EQ(n,m) (n == m)+#  define PLUS(n,m) (n + m)+#  define MINUS(n,m) (n - m)+#  define TIMES(n,m) (n * m)+#  define NEGATE(n) (negate (n))+#  define IF_GHC(x)+#endif++#ifdef ALEX_GHC+data AlexAddr = AlexA# Addr#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow16Int# i+  where+        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+        low  = int2Word# (ord# (indexCharOffAddr# arr off'))+        off' = off *# 2#+#else+#if __GLASGOW_HASKELL__ >= 901+  int16ToInt#+#endif+    (indexInt16OffAddr# arr off)+#endif+#else+alexIndexInt16OffAddr arr off = arr ! off+#endif++#ifdef ALEX_GHC+{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt32OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow32Int# i+  where+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+                     (b2 `uncheckedShiftL#` 16#) `or#`+                     (b1 `uncheckedShiftL#` 8#) `or#` b0)+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))+   off' = off *# 4#+#else+#if __GLASGOW_HASKELL__ >= 901+  int32ToInt#+#endif+    (indexInt32OffAddr# arr off)+#endif+#else+alexIndexInt32OffAddr arr off = arr ! off+#endif++#ifdef ALEX_GHC++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+#else+quickIndex arr i = arr ! i+#endif++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input__ IBOX(sc)+  = alexScanUser undefined input__ IBOX(sc)++alexScanUser user__ input__ IBOX(sc)+  = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of+  (AlexNone, input__') ->+    case alexGetByte input__ of+      Nothing ->+#ifdef ALEX_DEBUG+                                   trace ("End of input.") $+#endif+                                   AlexEOF+      Just _ ->+#ifdef ALEX_DEBUG+                                   trace ("Error.") $+#endif+                                   AlexError input__'++  (AlexLastSkip input__'' len, _) ->+#ifdef ALEX_DEBUG+    trace ("Skipping.") $+#endif+    AlexSkip input__'' len++  (AlexLastAcc k input__''' len, _) ->+#ifdef ALEX_DEBUG+    trace ("Accept.") $+#endif+    AlexToken input__''' len (alex_actions ! k)+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user__ orig_input len input__ s last_acc =+  input__ `seq` -- strict in the input+  let+  new_acc = (check_accs (alex_accept `quickIndex` IBOX(s)))+  in+  new_acc `seq`+  case alexGetByte input__ of+     Nothing -> (new_acc, input__)+     Just (c, new_input) ->+#ifdef ALEX_DEBUG+      trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $+#endif+      case fromIntegral c of { IBOX(ord_c) ->+        let+                base   = alexIndexInt32OffAddr alex_base s+                offset = PLUS(base,ord_c)++                new_s = if GTE(offset,ILIT(0))+                          && let check  = alexIndexInt16OffAddr alex_check offset+                             in  EQ(check,ord_c)+                          then alexIndexInt16OffAddr alex_table offset+                          else alexIndexInt16OffAddr alex_deflt s+        in+        case new_s of+            ILIT(-1) -> (new_acc, input__)+                -- on an error, we want to keep the input *before* the+                -- character that failed, not after.+            _ -> alex_scan_tkn user__ orig_input+#ifdef ALEX_LATIN1+                   PLUS(len,ILIT(1))+                   -- issue 119: in the latin1 encoding, *each* byte is one character+#else+                   (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len)+                   -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+#endif+                   new_input new_s new_acc+      }+  where+        check_accs (AlexAccNone) = last_acc+        check_accs (AlexAcc a  ) = AlexLastAcc a input__ IBOX(len)+        check_accs (AlexAccSkip) = AlexLastSkip  input__ IBOX(len)+#ifndef ALEX_NOPRED+        check_accs (AlexAccPred a predx rest)+           | predx user__ orig_input IBOX(len) input__+           = AlexLastAcc a input__ IBOX(len)+           | otherwise+           = check_accs rest+        check_accs (AlexAccSkipPred predx rest)+           | predx user__ orig_input IBOX(len) input__+           = AlexLastSkip input__ IBOX(len)+           | otherwise+           = check_accs rest+#endif++data AlexLastAcc+  = AlexNone+  | AlexLastAcc !Int !AlexInput !Int+  | AlexLastSkip     !AlexInput !Int++data AlexAcc user+  = AlexAccNone+  | AlexAcc Int+  | AlexAccSkip+#ifndef ALEX_NOPRED+  | AlexAccPred Int (AlexAccPred user) (AlexAcc user)+  | AlexAccSkipPred (AlexAccPred user) (AlexAcc user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user__ in1 len in2+  = p1 user__ in1 len in2 && p2 user__ in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _+alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__++alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__)++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _+alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__++--alexRightContext :: Int -> AlexAccPred _+alexRightContext IBOX(sc) user__ _ _ input__ =+     case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of+          (AlexNone, _) -> False+          _ -> True+        -- TODO: there's no need to find the longest+        -- match when checking the right context, just+        -- the first match will do.+#endif+{-# LINE 144 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-}+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_vec128+  | CmmT_vec256+  | CmmT_vec512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg     GlobalRegUse+  | CmmT_GlobalArgRegs GlobalArgRegs+  | CmmT_Name          FastString+  | CmmT_String        String+  | CmmT_Int           Integer+  | CmmT_Float         Rational+  | CmmT_EOF+  | CmmT_False+  | CmmT_True+  | CmmT_likely+  | CmmT_Relaxed+  | CmmT_Acquire+  | CmmT_Release+  | CmmT_SeqCst+  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 -> (Int -> GlobalReg) -> (Platform -> CmmType) -> Action+global_regN ident_nb_chars con ty_fn span buf len+  = do { platform <- getPlatform+       ; let reg = con (fromIntegral n)+             ty = ty_fn platform+       ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) }+  where buf' = go ident_nb_chars buf+          where go 0 b = b+                go i b = go (i-1) (stepOn b)+        n = parseUnsignedInteger buf' (len-ident_nb_chars) 10 octDecDigit++global_reg :: GlobalReg -> (Platform -> CmmType) -> Action+global_reg reg ty_fn span _buf _len+  = do { platform <- getPlatform+       ; let ty = ty_fn platform+       ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) }++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 ),+        ( "vec128",             CmmT_vec128 ),+        ( "vec256",             CmmT_vec256 ),+        ( "vec512",             CmmT_vec512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "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 } ()
+ GHC/Cmm/Lint.hs view
@@ -0,0 +1,317 @@+-----------------------------------------------------------------------------+--+-- (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.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)+  let machop_arg_widths = machOpArgReps platform op+      arg_tys           = map (cmmExprType platform) args+  if map typeWidth arg_tys == machop_arg_widths+    then cmmCheckMachOp op args tys+    else cmmLintMachOpErr expr arg_tys machop_arg_widths+lintCmmExpr (CmmRegOff reg offset)+  = do let rep = typeWidth (cmmRegType 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+            erep <- lintCmmExpr expr+            let reg_ty = cmmRegType reg+            unless (erep `cmmCompatType` reg_ty) $+              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty++  CmmStore l r _alignment -> do+            _ <- lintCmmExpr l+            _ <- lintCmmExpr r+            return ()++  CmmUnsafeForeignCall target _formals actuals -> do+            let lintArg expr = do+                  -- Arguments can't mention caller-saved+                  -- registers. See Note [Register parameter passing].+                  mayNotMentionCallerSavedRegs (text "foreign call argument") expr+                  lintCmmExpr expr+            arg_tys <- mapM lintArg actuals+            lintTarget arg_tys target+++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+          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+          arg_tys <- mapM lintArg args+          lintTarget arg_tys tgt+          checkTarget succ+ where+  checkTarget id+     | setMember id labels = return ()+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)++lintTarget :: [CmmType] -> ForeignTarget -> CmmLint ()+lintTarget _arg_tys (ForeignTarget e _) = do+    mayNotMentionCallerSavedRegs (text "foreign target") e+    _ <- lintCmmExpr e+    return ()+lintTarget arg_tys (PrimTarget mop) = do+  platform <- getPlatform+  let machop_arg_tys = callishMachOpArgTys platform mop+  unless (and $ zipWith cmmCompatType arg_tys machop_arg_tys) $+    cmmLintCallishMachOpErr mop arg_tys machop_arg_tys++-- | 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))++cmmLintCallishMachOpErr :: CallishMachOp -> [CmmType] -> [CmmType] -> CmmLint a+cmmLintCallishMachOpErr mop argTys mopTys+     = cmmLintErr (text "in Callish MachOp application: " $$+                   nest 2 (text $ show mop) $$+                      (text "op is expecting: " <+> ppr mopTys) $$+                      (text "arguments provide: " <+> ppr argTys))++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))+-}+
+ GHC/Cmm/Liveness.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE GADTs #-}++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+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.LRegSet++import GHC.Data.Maybe+import GHC.Utils.Outputable+import GHC.Utils.Panic++-----------------------------------------------------------------------------+-- 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 $ mapLookup entry facts) facts++cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse+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 GlobalRegUse) #-}++-----------------------------------------------------------------------------+-- | 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 = unionLRegSet 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 $ 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 = 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+
+ GHC/Cmm/MachOp.hs view
@@ -0,0 +1,988 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Cmm.MachOp+    ( 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+    , callishMachOpArgTys++    -- Atomic read-modify-write+    , MemoryOrdering(..)+    , AtomicMachOp(..)++    -- Fused multiply-add+    , FMASign(..), pprFMASign+   )+where++import GHC.Prelude++import GHC.Platform+import GHC.Cmm.Type+import GHC.Utils.Outputable+import GHC.Utils.Misc (expectNonEmpty)++import Data.List.NonEmpty (NonEmpty (..))++-----------------------------------------------------------------------------+--              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.++Note that there are variety of places in the native code generator where we+assume that the code produced for a MachOp does not introduce new blocks.+-}++-- Note [MO_S_MulMayOflo significant width]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are two interpretations in the code about what a multiplication+-- overflow exactly means:+--+-- 1. The result does not fit into the specified width (of type Width.)+-- 2. The result does not fit into a register.+--+-- (2) has some flaws: A following MO_Mul has a width, too. So MO_S_MulMayOflo+-- may signal no overflow, while MO_Mul truncates the result. There are+-- architectures with several register widths and it might be hard to decide+-- what's an overflow and what not. Both attributes can easily lead to subtle+-- bugs.+--+-- (1) has the benefit that its interpretation is completely independent of the+-- architecture. So, the mid-term plan is to migrate to this+-- interpretation/semantics.++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. See+                                -- Note [MO_S_MulMayOflo significant width]+  | 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_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 fused multiply-add operations+  -- | Fused multiply-add, see 'FMASign'.+  | MO_FMA FMASign Length 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++  | MO_F_Min Width+  | MO_F_Max 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++  -- Shifts. The shift amount must be in [0,widthInBits).+  | 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_Round    Width Width  -- Signed int -> Float+  | MO_FS_Truncate 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++  | MO_WF_Bitcast Width      -- Word32/Word64   -> Float/Double+  | MO_FW_Bitcast Width      -- Float/Double  -> Word32/Word64++  -- Vector element insertion and extraction operations+  | MO_V_Broadcast Length Width -- Broadcast a scalar into a vector+  | 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+  | MO_VS_Neg  Length Width++  -- Vector shuffles+  | MO_V_Shuffle  Length Width [Int]+  | MO_VF_Shuffle Length Width [Int]++  -- Floating point vector element insertion and extraction operations+  | MO_VF_Broadcast Length Width   -- Broadcast a scalar into a vector+  | 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++  -- Min/max operations+  | MO_VS_Min Length Width+  | MO_VS_Max Length Width+  | MO_VU_Min Length Width+  | MO_VU_Max Length Width+  | MO_VF_Min Length Width+  | MO_VF_Max Length Width++  -- | An atomic read with no memory ordering. Address msut+  -- be naturally aligned.+  | MO_RelaxedRead Width++  -- Alignment check (for -falignment-sanitisation)+  | MO_AlignmentCheck Int Width+  deriving (Eq, Show)++pprMachOp :: MachOp -> SDoc+pprMachOp mo = text (show mo)++-- | Where are the signs in a fused multiply-add instruction?+--+-- @x*y + z@ vs @x*y - z@ vs @-x*y+z@ vs @-x*y-z@.+--+-- Warning: the signs aren't consistent across architectures (X86, PowerPC, AArch64).+-- The user-facing implementation uses the X86 convention, while the relevant+-- backends use their corresponding conventions.+data FMASign+  -- | Fused multiply-add @x*y + z@.+  = FMAdd+  -- | Fused multiply-subtract. On X86: @x*y - z@.+  | FMSub+  -- | Fused multiply-add. On X86: @-x*y + z@.+  | FNMAdd+  -- | Fused multiply-subtract. On X86: @-x*y - z@.+  | FNMSub+  deriving (Eq, Show)++pprFMASign :: IsLine doc => FMASign -> doc+pprFMASign = \case+  FMAdd  -> text "fmadd"+  FMSub  -> text "fmsub"+  FNMAdd -> text "fnmadd"+  FNMSub -> text "fnmsub"++-- -----------------------------------------------------------------------------+-- 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+    :: Platform -> MachOp++mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_32To8, mo_32To16+    :: MachOp++mo_wordAdd      platform = MO_Add (wordWidth platform)+mo_wordSub      platform = MO_Sub (wordWidth platform)+mo_wordEq       platform = MO_Eq  (wordWidth platform)+mo_wordNe       platform = MO_Ne  (wordWidth platform)+mo_wordMul      platform = MO_Mul (wordWidth platform)+mo_wordSQuot    platform = MO_S_Quot (wordWidth platform)+mo_wordSRem     platform = MO_S_Rem (wordWidth platform)+mo_wordSNeg     platform = MO_S_Neg (wordWidth platform)+mo_wordUQuot    platform = MO_U_Quot (wordWidth platform)+mo_wordURem     platform = MO_U_Rem (wordWidth platform)++mo_wordSGe      platform = MO_S_Ge  (wordWidth platform)+mo_wordSLe      platform = MO_S_Le  (wordWidth platform)+mo_wordSGt      platform = MO_S_Gt  (wordWidth platform)+mo_wordSLt      platform = MO_S_Lt  (wordWidth platform)++mo_wordUGe      platform = MO_U_Ge  (wordWidth platform)+mo_wordULe      platform = MO_U_Le  (wordWidth platform)+mo_wordUGt      platform = MO_U_Gt  (wordWidth platform)+mo_wordULt      platform = MO_U_Lt  (wordWidth platform)++mo_wordAnd      platform = MO_And (wordWidth platform)+mo_wordOr       platform = MO_Or  (wordWidth platform)+mo_wordXor      platform = MO_Xor (wordWidth platform)+mo_wordNot      platform = MO_Not (wordWidth platform)+mo_wordShl      platform = MO_Shl (wordWidth platform)+mo_wordSShr     platform = MO_S_Shr (wordWidth platform)+mo_wordUShr     platform = MO_U_Shr (wordWidth platform)++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    platform = MO_UU_Conv W8  (wordWidth platform)+mo_s_8ToWord    platform = MO_SS_Conv W8  (wordWidth platform)+mo_u_16ToWord   platform = MO_UU_Conv W16 (wordWidth platform)+mo_s_16ToWord   platform = MO_SS_Conv W16 (wordWidth platform)+mo_s_32ToWord   platform = MO_SS_Conv W32 (wordWidth platform)+mo_u_32ToWord   platform = MO_UU_Conv W32 (wordWidth platform)++mo_WordTo8      platform = MO_UU_Conv (wordWidth platform) W8+mo_WordTo16     platform = MO_UU_Conv (wordWidth platform) W16+mo_WordTo32     platform = MO_UU_Conv (wordWidth platform) W32+mo_WordTo64     platform = MO_UU_Conv (wordWidth platform) 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_And _                -> True+        MO_Or _                 -> True+        MO_Xor _                -> True+        MO_F_Add _              -> True+        MO_F_Mul _              -> True+        MO_F_Min {}             -> True+        MO_F_Max {}             -> 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++-- Note [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 w   -> Just (MO_Ne w)+        MO_Ne w   -> Just (MO_Eq w)+        MO_U_Lt w -> Just (MO_U_Ge w)+        MO_U_Gt w -> Just (MO_U_Le w)+        MO_U_Le w -> Just (MO_U_Gt w)+        MO_U_Ge w -> Just (MO_U_Lt w)+        MO_S_Lt w -> Just (MO_S_Ge w)+        MO_S_Gt w -> Just (MO_S_Le w)+        MO_S_Le w -> Just (MO_S_Gt w)+        MO_S_Ge w -> Just (MO_S_Lt w)+        _other    -> Nothing++-- ----------------------------------------------------------------------------+-- machOpResultType++{- |+Returns the MachRep of the result of a MachOp.+-}+machOpResultType :: Platform -> MachOp -> [CmmType] -> CmmType+machOpResultType platform mop tys =+  case mop of+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood+    MO_Sub {}           -> ty1  -- of first arg+    MO_Mul    w         -> cmmBits w+    MO_S_MulMayOflo w   -> cmmBits w+    MO_S_Quot w         -> cmmBits w+    MO_S_Rem  w         -> cmmBits w+    MO_S_Neg  w         -> cmmBits w+    MO_U_Quot w         -> cmmBits w+    MO_U_Rem  w         -> cmmBits w++    MO_Eq {}            -> comparisonResultRep platform+    MO_Ne {}            -> comparisonResultRep platform+    MO_S_Ge {}          -> comparisonResultRep platform+    MO_S_Le {}          -> comparisonResultRep platform+    MO_S_Gt {}          -> comparisonResultRep platform+    MO_S_Lt {}          -> comparisonResultRep platform++    MO_U_Ge {}          -> comparisonResultRep platform+    MO_U_Le {}          -> comparisonResultRep platform+    MO_U_Gt {}          -> comparisonResultRep platform+    MO_U_Lt {}          -> comparisonResultRep platform++    MO_F_Add w          -> cmmFloat w+    MO_F_Sub w          -> cmmFloat w+    MO_F_Mul w          -> cmmFloat w+    MO_F_Quot w         -> cmmFloat w+    MO_F_Neg w          -> cmmFloat w+    MO_F_Min w          -> cmmFloat w+    MO_F_Max w          -> cmmFloat w++    MO_FMA _ l w        -> if l == 1 then cmmFloat w else cmmVec l (cmmFloat w)++    MO_F_Eq  {}         -> comparisonResultRep platform+    MO_F_Ne  {}         -> comparisonResultRep platform+    MO_F_Ge  {}         -> comparisonResultRep platform+    MO_F_Le  {}         -> comparisonResultRep platform+    MO_F_Gt  {}         -> comparisonResultRep platform+    MO_F_Lt  {}         -> comparisonResultRep platform++    MO_And {}           -> ty1  -- Used for pointer masking+    MO_Or {}            -> ty1+    MO_Xor {}           -> ty1+    MO_Not   w          -> cmmBits w+    MO_Shl   w          -> cmmBits w+    MO_U_Shr w          -> cmmBits w+    MO_S_Shr w          -> cmmBits w++    MO_SS_Conv _ to     -> cmmBits to+    MO_UU_Conv _ to     -> cmmBits to+    MO_XX_Conv _ to     -> cmmBits to+    MO_FS_Truncate _ to -> cmmBits to+    MO_SF_Round _ to    -> cmmFloat to+    MO_FF_Conv _ to     -> cmmFloat to+    MO_WF_Bitcast   w   -> cmmFloat w+    MO_FW_Bitcast   w   -> cmmBits w++    MO_V_Broadcast l w  -> cmmVec l (cmmBits w)+    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_Neg  l w      -> cmmVec l (cmmBits w)+    MO_VS_Min  l w      -> cmmVec l (cmmBits w)+    MO_VS_Max  l w      -> cmmVec l (cmmBits w)++    MO_VU_Min  l w      -> cmmVec l (cmmBits w)+    MO_VU_Max  l w      -> cmmVec l (cmmBits w)++    MO_V_Shuffle  l w _ -> cmmVec l (cmmBits w)+    MO_VF_Shuffle l w _ -> cmmVec l (cmmFloat w)++    MO_VF_Broadcast l w -> cmmVec l (cmmFloat 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_VF_Min  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Max  l w      -> cmmVec l (cmmFloat w)++    MO_RelaxedRead w    -> cmmBits w+    MO_AlignmentCheck _ _ -> ty1+  where+    ty1:|_ = expectNonEmpty tys++comparisonResultRep :: Platform -> 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 :: Platform -> MachOp -> [Width]+machOpArgReps platform op =+  case op of+    MO_Add    w         -> [w,w]+    MO_Sub    w         -> [w,w]+    MO_Eq     w         -> [w,w]+    MO_Ne     w         -> [w,w]+    MO_Mul    w         -> [w,w]+    MO_S_MulMayOflo w   -> [w,w]+    MO_S_Quot w         -> [w,w]+    MO_S_Rem  w         -> [w,w]+    MO_S_Neg  w         -> [w]+    MO_U_Quot w         -> [w,w]+    MO_U_Rem  w         -> [w,w]++    MO_S_Ge w           -> [w,w]+    MO_S_Le w           -> [w,w]+    MO_S_Gt w           -> [w,w]+    MO_S_Lt w           -> [w,w]++    MO_U_Ge w           -> [w,w]+    MO_U_Le w           -> [w,w]+    MO_U_Gt w           -> [w,w]+    MO_U_Lt w           -> [w,w]++    MO_F_Add w          -> [w,w]+    MO_F_Sub w          -> [w,w]+    MO_F_Mul w          -> [w,w]+    MO_F_Quot w         -> [w,w]+    MO_F_Neg w          -> [w]+    MO_F_Min w          -> [w,w]+    MO_F_Max w          -> [w,w]++    MO_FMA _ l w        -> [vecwidth l w, vecwidth l w, vecwidth l w]++    MO_F_Eq  w          -> [w,w]+    MO_F_Ne  w          -> [w,w]+    MO_F_Ge  w          -> [w,w]+    MO_F_Le  w          -> [w,w]+    MO_F_Gt  w          -> [w,w]+    MO_F_Lt  w          -> [w,w]++    MO_And   w          -> [w,w]+    MO_Or    w          -> [w,w]+    MO_Xor   w          -> [w,w]+    MO_Not   w          -> [w]+    MO_Shl   w          -> [w, wordWidth platform]+    MO_U_Shr w          -> [w, wordWidth platform]+    MO_S_Shr w          -> [w, wordWidth platform]++    MO_SS_Conv from _     -> [from]+    MO_UU_Conv from _     -> [from]+    MO_XX_Conv from _     -> [from]+    MO_SF_Round from _    -> [from]+    MO_FS_Truncate from _ -> [from]+    MO_FF_Conv from _     -> [from]+    MO_WF_Bitcast w       -> [w]+    MO_FW_Bitcast w       -> [w]++    MO_V_Shuffle  l w _ -> [vecwidth l w, vecwidth l w]+    MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w]++    MO_V_Broadcast _ w  -> [w]+    MO_V_Insert   l w   -> [vecwidth l w, w, W32]+    MO_V_Extract  l w   -> [vecwidth l w, W32]+    MO_VF_Broadcast _ w -> [w]+    MO_VF_Insert  l w   -> [vecwidth l w, w, W32]+    MO_VF_Extract l w   -> [vecwidth l w, W32]+      -- SIMD vector indices are always 32 bit++    MO_V_Add l w        -> [vecwidth l w, vecwidth l w]+    MO_V_Sub l w        -> [vecwidth l w, vecwidth l w]+    MO_V_Mul l w        -> [vecwidth l w, vecwidth l w]++    MO_VS_Neg  l w      -> [vecwidth l w]+    MO_VS_Min  l w      -> [vecwidth l w, vecwidth l w]+    MO_VS_Max  l w      -> [vecwidth l w, vecwidth l w]++    MO_VU_Min  l w      -> [vecwidth l w, vecwidth l w]+    MO_VU_Max  l w      -> [vecwidth l w, vecwidth l w]++    -- NOTE: The below is owing to the fact that floats use the SSE registers+    MO_VF_Add  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Sub  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Mul  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Quot l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Neg  l w      -> [vecwidth l w]+    MO_VF_Min  l w      -> [vecwidth l w, vecwidth l w]+    MO_VF_Max  l w      -> [vecwidth l w, vecwidth l w]++    MO_RelaxedRead _    -> [wordWidth platform]+    MO_AlignmentCheck _ w -> [w]+  where+    vecwidth l w = widthFromBytes (l * widthInBytes w)++-----------------------------------------------------------------------------+-- 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_Log1P+  | MO_F64_Exp+  | MO_F64_ExpM1+  | 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_Log1P+  | MO_F32_Exp+  | MO_F32_ExpM1+  | MO_F32_Fabs+  | MO_F32_Sqrt++  -- 64-bit int/word ops for when they exceed the native word size+  -- (i.e. on 32-bit architectures)+  | MO_I64_ToI+  | MO_I64_FromI+  | MO_W64_ToW+  | MO_W64_FromW++  | MO_x64_Neg+  | MO_x64_Add+  | MO_x64_Sub+  | MO_x64_Mul+  | MO_I64_Quot+  | MO_I64_Rem+  | MO_W64_Quot+  | MO_W64_Rem++  | MO_x64_And+  | MO_x64_Or+  | MO_x64_Xor+  | MO_x64_Not+  | MO_x64_Shl+  | MO_I64_Shr+  | MO_W64_Shr++  | MO_x64_Eq+  | MO_x64_Ne+  | MO_I64_Ge+  | MO_I64_Gt+  | MO_I64_Le+  | MO_I64_Lt+  | MO_W64_Ge+  | MO_W64_Gt+  | MO_W64_Le+  | MO_W64_Lt++  | MO_UF_Conv Width++  | MO_S_Mul2    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++  -- Signed vector divide+  | MO_VS_Quot Length Width+  | MO_VS_Rem  Length Width++  -- Unsigned vector divide+  | MO_VU_Quot Length Width+  | MO_VU_Rem  Length Width++  -- Int64X2/Word64X2 min/max+  | MO_I64X2_Min+  | MO_I64X2_Max+  | MO_W64X2_Min+  | MO_W64X2_Max++  | MO_Touch         -- Keep variables live (when using interior pointers)++  -- Prefetch+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not+                     -- program behavior.+                     -- the Int can be 0-3. Needs to be known at compile time+                     -- to interact with code generation correctly.+                     --  TODO: add support for prefetch WRITES,+                     --  currently only exposes prefetch reads, which+                     -- would the majority of use cases in ghc anyways+++  -- These three MachOps are parameterised by the known alignment+  -- of the destination and source (for memcpy/memmove) pointers.+  -- This information may be used for optimisation in backends.+  | MO_Memcpy Int+  | MO_Memset Int+  | MO_Memmove Int+  | MO_Memcmp Int++  | MO_PopCnt Width+  | MO_Pdep Width+  | MO_Pext Width+  | MO_Clz Width+  | MO_Ctz Width++  | MO_BSwap Width+  | MO_BRev Width++  | MO_AcquireFence+  | MO_ReleaseFence+  | MO_SeqCstFence++  -- | Atomic read-modify-write. Arguments are @[dest, n]@.+  | MO_AtomicRMW Width AtomicMachOp+  -- | Atomic read. Arguments are @[addr]@.+  | MO_AtomicRead Width MemoryOrdering+  -- | Atomic write. Arguments are @[addr, value]@.+  | MO_AtomicWrite Width MemoryOrdering+  -- | Atomic compare-and-swap. Arguments are @[dest, expected, new]@.+  -- Sequentially consistent.+  -- Possible future refactoring: should this be an'MO_AtomicRMW' variant?+  | MO_Cmpxchg Width+  -- | Atomic swap. Arguments are @[dest, new]@+  | MO_Xchg Width++  -- These rts provided functions are special: suspendThread releases the+  -- capability, hence we mustn't sink any use of data stored in the capability+  -- after this instruction.+  | MO_SuspendThread+  | MO_ResumeThread+  deriving (Eq, Show)++-- | C11 memory ordering semantics.+data MemoryOrdering+  = MemOrderRelaxed  -- ^ relaxed ordering+  | MemOrderAcquire  -- ^ acquire ordering+  | MemOrderRelease  -- ^ release ordering+  | MemOrderSeqCst   -- ^ sequentially consistent+  deriving (Eq, Ord, 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)++-- | Return (results_hints,args_hints)+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])+  MO_SuspendThread -> ([AddrHint], [AddrHint,NoHint])+  MO_ResumeThread  -> ([AddrHint], [AddrHint])+  _                -> ([],[])+  -- 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++-- | Like 'machOpArgReps', but for 'CallishMachOp'.+--+-- Used only in Cmm lint.+callishMachOpArgTys :: Platform -> CallishMachOp -> [CmmType]+callishMachOpArgTys platform = \case+  MO_F64_Pwr -> [f64, f64]+  MO_F64_Sin -> [f64]+  MO_F64_Cos -> [f64]+  MO_F64_Tan -> [f64]+  MO_F64_Sinh -> [f64]+  MO_F64_Cosh -> [f64]+  MO_F64_Tanh -> [f64]+  MO_F64_Asin -> [f64]+  MO_F64_Acos -> [f64]+  MO_F64_Atan -> [f64]+  MO_F64_Asinh -> [f64]+  MO_F64_Acosh -> [f64]+  MO_F64_Atanh -> [f64]+  MO_F64_Log -> [f64]+  MO_F64_Log1P -> [f64]+  MO_F64_Exp -> [f64]+  MO_F64_ExpM1 -> [f64]+  MO_F64_Fabs -> [f64]+  MO_F64_Sqrt -> [f64]+  MO_F32_Pwr -> [f32, f32]+  MO_F32_Sin -> [f32]+  MO_F32_Cos -> [f32]+  MO_F32_Tan -> [f32]+  MO_F32_Sinh -> [f32]+  MO_F32_Cosh -> [f32]+  MO_F32_Tanh -> [f32]+  MO_F32_Asin -> [f32]+  MO_F32_Acos -> [f32]+  MO_F32_Atan -> [f32]+  MO_F32_Asinh -> [f32]+  MO_F32_Acosh -> [f32]+  MO_F32_Atanh -> [f32]+  MO_F32_Log -> [f32]+  MO_F32_Log1P -> [f32]+  MO_F32_Exp -> [f32]+  MO_F32_ExpM1 -> [f32]+  MO_F32_Fabs -> [f32]+  MO_F32_Sqrt -> [f32]+  MO_I64_ToI -> [b64]+  MO_I64_FromI -> [bWord platform]+  MO_W64_ToW -> [b64]+  MO_W64_FromW -> [bWord platform]+  MO_x64_Neg -> [b64]+  MO_x64_Add -> [b64]+  MO_x64_Sub -> [b64]+  MO_x64_Mul -> [b64]+  MO_I64_Quot -> [b64,b64]+  MO_I64_Rem -> [b64,b64]+  MO_W64_Quot -> [b64,b64]+  MO_W64_Rem -> [b64,b64]+  MO_x64_And -> [b64,b64]+  MO_x64_Or -> [b64,b64]+  MO_x64_Xor -> [b64,b64]+  MO_x64_Not -> [b64]+  MO_x64_Shl -> [b64,b64]+  MO_I64_Shr -> [b64,b64]+  MO_W64_Shr -> [b64,b64]+  MO_x64_Eq -> [b64,b64]+  MO_x64_Ne -> [b64,b64]+  MO_I64_Ge -> [b64,b64]+  MO_I64_Gt -> [b64,b64]+  MO_I64_Le -> [b64,b64]+  MO_I64_Lt -> [b64,b64]+  MO_W64_Ge -> [b64,b64]+  MO_W64_Gt -> [b64,b64]+  MO_W64_Le -> [b64,b64]+  MO_W64_Lt -> [b64,b64]+  MO_UF_Conv _w -> [bWord platform] -- Word to Float/Double+  MO_S_Mul2    w -> [cmmBits w, cmmBits w]+  MO_S_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem2 w -> [cmmBits w, cmmBits w]+  MO_Add2      w -> [cmmBits w, cmmBits w]+  MO_AddWordC  w -> [cmmBits w, cmmBits w]+  MO_SubWordC  w -> [cmmBits w, cmmBits w]+  MO_AddIntC   w -> [cmmBits w, cmmBits w]+  MO_SubIntC   w -> [cmmBits w, cmmBits w]+  MO_U_Mul2    w -> [cmmBits w, cmmBits w]+  MO_VS_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VS_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_I64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_I64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_Touch -> [gcWord platform]+  MO_Prefetch_Data _n -> [addr]+  MO_Memcpy _align -> [addr, addr, bWord platform]+  MO_Memset _align ->+    [ addr+    , bWord platform -- byte to set: supplied as an int, converted to a byte+    , bWord platform]+  MO_Memmove _align -> [addr, addr, bWord platform]+  MO_Memcmp _align -> [addr, addr, bWord platform]+  MO_PopCnt w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Pdep w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Pext w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Clz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Ctz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BSwap w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BRev w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_AcquireFence -> []+  MO_ReleaseFence -> []+  MO_SeqCstFence -> []+  MO_AtomicRMW w _op -> [addr, cmmBits w]+  MO_AtomicRead _w _mem_ordering -> [addr]+  MO_AtomicWrite w _mem_ordering -> [addr, cmmBits w]+  MO_Cmpxchg w -> [addr, cmmBits w, cmmBits w]+  MO_Xchg w -> [addr, cmmBits w]+  MO_SuspendThread -> []+  MO_ResumeThread -> []+  where+    addr = bWord platform
+ GHC/Cmm/Node.hs view
@@ -0,0 +1,937 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}++-- CmmNode type for representation using Hoopl graphs.++module GHC.Cmm.Node (+     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 GHC.Prelude hiding (succ)++import GHC.Platform.Regs+import GHC.Cmm.CLabel+import GHC.Cmm.Expr+import GHC.Cmm.Switch+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Types.ForeignCall+import GHC.Utils.Outputable+import GHC.Runtime.Heap.Layout+import GHC.Types.Tickish (CmmTickish)+import qualified GHC.Types.Unique as U+import GHC.Types.Basic (FunctionOrData(..))++import GHC.Platform+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import Data.Foldable (toList)+import Data.Functor.Classes (liftCompare)+import Data.Maybe+import Data.List (tails,sortBy)+import GHC.Types.Unique (nonDetCmpUnique)+import GHC.Utils.Constants (debugIsOn)+++------------------------+-- 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 "GHC.Cmm.DebugBlock"+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O++  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O+    -- Assign to register++  CmmStore :: !CmmExpr -> !CmmExpr -> !AlignmentSpec -> 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 GHC.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 BlockIds]+          -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+          -- 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 :: [GlobalRegUse],+          -- 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++instance OutputableP Platform (CmmNode e x) where+    pdoc = pprNode++pprNode :: Platform -> CmmNode e x -> SDoc+pprNode platform node = pp_node <+> pp_debug+  where+    pp_node :: SDoc+    pp_node = case node of+      -- label:+      CmmEntry id tscope ->+         (sdocOption sdocSuppressUniques $ \case+            True  -> text "_lbl_"+            False -> ppr id+         )+         <> colon+         <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)++      -- // text+      CmmComment s -> text "//" <+> ftext s++      -- //tick bla<...>+      CmmTick t -> ppUnlessOption sdocSuppressTicks+                     (text "//tick" <+> ppr t)++      -- unwind reg = expr;+      CmmUnwind regs ->+          text "unwind "+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi++      -- reg = expr;+      CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi++      -- rep[lv] = expr;+      CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi+          where+            align_mark = case align of+                           Unaligned -> text "^"+                           NaturallyAligned -> empty+            rep = ppr ( cmmExprType platform 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",+                 pdoc platform target <> parens (commafy $ map (pdoc platform) 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 (pdoc platform 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 pdoc platform expr+                       else parens (pdoc platform expr)+                     , text "{"+                     ])+             4 (vcat (map ppCase cases) $$ def) $$ rbrace+          where+            (cases, mbdef) = switchTargetsFallThrough ids+            ppCase (is,l) = hsep+                            [ text "case"+                            , commafy $ toList $ fmap 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 _) = pdoc platform f+                pprFun f = parens (pdoc platform 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+               , pdoc platform t, text "(...)", space+               , text "returns to" <+> ppr s+                    <+> text "args:" <+> parens (pdoc platform 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++instance OutputableP Platform (Block CmmNode C C) where+    pdoc = pprBlock+instance OutputableP Platform (Block CmmNode C O) where+    pdoc = pprBlock+instance OutputableP Platform (Block CmmNode O C) where+    pdoc = pprBlock+instance OutputableP Platform (Block CmmNode O O) where+    pdoc = pprBlock++instance OutputableP Platform (Graph CmmNode e x) where+    pdoc = pprGraph++pprBlock :: IndexedCO x SDoc SDoc ~ SDoc+         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc+pprBlock platform block+    = foldBlockNodesB3 ( ($$) . pdoc platform+                       , ($$) . (nest 4) . pdoc platform+                       , ($$) . (nest 4) . pdoc platform+                       )+                       block+                       empty++pprGraph :: Platform -> Graph CmmNode e x -> SDoc+pprGraph platform = \case+   GNil                  -> empty+   GUnit block           -> pdoc platform block+   GMany entry body exit ->+         text "{"+      $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)+      $$ text "}"+      where pprMaybeO :: OutputableP Platform (Block CmmNode e x)+                      => MaybeO ex (Block CmmNode e x) -> SDoc+            pprMaybeO NothingO = empty+            pprMaybeO (JustO block) = pdoc platform block++{- 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 GHC.Cmm.LayoutStack, 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).+GHC.StgToCmm.Utils.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 GHC.StgToCmm.Utils.++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 GHC.Cmm.Sink+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++instance Outputable ForeignConvention where+    ppr = pprForeignConvention++pprForeignConvention :: ForeignConvention -> SDoc+pprForeignConvention (ForeignConvention c args res ret) =+    doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret++data CmmReturnInfo+  = CmmMayReturn+  | CmmNeverReturns+  deriving ( Eq )++instance Outputable CmmReturnInfo where+    ppr = pprReturnInfo++pprReturnInfo :: CmmReturnInfo -> SDoc+pprReturnInfo CmmMayReturn = empty+pprReturnInfo CmmNeverReturns = text "never returns"++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++instance OutputableP Platform ForeignTarget where+    pdoc = pprForeignTarget++pprForeignTarget :: Platform -> ForeignTarget -> SDoc+pprForeignTarget platform (ForeignTarget fn c) =+    ppr c <+> ppr_target fn+  where+    ppr_target :: CmmExpr -> SDoc+    ppr_target t@(CmmLit _) = pdoc platform t+    ppr_target fn'          = parens (pdoc platform fn')+pprForeignTarget platform (PrimTarget op)+ -- HACK: We're just using a ForeignLabel to get this printed, the label+ --       might not really be foreign.+ = pdoc platform+               (mkForeignLabel+                          (mkFastString (show op))+                          ForeignLabelInThisPackage IsFunction)++instance Outputable Convention where+  ppr = pprConvention++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>"+++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+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform 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 platform f z n++instance UserOfRegs GlobalRegUse (CmmNode e x) where+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform 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 GlobalRegUse a+               => (b -> GlobalRegUse -> b) -> b -> a -> b+          fold f z n = foldRegsUsed platform 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 GHC.Tc.TyCl.Instance+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed _        _ !z (PrimTarget _)      = z+  foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e++instance DefinerOfRegs LocalReg (CmmNode e x) where+  {-# INLINEABLE foldRegsDefd #-}+  foldRegsDefd platform 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 platform f z n++instance DefinerOfRegs GlobalRegUse (CmmNode e x) where+  {-# INLINEABLE foldRegsDefd #-}+  foldRegsDefd platform 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 GlobalRegUse a+               => (b -> GlobalRegUse -> b) -> b -> a -> b+          fold f z n = foldRegsDefd platform f z n++          activeRegs :: [GlobalRegUse]+          activeRegs = map (\ r -> GlobalRegUse r (globalRegSpillType platform r)) $ activeStgRegs platform+          activeCallerSavesRegs = filter (callerSaves platform . globalRegUse_reg) 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 GHC.Cmm.Node++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 align) = f (CmmLoad (wrapRecExp f addr) ty align)+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 align)               = CmmStore (f addr) (f e) align+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 GHC.Cmm.Node, 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 align) = maybe (f n) (\addr' -> f $ CmmLoad addr' ty align) (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 align)   = (\ (Pair addr' e') -> CmmStore addr' e' align) `fmap` traverse f (Pair 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 GHC.Cmm.Node++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, [])++-- -----------------------------------------------------------------------------++-- | 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 (extremely) 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'                   = liftCompare 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 simplify 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
+ GHC/Cmm/Opt.hs view
@@ -0,0 +1,484 @@+-----------------------------------------------------------------------------+--+-- 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.Utils.Outputable+import GHC.Platform++import Data.Maybe+import GHC.Float+++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 _ (MO_V_Broadcast lg _w) exprs =+  case exprs of+    [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)+    _ -> Nothing+cmmMachOpFoldM _ (MO_VF_Broadcast lg _w) exprs =+  case exprs of+    [CmmLit l] -> Just $! CmmLit (CmmVec $ replicate lg l)+    _ -> Nothing+cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]+  | MO_WF_Bitcast width <- op = case width of+      W32 | res <- castWord32ToFloat (fromInteger x)+          -- Since we store float literals as Rationals+          -- we must check for the usual tricky cases first+          , not (isNegativeZero res || isNaN res || isInfinite res)+          -- (round-tripping subnormals is not a problem)+          , !res_rat <- toRational res+            -> Just (CmmLit (CmmFloat res_rat W32))++      W64 | res <- castWord64ToDouble (fromInteger x)+          -- Since we store float literals as Rationals+          -- we must check for the usual tricky cases first+          , not (isNegativeZero res || isNaN res || isInfinite res)+          -- (round-tripping subnormals is not a problem)+          , !res_rat <- toRational res+            -> Just (CmmLit (CmmFloat res_rat W64))++      _ -> Nothing+  | otherwise+  = Just $! case op of+      MO_S_Neg _ -> CmmLit (CmmInt (narrowS rep (-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_Round _frm 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)++      MO_F_Neg{}          -> invalidArgPanic+      MO_FS_Truncate{}    -> invalidArgPanic+      MO_FF_Conv{}        -> invalidArgPanic+      MO_FW_Bitcast{}     -> invalidArgPanic+      MO_VS_Neg{}         -> invalidArgPanic+      MO_VF_Neg{}         -> invalidArgPanic+      MO_RelaxedRead{}    -> invalidArgPanic+      MO_AlignmentCheck{} -> invalidArgPanic++      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op+      where invalidArgPanic = pprPanic "cmmMachOpFoldM" $+              text "Found" <+> pprMachOp op+                <+> text "illegally applied to an int literal"++-- 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 (narrowU r $ x + y) r)+        MO_Sub r -> Just $! CmmLit (CmmInt (narrowS r $ x - y) r)+        MO_Mul r -> Just $! CmmLit (CmmInt (narrowU r $ 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 (narrowU r $ 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. We don't perform this optimization if rep is greater+-- than the host word size because we use an Int to store the offset. See+-- #24893 and #24700. This should be fixed to ensure that optimizations don't+-- depend on the compiler host platform.+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+  | validOffsetRep rep+  = Just $! cmmRegOff reg (fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  | validOffsetRep rep+  = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+  | validOffsetRep rep+  = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  | validOffsetRep 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)]+  | validOffsetRep rep+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+  | validOffsetRep rep+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+  | validOffsetRep 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++-- | Check that a literal width is compatible with the host word size used to+-- store offsets. This should be fixed properly (using larger types to store+-- literal offsets). See #24893+validOffsetRep :: Width -> Bool+validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int)+++{- 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 (GlobalRegUse PicBaseReg _))) = True+isPicReg _ = False
+ GHC/Cmm/Parser.hs view
@@ -0,0 +1,3906 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-}+#if __GLASGOW_HASKELL__ >= 710+{-# OPTIONS_GHC -XPartialTypeSignatures #-}+#endif+{-# 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.Reg        ( GlobalArgRegs(..) )+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.Unique.DSM+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+import qualified Data.Array as Happy_Data_Array+import qualified Data.Bits as Bits+import qualified GHC.Exts as Happy_GHC_Exts+import Control.Applicative(Applicative(..))+import Control.Monad (ap)++-- parser produced by Happy Version 1.20.1.1++newtype HappyAbsSyn  = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+newtype HappyWrap4 = HappyWrap4 (CmmParse ())+happyIn4 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x)+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn ) -> HappyWrap4+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+newtype HappyWrap5 = HappyWrap5 (CmmParse ())+happyIn5 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x)+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn ) -> HappyWrap5+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+newtype HappyWrap6 = HappyWrap6 (CmmParse ())+happyIn6 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x)+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn ) -> HappyWrap6+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+newtype HappyWrap7 = HappyWrap7 (CmmParse CLabel)+happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn )+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x)+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn ) -> HappyWrap7+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+newtype HappyWrap8 = HappyWrap8 ([CmmParse [CmmStatic]])+happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn )+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap8 x)+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn ) -> HappyWrap8+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+newtype HappyWrap9 = HappyWrap9 (CmmParse [CmmStatic])+happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn )+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x)+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn ) -> HappyWrap9+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+newtype HappyWrap10 = HappyWrap10 ([CmmParse CmmExpr])+happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )+happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x)+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn ) -> HappyWrap10+happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut10 #-}+newtype HappyWrap11 = HappyWrap11 (CmmParse ())+happyIn11 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x)+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn ) -> HappyWrap11+happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut11 #-}+newtype HappyWrap12 = HappyWrap12 (Convention)+happyIn12 :: (Convention) -> (HappyAbsSyn )+happyIn12 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap12 x)+{-# INLINE happyIn12 #-}+happyOut12 :: (HappyAbsSyn ) -> HappyWrap12+happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut12 #-}+newtype HappyWrap13 = HappyWrap13 (CmmParse ())+happyIn13 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn13 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap13 x)+{-# INLINE happyIn13 #-}+happyOut13 :: (HappyAbsSyn ) -> HappyWrap13+happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut13 #-}+newtype HappyWrap14 = HappyWrap14 (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]))+happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn )+happyIn14 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap14 x)+{-# INLINE happyIn14 #-}+happyOut14 :: (HappyAbsSyn ) -> HappyWrap14+happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut14 #-}+newtype HappyWrap15 = HappyWrap15 (CmmParse ())+happyIn15 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn15 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap15 x)+{-# INLINE happyIn15 #-}+happyOut15 :: (HappyAbsSyn ) -> HappyWrap15+happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut15 #-}+newtype HappyWrap16 = HappyWrap16 (CmmParse ())+happyIn16 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x)+{-# INLINE happyIn16 #-}+happyOut16 :: (HappyAbsSyn ) -> HappyWrap16+happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut16 #-}+newtype HappyWrap17 = HappyWrap17 ([(FastString, CLabel)])+happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn )+happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x)+{-# INLINE happyIn17 #-}+happyOut17 :: (HappyAbsSyn ) -> HappyWrap17+happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut17 #-}+newtype HappyWrap18 = HappyWrap18 ((FastString,  CLabel))+happyIn18 :: ((FastString,  CLabel)) -> (HappyAbsSyn )+happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x)+{-# INLINE happyIn18 #-}+happyOut18 :: (HappyAbsSyn ) -> HappyWrap18+happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut18 #-}+newtype HappyWrap19 = HappyWrap19 ([FastString])+happyIn19 :: ([FastString]) -> (HappyAbsSyn )+happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x)+{-# INLINE happyIn19 #-}+happyOut19 :: (HappyAbsSyn ) -> HappyWrap19+happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut19 #-}+newtype HappyWrap20 = HappyWrap20 (CmmParse ())+happyIn20 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x)+{-# INLINE happyIn20 #-}+happyOut20 :: (HappyAbsSyn ) -> HappyWrap20+happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut20 #-}+newtype HappyWrap21 = HappyWrap21 (CmmParse [(GlobalReg, Maybe CmmExpr)])+happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn )+happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x)+{-# INLINE happyIn21 #-}+happyOut21 :: (HappyAbsSyn ) -> HappyWrap21+happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut21 #-}+newtype HappyWrap22 = HappyWrap22 (CmmParse MemoryOrdering)+happyIn22 :: (CmmParse MemoryOrdering) -> (HappyAbsSyn )+happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x)+{-# INLINE happyIn22 #-}+happyOut22 :: (HappyAbsSyn ) -> HappyWrap22+happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut22 #-}+newtype HappyWrap23 = HappyWrap23 (CmmParse (Maybe CmmExpr))+happyIn23 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn )+happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x)+{-# INLINE happyIn23 #-}+happyOut23 :: (HappyAbsSyn ) -> HappyWrap23+happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut23 #-}+newtype HappyWrap24 = HappyWrap24 (CmmParse CmmExpr)+happyIn24 :: (CmmParse CmmExpr) -> (HappyAbsSyn )+happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x)+{-# INLINE happyIn24 #-}+happyOut24 :: (HappyAbsSyn ) -> HappyWrap24+happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut24 #-}+newtype HappyWrap25 = HappyWrap25 (CmmReturnInfo)+happyIn25 :: (CmmReturnInfo) -> (HappyAbsSyn )+happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x)+{-# INLINE happyIn25 #-}+happyOut25 :: (HappyAbsSyn ) -> HappyWrap25+happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut25 #-}+newtype HappyWrap26 = HappyWrap26 (CmmParse BoolExpr)+happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn )+happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x)+{-# INLINE happyIn26 #-}+happyOut26 :: (HappyAbsSyn ) -> HappyWrap26+happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut26 #-}+newtype HappyWrap27 = HappyWrap27 (CmmParse BoolExpr)+happyIn27 :: (CmmParse BoolExpr) -> (HappyAbsSyn )+happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x)+{-# INLINE happyIn27 #-}+happyOut27 :: (HappyAbsSyn ) -> HappyWrap27+happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut27 #-}+newtype HappyWrap28 = HappyWrap28 (Safety)+happyIn28 :: (Safety) -> (HappyAbsSyn )+happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x)+{-# INLINE happyIn28 #-}+happyOut28 :: (HappyAbsSyn ) -> HappyWrap28+happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut28 #-}+newtype HappyWrap29 = HappyWrap29 ([GlobalRegUse])+happyIn29 :: ([GlobalRegUse]) -> (HappyAbsSyn )+happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x)+{-# INLINE happyIn29 #-}+happyOut29 :: (HappyAbsSyn ) -> HappyWrap29+happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut29 #-}+newtype HappyWrap30 = HappyWrap30 ([GlobalRegUse])+happyIn30 :: ([GlobalRegUse]) -> (HappyAbsSyn )+happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x)+{-# INLINE happyIn30 #-}+happyOut30 :: (HappyAbsSyn ) -> HappyWrap30+happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut30 #-}+newtype HappyWrap31 = HappyWrap31 (Maybe (Integer,Integer))+happyIn31 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn )+happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x)+{-# INLINE happyIn31 #-}+happyOut31 :: (HappyAbsSyn ) -> HappyWrap31+happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut31 #-}+newtype HappyWrap32 = HappyWrap32 ([CmmParse ([Integer],Either BlockId (CmmParse ()))])+happyIn32 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn )+happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x)+{-# INLINE happyIn32 #-}+happyOut32 :: (HappyAbsSyn ) -> HappyWrap32+happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut32 #-}+newtype HappyWrap33 = HappyWrap33 (CmmParse ([Integer],Either BlockId (CmmParse ())))+happyIn33 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn )+happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x)+{-# INLINE happyIn33 #-}+happyOut33 :: (HappyAbsSyn ) -> HappyWrap33+happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut33 #-}+newtype HappyWrap34 = HappyWrap34 (CmmParse (Either BlockId (CmmParse ())))+happyIn34 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn )+happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x)+{-# INLINE happyIn34 #-}+happyOut34 :: (HappyAbsSyn ) -> HappyWrap34+happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut34 #-}+newtype HappyWrap35 = HappyWrap35 ([Integer])+happyIn35 :: ([Integer]) -> (HappyAbsSyn )+happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x)+{-# INLINE happyIn35 #-}+happyOut35 :: (HappyAbsSyn ) -> HappyWrap35+happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut35 #-}+newtype HappyWrap36 = HappyWrap36 (Maybe (CmmParse ()))+happyIn36 :: (Maybe (CmmParse ())) -> (HappyAbsSyn )+happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x)+{-# INLINE happyIn36 #-}+happyOut36 :: (HappyAbsSyn ) -> HappyWrap36+happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut36 #-}+newtype HappyWrap37 = HappyWrap37 (CmmParse ())+happyIn37 :: (CmmParse ()) -> (HappyAbsSyn )+happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x)+{-# INLINE happyIn37 #-}+happyOut37 :: (HappyAbsSyn ) -> HappyWrap37+happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut37 #-}+newtype HappyWrap38 = HappyWrap38 (Maybe Bool)+happyIn38 :: (Maybe Bool) -> (HappyAbsSyn )+happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x)+{-# INLINE happyIn38 #-}+happyOut38 :: (HappyAbsSyn ) -> HappyWrap38+happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut38 #-}+newtype HappyWrap39 = HappyWrap39 (CmmParse CmmExpr)+happyIn39 :: (CmmParse CmmExpr) -> (HappyAbsSyn )+happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x)+{-# INLINE happyIn39 #-}+happyOut39 :: (HappyAbsSyn ) -> HappyWrap39+happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut39 #-}+newtype HappyWrap40 = HappyWrap40 (CmmParse CmmExpr)+happyIn40 :: (CmmParse CmmExpr) -> (HappyAbsSyn )+happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x)+{-# INLINE happyIn40 #-}+happyOut40 :: (HappyAbsSyn ) -> HappyWrap40+happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut40 #-}+newtype HappyWrap41 = HappyWrap41 (CmmType)+happyIn41 :: (CmmType) -> (HappyAbsSyn )+happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x)+{-# INLINE happyIn41 #-}+happyOut41 :: (HappyAbsSyn ) -> HappyWrap41+happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut41 #-}+newtype HappyWrap42 = HappyWrap42 ([CmmParse (CmmExpr, ForeignHint)])+happyIn42 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn )+happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x)+{-# INLINE happyIn42 #-}+happyOut42 :: (HappyAbsSyn ) -> HappyWrap42+happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut42 #-}+newtype HappyWrap43 = HappyWrap43 ([CmmParse (CmmExpr, ForeignHint)])+happyIn43 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn )+happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x)+{-# INLINE happyIn43 #-}+happyOut43 :: (HappyAbsSyn ) -> HappyWrap43+happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut43 #-}+newtype HappyWrap44 = HappyWrap44 (CmmParse (CmmExpr, ForeignHint))+happyIn44 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn )+happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x)+{-# INLINE happyIn44 #-}+happyOut44 :: (HappyAbsSyn ) -> HappyWrap44+happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut44 #-}+newtype HappyWrap45 = HappyWrap45 ([CmmParse CmmExpr])+happyIn45 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )+happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x)+{-# INLINE happyIn45 #-}+happyOut45 :: (HappyAbsSyn ) -> HappyWrap45+happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut45 #-}+newtype HappyWrap46 = HappyWrap46 ([CmmParse CmmExpr])+happyIn46 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )+happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x)+{-# INLINE happyIn46 #-}+happyOut46 :: (HappyAbsSyn ) -> HappyWrap46+happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut46 #-}+newtype HappyWrap47 = HappyWrap47 (CmmParse CmmExpr)+happyIn47 :: (CmmParse CmmExpr) -> (HappyAbsSyn )+happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x)+{-# INLINE happyIn47 #-}+happyOut47 :: (HappyAbsSyn ) -> HappyWrap47+happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut47 #-}+newtype HappyWrap48 = HappyWrap48 ([CmmParse (LocalReg, ForeignHint)])+happyIn48 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn )+happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x)+{-# INLINE happyIn48 #-}+happyOut48 :: (HappyAbsSyn ) -> HappyWrap48+happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut48 #-}+newtype HappyWrap49 = HappyWrap49 ([CmmParse (LocalReg, ForeignHint)])+happyIn49 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn )+happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x)+{-# INLINE happyIn49 #-}+happyOut49 :: (HappyAbsSyn ) -> HappyWrap49+happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut49 #-}+newtype HappyWrap50 = HappyWrap50 (CmmParse (LocalReg, ForeignHint))+happyIn50 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn )+happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x)+{-# INLINE happyIn50 #-}+happyOut50 :: (HappyAbsSyn ) -> HappyWrap50+happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut50 #-}+newtype HappyWrap51 = HappyWrap51 (CmmParse LocalReg)+happyIn51 :: (CmmParse LocalReg) -> (HappyAbsSyn )+happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x)+{-# INLINE happyIn51 #-}+happyOut51 :: (HappyAbsSyn ) -> HappyWrap51+happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut51 #-}+newtype HappyWrap52 = HappyWrap52 (CmmParse CmmReg)+happyIn52 :: (CmmParse CmmReg) -> (HappyAbsSyn )+happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x)+{-# INLINE happyIn52 #-}+happyOut52 :: (HappyAbsSyn ) -> HappyWrap52+happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut52 #-}+newtype HappyWrap53 = HappyWrap53 (Maybe [CmmParse LocalReg])+happyIn53 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn )+happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x)+{-# INLINE happyIn53 #-}+happyOut53 :: (HappyAbsSyn ) -> HappyWrap53+happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut53 #-}+newtype HappyWrap54 = HappyWrap54 ([CmmParse LocalReg])+happyIn54 :: ([CmmParse LocalReg]) -> (HappyAbsSyn )+happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x)+{-# INLINE happyIn54 #-}+happyOut54 :: (HappyAbsSyn ) -> HappyWrap54+happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut54 #-}+newtype HappyWrap55 = HappyWrap55 ([CmmParse LocalReg])+happyIn55 :: ([CmmParse LocalReg]) -> (HappyAbsSyn )+happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x)+{-# INLINE happyIn55 #-}+happyOut55 :: (HappyAbsSyn ) -> HappyWrap55+happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut55 #-}+newtype HappyWrap56 = HappyWrap56 (CmmParse LocalReg)+happyIn56 :: (CmmParse LocalReg) -> (HappyAbsSyn )+happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x)+{-# INLINE happyIn56 #-}+happyOut56 :: (HappyAbsSyn ) -> HappyWrap56+happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut56 #-}+newtype HappyWrap57 = HappyWrap57 (CmmType)+happyIn57 :: (CmmType) -> (HappyAbsSyn )+happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x)+{-# INLINE happyIn57 #-}+happyOut57 :: (HappyAbsSyn ) -> HappyWrap57+happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut57 #-}+newtype HappyWrap58 = HappyWrap58 (CmmType)+happyIn58 :: (CmmType) -> (HappyAbsSyn )+happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x)+{-# INLINE happyIn58 #-}+happyOut58 :: (HappyAbsSyn ) -> HappyWrap58+happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut58 #-}+happyInTok :: (Located CmmToken) -> (HappyAbsSyn )+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken)+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyExpList :: HappyAddr+happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x06\x20\xf8\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\xc0\x03\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x01\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x08\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x1f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x0f\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x07\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x7f\xf8\x01\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\xc0\x03\x7a\x6c\xfe\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++{-# NOINLINE happyExpListPerState #-}+happyExpListPerState st =+    token_strs_expected+  where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","mem_ordering","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","cond_likely","expr","expr0","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'True'","'False'","'likely'","'relaxed'","'acquire'","'release'","'seq_cst'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'vec128'","'vec256'","'vec512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","GP_ARG_REGS","SCALAR_ARG_REGS","V16_ARG_REGS","V32_ARG_REGS","V64_ARG_REGS","%eof"]+        bit_start = st Prelude.* 144+        bit_end = (st Prelude.+ 1) Prelude.* 144+        read_bit = readArrayBit happyExpList+        bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]+        bits_indexed = Prelude.zip bits [0..143]+        token_strs_expected = Prelude.concatMap f bits_indexed+        f (Prelude.False, _) = []+        f (Prelude.True, nr) = [token_strs Prelude.!! nr]++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x72\x01\x00\x00\xae\xff\x72\x01\x00\x00\x00\x00\xec\xff\x00\x00\xe7\xff\x00\x00\x3c\x00\x40\x00\x4c\x00\x4f\x00\x64\x00\x73\x00\x31\x00\x33\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xa8\x00\x57\x00\x00\x00\x74\x00\xd3\x00\xd8\x00\xed\x00\xd1\x00\xdb\x00\xdd\x00\xdf\x00\xe4\x00\xe6\x00\x37\x01\x34\x01\x00\x00\x00\x00\xa9\x00\xe6\x04\x00\x00\x39\x01\x3d\x01\x43\x01\x45\x01\x48\x01\x4c\x01\x19\x01\x00\x00\x1d\x01\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x95\x01\x6c\x01\x00\x00\x24\x01\x26\x01\x2d\x01\x31\x01\x33\x01\x40\x01\x69\x01\x00\x00\x74\x01\x46\x01\x00\x00\x00\x00\x50\x00\x93\x01\x50\x00\x50\x00\xe6\x04\x47\x00\x8f\x01\xfd\xff\x00\x00\xd9\x04\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\xa2\x00\xb1\x00\xb1\x00\xb1\x00\xa3\x01\xa6\x01\xa5\x01\x61\x01\x00\x00\x3f\x00\x00\x00\xe6\x04\x00\x00\x99\x01\x9b\x01\x44\x00\xb1\x01\xb8\x01\xb9\x01\x00\x00\xd2\x01\x95\x01\x1a\x00\xe0\x01\xdf\x01\xe2\x01\x0c\x00\x9e\x01\x9f\x01\x1a\x02\xde\x01\x00\x00\x10\x00\x00\x00\xb1\x00\xb1\x00\xa2\x01\xb1\x00\x00\x00\x00\x00\x00\x00\xd1\x01\xd1\x01\x00\x00\x00\x00\xa7\x01\xa8\x01\xae\x01\x00\x00\xe6\x04\xaf\x01\xed\x01\xb1\x00\x00\x00\x00\x00\xb1\x00\xf0\x01\xf6\x01\xb1\x00\xb1\x00\xb7\x01\xb1\x00\x67\x03\xfc\xff\x1f\x03\x38\x00\x00\x00\xa3\x03\xa2\x00\xa2\x00\xfe\x01\xff\x01\xf4\x01\x00\x00\x07\x02\x00\x00\xc9\x01\xb1\x00\x80\x00\xca\x01\x09\x02\x18\x02\x00\x00\x00\x00\x00\x00\xb1\x00\xd4\x01\xd5\x01\xe6\x04\x2e\x02\x84\x02\x00\x00\x15\x02\x65\x00\x1c\x02\x00\x00\x00\x00\x8e\x00\x29\x02\x50\x03\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x03\x00\x0e\x02\xa2\x00\xa2\x00\xb1\x00\x31\x02\xff\xff\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x7b\x03\x3d\x02\x00\x00\x2f\x02\x6a\x02\x3e\x02\xca\x00\x00\x00\x51\x02\x8f\x03\x58\x02\x45\x02\x64\x02\x6b\x02\x6c\x02\x6d\x02\x00\x00\xe6\x04\x00\x00\x12\x00\x67\x02\x00\x00\x50\x03\xb1\x00\x7b\x02\x95\x02\x22\x02\x00\x00\x96\x02\x85\x02\x4f\x02\x9f\x02\xa4\x02\xa5\x02\xa0\x02\xa7\x02\xaa\x02\xb1\x00\xb1\x00\x9e\x02\x00\x00\xb1\x00\x00\x00\x68\x02\x66\x02\x70\x02\x00\x00\x71\x02\x00\x00\x00\x00\xb5\x02\xab\x02\xa3\x03\x00\x00\xdc\x00\x90\x02\x73\x02\xc1\x02\xb1\x00\xdc\x00\x00\x00\xc7\x02\xca\x02\x00\x00\xbb\x02\x00\x00\xd1\x02\xc2\x00\xba\x02\xda\x02\x50\x00\x8f\x02\xb7\x03\xb7\x03\xb7\x03\xb7\x03\x6b\x01\x6b\x01\xb7\x03\xb7\x03\x61\x00\x98\x01\xb6\x01\x12\x00\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x02\xdf\x02\x00\x00\xe4\x02\xe3\x02\x00\x00\xed\x02\xb8\x02\xe2\x02\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xef\x02\xe3\x00\xf3\x02\xb6\x02\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\xf0\x02\xc4\x02\xb9\x02\xbe\x02\x00\x00\xc2\x02\x00\x00\xee\x02\xf9\x02\xfa\x02\xfb\x02\xfd\x02\x00\x00\xd2\x02\xec\x02\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x02\xcf\x02\xd9\x02\xdb\x02\x00\x00\x1c\x03\x09\x03\x00\x00\x24\x03\x29\x03\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x2d\x03\x2e\x03\x08\x03\x38\x03\x42\x02\x06\x03\x1e\x00\x30\x03\x00\x00\x2a\x03\x39\x03\xb1\x00\x56\x02\x40\x03\xb1\x00\xf5\x02\x00\x00\x4c\x03\x00\x00\xb1\x00\x00\x00\x4d\x03\x00\x00\x00\x00\x47\x03\x4e\x03\x00\x00\x0a\x03\x04\x00\x44\x03\x45\x03\x51\x03\x5e\x03\x00\x00\x1a\x03\x1b\x03\x23\x03\x00\x00\x50\x00\x25\x03\x00\x00\x50\x00\x7c\x03\x50\x00\x75\x03\x00\x00\x48\x03\x00\x00\x00\x00\x00\x00\x00\x00\x7e\x03\x57\x03\x91\x03\x90\x03\x00\x00\xa2\x03\xa5\x03\xa4\x03\xb1\x03\xa6\x03\xb8\x03\x6c\x03\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x03\xb3\x03\x00\x00\x81\x03\xc5\x03\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x1b\x01\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\xda\x03\x00\x00\xdc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x03\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x03\x00\x00\x00\x00\xe5\x03\x97\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x03\x00\x00\xf3\x03\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x22\x01\x2a\x01\xee\x00\x00\x00\x00\x00\xea\x03\x00\x00\x05\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x7f\x00\x1c\x04\x25\x04\x00\x00\xe6\x03\x00\x00\xef\x03\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x2b\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x04\x34\x04\x00\x00\x3a\x04\x00\x00\x00\x00\x00\x00\xde\x03\xdf\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x02\x00\x00\x00\x00\x40\x04\x00\x00\x00\x00\xea\x01\x00\x00\x00\x00\xba\x03\x49\x04\x00\x00\xbd\x03\x00\x00\xec\x03\x00\x00\xee\x03\x00\x00\x00\x00\xcd\x01\xd6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x03\x4e\x04\x60\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x04\x00\x00\xf9\x03\x02\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x04\x63\x04\x66\x04\x6c\x04\x72\x04\x7b\x04\x80\x04\x89\x04\x8f\x04\x95\x04\x98\x04\x9e\x04\xa4\x04\xad\x04\xb2\x04\xbb\x04\x00\x00\x00\x00\xe5\x01\xee\x01\xd1\x03\x00\x00\xfd\x03\xd4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x01\x00\x00\x00\x00\x12\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x04\xca\x04\x00\x00\x00\x00\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x04\x13\x01\x00\x00\x00\x00\x17\x04\x16\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x03\xb4\x03\xd0\x04\xd6\x04\xdf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x01\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x62\x01\x06\x04\x00\x00\x15\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\x00\x00\x00\x00\x08\x04\x0f\x04\x00\x00\x00\x00\x00\x00\x0e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x04\x10\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x01\x00\x00\x00\x00\x5c\x01\x00\x00\x64\x01\x00\x00\x00\x00\x21\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int#+happyAdjustOffset off = off++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x53\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\xff\x52\xff\x51\xff\x50\xff\x4f\xff\x4e\xff\x4d\xff\x4c\xff\x4b\xff\x4a\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xff\xea\xff\xfd\xff\x00\x00\x5a\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\xff\x57\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\xbb\xff\xb9\xff\xba\xff\xb8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\x5d\xff\x5e\xff\x55\xff\x58\xff\x5b\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x53\xff\x00\x00\x54\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7e\xff\x7a\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x67\xff\x68\xff\x7b\xff\x74\xff\x74\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x5a\xff\x00\x00\x00\x00\x00\x00\x56\xff\xd2\xff\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x00\x00\x92\xff\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x64\xff\x61\xff\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\xff\x00\x00\x63\xff\x00\x00\xc9\xff\xae\xff\x00\x00\xb2\xff\xb1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x00\x00\x00\x00\x6c\xff\xa9\xff\xa8\xff\xa7\xff\xa6\xff\xa5\xff\x00\x00\x6a\xff\x00\x00\x6b\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\xff\x00\x00\x7d\xff\x80\xff\x00\x00\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\xff\x6c\xff\x73\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbc\xff\xb6\xff\xb7\xff\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x00\x00\xaa\xff\xa3\xff\xc7\xff\x00\x00\xaf\xff\xb0\xff\x00\x00\xe0\xff\x00\x00\x83\xff\x82\xff\x85\xff\x87\xff\x8b\xff\x8c\xff\x84\xff\x86\xff\x88\xff\x89\xff\x8a\xff\x8d\xff\x8e\xff\x8f\xff\x90\xff\x91\xff\xad\xff\x65\xff\x62\xff\x00\x00\x00\x00\xd1\xff\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x6c\xff\x72\xff\x00\x00\x00\x00\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa4\xff\x00\x00\xbf\xff\x69\xff\xc8\xff\x00\x00\x97\xff\x9f\xff\x00\x00\xc0\xff\x00\x00\xcb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\xff\x00\x00\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x7f\xff\x79\xff\x78\xff\x76\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbd\xff\x00\x00\x9a\xff\x9e\xff\x00\x00\x00\x00\xa1\xff\xc6\xff\x6c\xff\xa2\xff\xc4\xff\x00\x00\x00\x00\x96\xff\x00\x00\x00\x00\x00\x00\x6e\xff\x00\x00\x71\xff\x70\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\xff\x6d\xff\x00\x00\xce\xff\x6c\xff\xc1\xff\x00\x00\x93\xff\x94\xff\x00\x00\x00\x00\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x9d\xff\xe0\xff\x00\x00\x99\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xd0\xff\xb4\xff\xab\xff\x6f\xff\xcc\xff\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\x9c\xff\x9b\xff\x98\xff\x95\xff\xc3\xff\xb3\xff\xcd\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\xe5\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x05\x00\x05\x00\x07\x00\x56\x00\x06\x00\x03\x00\x03\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x06\x00\x04\x00\x05\x00\x05\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x02\x00\x29\x00\x0c\x00\x0d\x00\x0e\x00\x07\x00\x12\x00\x04\x00\x05\x00\x0b\x00\x3a\x00\x17\x00\x0e\x00\x0f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4d\x00\x32\x00\x32\x00\x24\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x2b\x00\x07\x00\x01\x00\x4d\x00\x4e\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x35\x00\x36\x00\x4d\x00\x4c\x00\x08\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x02\x00\x07\x00\x35\x00\x36\x00\x07\x00\x07\x00\x20\x00\x21\x00\x16\x00\x4f\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x02\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x07\x00\x1a\x00\x1b\x00\x36\x00\x4d\x00\x38\x00\x30\x00\x4e\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x07\x00\x38\x00\x39\x00\x3a\x00\x0b\x00\x3c\x00\x3d\x00\x0e\x00\x0f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x33\x00\x34\x00\x35\x00\x36\x00\x23\x00\x24\x00\x4d\x00\x25\x00\x26\x00\x27\x00\x28\x00\x07\x00\x2b\x00\x02\x00\x03\x00\x0b\x00\x20\x00\x21\x00\x0e\x00\x0f\x00\x4d\x00\x4e\x00\x35\x00\x36\x00\x0b\x00\x0c\x00\x07\x00\x17\x00\x02\x00\x10\x00\x0b\x00\x12\x00\x16\x00\x0e\x00\x0f\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x2d\x00\x2e\x00\x2f\x00\x0b\x00\x03\x00\x2c\x00\x0e\x00\x0f\x00\x02\x00\x30\x00\x4c\x00\x4d\x00\x02\x00\x03\x00\x35\x00\x36\x00\x20\x00\x21\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x07\x00\x16\x00\x3a\x00\x22\x00\x23\x00\x0d\x00\x0e\x00\x0e\x00\x0d\x00\x0e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x00\x00\x01\x00\x02\x00\x4d\x00\x00\x00\x01\x00\x02\x00\x07\x00\x35\x00\x36\x00\x0a\x00\x07\x00\x0c\x00\x4d\x00\x0a\x00\x4d\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x1c\x00\x1d\x00\x4d\x00\x10\x00\x4d\x00\x12\x00\x0b\x00\x0c\x00\x35\x00\x36\x00\x02\x00\x10\x00\x07\x00\x12\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x35\x00\x36\x00\x2c\x00\x16\x00\x35\x00\x36\x00\x30\x00\x16\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x16\x00\x30\x00\x16\x00\x0b\x00\x0c\x00\x16\x00\x35\x00\x36\x00\x10\x00\x16\x00\x12\x00\x0b\x00\x0c\x00\x4d\x00\x0b\x00\x0c\x00\x10\x00\x4d\x00\x12\x00\x10\x00\x01\x00\x12\x00\x0b\x00\x0c\x00\x08\x00\x12\x00\x4f\x00\x10\x00\x4f\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x4f\x00\x2c\x00\x1c\x00\x1d\x00\x4f\x00\x30\x00\x4f\x00\x23\x00\x24\x00\x2c\x00\x35\x00\x36\x00\x2c\x00\x30\x00\x16\x00\x2b\x00\x30\x00\x4d\x00\x35\x00\x36\x00\x2c\x00\x35\x00\x36\x00\x4d\x00\x30\x00\x35\x00\x36\x00\x04\x00\x09\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x4d\x00\x30\x00\x31\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x07\x00\x05\x00\x07\x00\x4c\x00\x3c\x00\x16\x00\x13\x00\x16\x00\x1a\x00\x1b\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x29\x00\x4d\x00\x23\x00\x24\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x16\x00\x2b\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x04\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x05\x00\x07\x00\x05\x00\x0a\x00\x2b\x00\x19\x00\x4d\x00\x16\x00\x17\x00\x4f\x00\x4d\x00\x23\x00\x24\x00\x02\x00\x35\x00\x36\x00\x08\x00\x4f\x00\x4f\x00\x2b\x00\x23\x00\x24\x00\x16\x00\x17\x00\x4f\x00\x4f\x00\x09\x00\x02\x00\x2b\x00\x35\x00\x36\x00\x16\x00\x17\x00\x4f\x00\x08\x00\x23\x00\x24\x00\x16\x00\x35\x00\x36\x00\x23\x00\x24\x00\x08\x00\x2b\x00\x23\x00\x24\x00\x29\x00\x2a\x00\x2b\x00\x4d\x00\x0e\x00\x4e\x00\x2b\x00\x35\x00\x36\x00\x02\x00\x05\x00\x09\x00\x35\x00\x36\x00\x4d\x00\x4d\x00\x35\x00\x36\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x24\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x08\x00\x18\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x03\x00\x07\x00\x4d\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x06\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x06\x00\x02\x00\x02\x00\x08\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x0a\x00\x4f\x00\x4e\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4f\x00\x16\x00\x4f\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3e\x00\x08\x00\x06\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x08\x00\x20\x00\x01\x00\x4d\x00\x34\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x05\x00\x07\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x04\x00\x07\x00\x02\x00\x06\x00\x3e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4c\x00\x3f\x00\x16\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4f\x00\x4c\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4e\x00\x01\x00\x4f\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x4e\x00\x04\x00\x4e\x00\x01\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x2f\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x08\x00\x02\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x03\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x4f\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4e\x00\x4e\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x4e\x00\x4d\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x37\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x3b\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x04\x00\x02\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x4e\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x16\x00\x4f\x00\x4f\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x23\x00\x24\x00\x16\x00\x26\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\x08\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\x0f\x00\x0f\x00\x31\x00\x09\x00\x35\x00\x36\x00\x0f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x03\x00\x23\x00\x24\x00\x0f\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x11\x00\x1b\x00\x06\x00\x25\x00\x25\x00\x19\x00\x35\x00\x36\x00\x2f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x14\x00\x23\x00\x24\x00\x22\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x1a\x00\x06\x00\x30\x00\x06\x00\x1a\x00\x09\x00\x35\x00\x36\x00\x09\x00\x35\x00\x36\x00\x23\x00\x24\x00\x20\x00\x1f\x00\x11\x00\x18\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x21\x00\x1e\x00\x27\x00\x28\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\x15\x00\x29\x00\x2a\x00\x2b\x00\x23\x00\x24\x00\x1f\x00\x35\x00\x36\x00\x23\x00\x24\x00\x2a\x00\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\x23\x00\x24\x00\xff\xff\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x23\x00\x24\x00\x2b\x00\x35\x00\x36\x00\xff\xff\x35\x00\x36\x00\x2b\x00\x23\x00\x24\x00\xff\xff\x35\x00\x36\x00\x23\x00\x24\x00\xff\xff\x2b\x00\x35\x00\x36\x00\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\xff\xff\x4d\x00\x4e\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\xda\x00\xad\x00\xdb\x00\xff\xff\x21\x01\x28\x01\xa2\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x00\x01\x73\x00\x74\x00\xf9\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x81\x00\x21\x00\xc4\x00\xc5\x00\xc6\x00\x82\x00\xfa\x00\x8a\x00\x74\x00\x83\x00\x2f\x00\xfb\x00\x84\x00\x85\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x26\x00\x29\x01\xa3\x01\x68\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x7e\x00\xd5\x00\x96\x00\x22\x00\x23\x00\x2c\x00\x75\x00\x76\x00\x97\x00\x2b\x00\x7f\x00\x09\x00\x26\x00\x22\x01\x90\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\x59\x00\x2a\x00\x75\x00\x76\x00\x29\x00\x5a\x00\xd6\x00\xd7\x00\x91\x00\x01\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x28\x00\x8c\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x78\x01\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x79\x01\x27\x00\xce\x00\xcf\x00\xaf\x00\x26\x00\xb0\x00\x11\x00\x24\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x66\xff\x82\x00\x66\xff\x63\x00\x64\x00\x83\x00\x13\x00\x65\x00\x84\x00\x85\x00\x66\x00\x67\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x68\x00\x69\x00\x94\x00\x4c\x00\x4d\x00\x09\x00\x9f\x00\x7d\x00\x3e\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa4\x00\x7e\x00\x50\x00\x51\x00\x83\x00\xd6\x00\xd7\x00\x84\x00\x85\x00\xab\x00\xac\x00\x7f\x00\x09\x00\x51\x00\x52\x00\x82\x00\xa5\x00\x40\x00\x53\x00\x83\x00\x54\x00\x3f\x00\x84\x00\x85\x00\x3d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3b\x01\xa7\x00\xa8\x00\x83\x00\x3c\x00\x55\x00\x84\x00\x85\x00\x3b\x00\x56\x00\x68\x00\x1e\x01\x50\x00\x51\x00\x57\x00\x09\x00\xd6\x00\xd7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x82\x00\x3a\x00\x17\x01\x7c\x01\x7d\x01\x1e\x00\x1f\x00\x84\x00\x40\x00\x1f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x02\x00\x03\x00\x04\x00\x39\x00\x2f\x00\x03\x00\x04\x00\x05\x00\xb0\x00\x09\x00\x06\x00\x05\x00\x07\x00\x38\x00\x06\x00\x37\x00\x07\x00\x36\x00\xb2\x00\x52\x00\x55\x01\x56\x01\x35\x00\x53\x00\x34\x00\x54\x00\xb1\x00\x52\x00\x3f\x01\x09\x00\x33\x00\x53\x00\x32\x00\x54\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x0b\x01\x09\x00\x55\x00\x4a\x00\x08\x00\x09\x00\x56\x00\x49\x00\x08\x00\x09\x00\x55\x00\x57\x00\x09\x00\x48\x00\x56\x00\x47\x00\x4b\x01\x52\x00\x46\x00\x57\x00\x09\x00\x53\x00\x45\x00\x54\x00\xb5\x01\x52\x00\x26\x00\xb3\x01\x52\x00\x53\x00\x43\x00\x54\x00\x53\x00\x73\x00\x54\x00\xb1\x01\x52\x00\x6c\x00\xb7\x00\x72\x00\x53\x00\x71\x00\x54\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x70\x00\x55\x00\x73\x01\x56\x01\x6f\x00\x56\x00\x6e\x00\xb8\x00\x7d\x00\x55\x00\x57\x00\x09\x00\x55\x00\x56\x00\x6b\x00\x7e\x00\x56\x00\x6d\x00\x57\x00\x09\x00\x55\x00\x57\x00\x09\x00\x6a\x00\x56\x00\x7f\x00\x09\x00\xb4\x00\xae\x00\x57\x00\x09\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\xa6\x00\x11\x00\x12\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\x9d\x00\x9c\x00\x9a\x00\x99\x00\x13\x00\x94\x00\x14\x01\x92\x00\xce\x00\xcf\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x78\x00\x1e\x00\x15\x01\x7d\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\x8f\x00\x7e\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x8e\x00\x8d\x00\xce\x00\xcf\x00\x7f\x00\x09\x00\xa0\x00\xa1\x00\x8c\x00\x79\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa2\x00\x7d\x00\xc0\x00\xc1\x00\x7c\x00\x7b\x00\x7a\x00\xfc\x00\x7e\x00\xf3\x00\xff\x00\xbf\x00\xa1\x00\xfe\x00\xf6\x00\xc2\x00\x7d\x00\xe9\x00\x7f\x00\x09\x00\xec\x00\xf1\x00\xf0\x00\x7e\x00\xa2\x00\x7d\x00\x25\x01\xa1\x00\xef\x00\xed\x00\xe8\x00\xbf\x00\x7e\x00\x7f\x00\x09\x00\x24\x01\xa1\x00\xe5\x00\xbe\x00\xa2\x00\x7d\x00\xbd\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\xbc\x00\x7e\x00\xa2\x00\x7d\x00\xe9\x00\xe3\x00\x7e\x00\xab\x00\xb6\x00\xb7\x00\x7e\x00\x7f\x00\x09\x00\xfd\x00\xb5\x00\x3d\x01\x7f\x00\x09\x00\x43\x01\x42\x01\x7f\x00\x09\x00\x3b\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x3f\x01\x3a\x01\x27\x01\x23\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x8e\x01\x1b\x01\x18\x01\x1a\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xae\x01\x14\x01\x12\x01\x11\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x10\x01\x19\x01\x0b\x01\x06\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x08\x01\x0f\x01\x0e\x01\x0d\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x3e\x01\xed\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x07\x01\x94\x00\x05\x01\x03\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x61\x01\x02\x01\x68\x01\x67\x01\x66\x01\x65\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x64\x01\x5e\x01\x5f\x01\x5b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x45\x01\x5d\x01\x5c\x01\x5a\x01\x55\x01\x54\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x58\x01\x51\x01\x50\x01\x4f\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6b\x01\x4e\x01\xd6\x00\x4d\x01\x4b\x01\x4a\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x49\x01\x48\x01\x47\x01\x87\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x6a\x01\x7e\x01\x46\x01\x7b\x01\x77\x01\x58\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x22\x01\x76\x01\x70\x01\x6c\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8d\x01\x73\x01\x99\x00\x6f\x01\x6e\x01\x6d\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9c\x01\x98\x01\x9b\x01\x97\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd8\x00\x9a\x01\x96\x01\x99\x01\x95\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x93\x01\x92\x01\x91\x01\x8b\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x8f\x01\x8a\x01\x89\x01\xad\x01\xab\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xa9\x01\xa6\x01\xa7\x01\xa5\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x0a\x01\x73\x01\xa0\x01\x9f\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x9d\x01\x9e\x01\xb9\x01\xb8\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xe1\x00\xb7\x01\xb5\x01\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb1\x01\xb3\x01\xb0\x01\xc3\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x1c\x01\xc2\x01\xc1\x01\xc0\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x94\x00\xbf\x01\xbe\x01\xbd\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbc\x01\xc5\x01\xc6\x01\xbb\x01\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x00\x00\x00\x00\xc9\x01\xba\x01\xc4\x01\xc8\x01\xce\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x01\x7d\x00\xc7\x01\x82\x01\x83\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\xe1\x00\x7d\x00\x2d\x00\xe6\x00\xe3\x00\x7e\x00\xe2\x00\xe3\x00\x7e\x00\x7f\x00\x09\x00\x2c\x00\x24\x00\x30\x00\x4e\x00\x7f\x00\x09\x00\x43\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x41\x00\xe1\x00\x7d\x00\x2c\x00\x23\x01\xe3\x00\x7e\x00\x1e\x01\xe3\x00\x7e\x00\x97\x00\x9a\x00\x92\x00\xf3\x00\xf1\x00\xd8\x00\x7f\x00\x09\x00\xba\x00\x7f\x00\x09\x00\xe1\x00\x7d\x00\x40\x01\xe1\x00\x7d\x00\xd3\x00\x5f\x01\xe3\x00\x7e\x00\x85\x01\xe3\x00\x7e\x00\x1f\x01\x12\x01\x1c\x01\x03\x01\x79\x01\x58\x01\x7f\x00\x09\x00\x51\x01\x7f\x00\x09\x00\xe1\x00\x7d\x00\x74\x01\x71\x01\x70\x01\xa9\x01\x93\x01\xe3\x00\x7e\x00\x81\x01\x7d\x00\x8f\x01\xa0\x01\xab\x01\x84\x01\xe1\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\xae\x01\xa7\x01\xe3\x00\x7e\x00\xe1\x00\x7d\x00\xa3\x01\x7f\x00\x09\x00\x9e\x00\x7d\x00\x52\x01\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x9d\x00\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xf7\x00\x7d\x00\x7e\x00\xf6\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xf4\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\xea\x00\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\xe5\x00\x7d\x00\x00\x00\x7f\x00\x09\x00\xb9\x00\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x43\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x38\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x37\x01\x7d\x00\x7e\x00\x36\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x35\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x34\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x33\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x32\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x31\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x30\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2f\x01\x7d\x00\x7e\x00\x2e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2d\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x2c\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x2b\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x2a\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x29\x01\x7d\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x08\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x62\x01\x7d\x00\x7e\x00\x61\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x80\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x01\x7d\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x7f\x00\x09\x00\x7e\x00\x7e\x01\x7d\x00\x00\x00\x7f\x00\x09\x00\x87\x01\x7d\x00\x00\x00\x7e\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xab\x00\xac\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\xa6\x00\xa7\x00\xa8\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 181) [+	(1 , happyReduce_1),+	(2 , happyReduce_2),+	(3 , happyReduce_3),+	(4 , happyReduce_4),+	(5 , happyReduce_5),+	(6 , happyReduce_6),+	(7 , happyReduce_7),+	(8 , happyReduce_8),+	(9 , happyReduce_9),+	(10 , happyReduce_10),+	(11 , happyReduce_11),+	(12 , happyReduce_12),+	(13 , happyReduce_13),+	(14 , happyReduce_14),+	(15 , happyReduce_15),+	(16 , happyReduce_16),+	(17 , happyReduce_17),+	(18 , happyReduce_18),+	(19 , happyReduce_19),+	(20 , happyReduce_20),+	(21 , happyReduce_21),+	(22 , happyReduce_22),+	(23 , happyReduce_23),+	(24 , happyReduce_24),+	(25 , happyReduce_25),+	(26 , happyReduce_26),+	(27 , happyReduce_27),+	(28 , happyReduce_28),+	(29 , happyReduce_29),+	(30 , happyReduce_30),+	(31 , happyReduce_31),+	(32 , happyReduce_32),+	(33 , happyReduce_33),+	(34 , happyReduce_34),+	(35 , happyReduce_35),+	(36 , happyReduce_36),+	(37 , happyReduce_37),+	(38 , happyReduce_38),+	(39 , happyReduce_39),+	(40 , happyReduce_40),+	(41 , happyReduce_41),+	(42 , happyReduce_42),+	(43 , happyReduce_43),+	(44 , happyReduce_44),+	(45 , happyReduce_45),+	(46 , happyReduce_46),+	(47 , happyReduce_47),+	(48 , happyReduce_48),+	(49 , happyReduce_49),+	(50 , happyReduce_50),+	(51 , happyReduce_51),+	(52 , happyReduce_52),+	(53 , happyReduce_53),+	(54 , happyReduce_54),+	(55 , happyReduce_55),+	(56 , happyReduce_56),+	(57 , happyReduce_57),+	(58 , happyReduce_58),+	(59 , happyReduce_59),+	(60 , happyReduce_60),+	(61 , happyReduce_61),+	(62 , happyReduce_62),+	(63 , happyReduce_63),+	(64 , happyReduce_64),+	(65 , happyReduce_65),+	(66 , happyReduce_66),+	(67 , happyReduce_67),+	(68 , happyReduce_68),+	(69 , happyReduce_69),+	(70 , happyReduce_70),+	(71 , happyReduce_71),+	(72 , happyReduce_72),+	(73 , happyReduce_73),+	(74 , happyReduce_74),+	(75 , happyReduce_75),+	(76 , happyReduce_76),+	(77 , happyReduce_77),+	(78 , happyReduce_78),+	(79 , happyReduce_79),+	(80 , happyReduce_80),+	(81 , happyReduce_81),+	(82 , happyReduce_82),+	(83 , happyReduce_83),+	(84 , happyReduce_84),+	(85 , happyReduce_85),+	(86 , happyReduce_86),+	(87 , happyReduce_87),+	(88 , happyReduce_88),+	(89 , happyReduce_89),+	(90 , happyReduce_90),+	(91 , happyReduce_91),+	(92 , happyReduce_92),+	(93 , happyReduce_93),+	(94 , happyReduce_94),+	(95 , happyReduce_95),+	(96 , happyReduce_96),+	(97 , happyReduce_97),+	(98 , happyReduce_98),+	(99 , happyReduce_99),+	(100 , happyReduce_100),+	(101 , happyReduce_101),+	(102 , happyReduce_102),+	(103 , happyReduce_103),+	(104 , happyReduce_104),+	(105 , happyReduce_105),+	(106 , happyReduce_106),+	(107 , happyReduce_107),+	(108 , happyReduce_108),+	(109 , happyReduce_109),+	(110 , happyReduce_110),+	(111 , happyReduce_111),+	(112 , happyReduce_112),+	(113 , happyReduce_113),+	(114 , happyReduce_114),+	(115 , happyReduce_115),+	(116 , happyReduce_116),+	(117 , happyReduce_117),+	(118 , happyReduce_118),+	(119 , happyReduce_119),+	(120 , happyReduce_120),+	(121 , happyReduce_121),+	(122 , happyReduce_122),+	(123 , happyReduce_123),+	(124 , happyReduce_124),+	(125 , happyReduce_125),+	(126 , happyReduce_126),+	(127 , happyReduce_127),+	(128 , happyReduce_128),+	(129 , happyReduce_129),+	(130 , happyReduce_130),+	(131 , happyReduce_131),+	(132 , happyReduce_132),+	(133 , happyReduce_133),+	(134 , happyReduce_134),+	(135 , happyReduce_135),+	(136 , happyReduce_136),+	(137 , happyReduce_137),+	(138 , happyReduce_138),+	(139 , happyReduce_139),+	(140 , happyReduce_140),+	(141 , happyReduce_141),+	(142 , happyReduce_142),+	(143 , happyReduce_143),+	(144 , happyReduce_144),+	(145 , happyReduce_145),+	(146 , happyReduce_146),+	(147 , happyReduce_147),+	(148 , happyReduce_148),+	(149 , happyReduce_149),+	(150 , happyReduce_150),+	(151 , happyReduce_151),+	(152 , happyReduce_152),+	(153 , happyReduce_153),+	(154 , happyReduce_154),+	(155 , happyReduce_155),+	(156 , happyReduce_156),+	(157 , happyReduce_157),+	(158 , happyReduce_158),+	(159 , happyReduce_159),+	(160 , happyReduce_160),+	(161 , happyReduce_161),+	(162 , happyReduce_162),+	(163 , happyReduce_163),+	(164 , happyReduce_164),+	(165 , happyReduce_165),+	(166 , happyReduce_166),+	(167 , happyReduce_167),+	(168 , happyReduce_168),+	(169 , happyReduce_169),+	(170 , happyReduce_170),+	(171 , happyReduce_171),+	(172 , happyReduce_172),+	(173 , happyReduce_173),+	(174 , happyReduce_174),+	(175 , happyReduce_175),+	(176 , happyReduce_176),+	(177 , happyReduce_177),+	(178 , happyReduce_178),+	(179 , happyReduce_179),+	(180 , happyReduce_180),+	(181 , happyReduce_181)+	]++happy_n_terms = 87 :: Prelude.Int+happy_n_nonterms = 55 :: Prelude.Int++happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_1 = happySpecReduce_0  0# happyReduction_1+happyReduction_1  =  happyIn4+		 (return ()+	)++happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_2 = happySpecReduce_2  0# happyReduction_2+happyReduction_2 happy_x_2+	happy_x_1+	 =  case happyOut5 happy_x_1 of { (HappyWrap5 happy_var_1) -> +	case happyOut4 happy_x_2 of { (HappyWrap4 happy_var_2) -> +	happyIn4+		 (do happy_var_1; happy_var_2+	)}}++happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_3 = happySpecReduce_1  1# happyReduction_3+happyReduction_3 happy_x_1+	 =  case happyOut11 happy_x_1 of { (HappyWrap11 happy_var_1) -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_4 = happySpecReduce_1  1# happyReduction_4+happyReduction_4 happy_x_1+	 =  case happyOut6 happy_x_1 of { (HappyWrap6 happy_var_1) -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_5 = happySpecReduce_1  1# happyReduction_5+happyReduction_5 happy_x_1+	 =  case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> +	happyIn5+		 (happy_var_1+	)}++happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6+happyReduction_6 (happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Name      happy_var_5)) -> +	case happyOut10 happy_x_6 of { (HappyWrap10 happy_var_6) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        lits <- sequence happy_var_6;+                        staticClosure home_unit_id happy_var_3 happy_var_5 (map getLit lits))}}})+	) (\r -> happyReturn (happyIn5 r))++happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_7 = happyReduce 6# 2# happyReduction_7+happyReduction_7 (happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_2 of { (L _ (CmmT_String    happy_var_2)) -> +	case happyOut7 happy_x_4 of { (HappyWrap7 happy_var_4) -> +	case happyOut8 happy_x_5 of { (HappyWrap8 happy_var_5) -> +	happyIn6+		 (do lbl <- happy_var_4;+                     ss <- sequence happy_var_5;+                     code (emitDecl (CmmData (Section (section happy_var_2) lbl) (CmmStaticsRaw lbl (concat ss))))+	) `HappyStk` happyRest}}}++happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8+happyReduction_8 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	( do+                   home_unit_id <- getHomeUnitId+                   liftP $ pure $ do+                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) happy_var_1))})+	) (\r -> happyReturn (happyIn7 r))++happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_9 = happySpecReduce_0  4# happyReduction_9+happyReduction_9  =  happyIn8+		 ([]+	)++happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_10 = happySpecReduce_2  4# happyReduction_10+happyReduction_10 happy_x_2+	happy_x_1+	 =  case happyOut9 happy_x_1 of { (HappyWrap9 happy_var_1) -> +	case happyOut8 happy_x_2 of { (HappyWrap8 happy_var_2) -> +	happyIn8+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_11 = happySpecReduce_3  5# happyReduction_11+happyReduction_11 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	happyIn9+		 (do e <- happy_var_2;+                             return [CmmStaticLit (getLit e)]+	)}++happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_12 = happySpecReduce_2  5# happyReduction_12+happyReduction_12 happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	happyIn9+		 (return [CmmUninitialised+                                                        (widthInBytes (typeWidth happy_var_1))]+	)}++happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_13 = happyReduce 5# 5# happyReduction_13+happyReduction_13 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_4 of { (L _ (CmmT_String    happy_var_4)) -> +	happyIn9+		 (return [mkString happy_var_4]+	) `HappyStk` happyRest}++happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_14 = happyReduce 5# 5# happyReduction_14+happyReduction_14 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_3 of { (L _ (CmmT_Int       happy_var_3)) -> +	happyIn9+		 (return [CmmUninitialised+                                                        (fromIntegral happy_var_3)]+	) `HappyStk` happyRest}++happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_15 = happyReduce 5# 5# happyReduction_15+happyReduction_15 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> +	case happyOutTok happy_x_3 of { (L _ (CmmT_Int       happy_var_3)) -> +	happyIn9+		 (return [CmmUninitialised+                                                (widthInBytes (typeWidth happy_var_1) *+                                                        fromIntegral happy_var_3)]+	) `HappyStk` happyRest}}++happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_16 = happyReduce 5# 5# happyReduction_16+happyReduction_16 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOut10 happy_x_4 of { (HappyWrap10 happy_var_4) -> +	happyIn9+		 (do { lits <- sequence happy_var_4+                ; profile <- getProfile+                     ; return $ map CmmStaticLit $+                        mkStaticClosure profile (mkForeignLabel happy_var_3 ForeignLabelInExternalPackage IsData)+                         -- mkForeignLabel because these are only used+                         -- for CHARLIKE and INTLIKE closures in the RTS.+                        dontCareCCS (map getLit lits) [] [] [] [] }+	) `HappyStk` happyRest}}++happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_17 = happySpecReduce_0  6# happyReduction_17+happyReduction_17  =  happyIn10+		 ([]+	)++happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_18 = happySpecReduce_3  6# happyReduction_18+happyReduction_18 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut10 happy_x_3 of { (HappyWrap10 happy_var_3) -> +	happyIn10+		 (happy_var_2 : happy_var_3+	)}}++happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_19 = happyReduce 4# 7# happyReduction_19+happyReduction_19 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut14 happy_x_1 of { (HappyWrap14 happy_var_1) -> +	case happyOut12 happy_x_2 of { (HappyWrap12 happy_var_2) -> +	case happyOut53 happy_x_3 of { (HappyWrap53 happy_var_3) -> +	case happyOut13 happy_x_4 of { (HappyWrap13 happy_var_4) -> +	happyIn11+		 (do ((entry_ret_label, info, stk_formals, formals), agraph) <-+                       getCodeScoped $ loopDecls $ do {+                         (entry_ret_label, info, stk_formals) <- happy_var_1;+                         platform <- getPlatform;+                         ctx      <- getContext;+                         formals <- sequence (fromMaybe [] happy_var_3);+                         withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label))+                           happy_var_4;+                         return (entry_ret_label, info, stk_formals, formals) }+                     let do_layout = isJust happy_var_3+                     code (emitProcWithStackFrame happy_var_2 info+                                entry_ret_label stk_formals formals agraph+                                do_layout )+	) `HappyStk` happyRest}}}}++happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_20 = happySpecReduce_0  8# happyReduction_20+happyReduction_20  =  happyIn12+		 (NativeNodeCall+	)++happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_21 = happySpecReduce_1  8# happyReduction_21+happyReduction_21 happy_x_1+	 =  happyIn12+		 (NativeReturn+	)++happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_22 = happySpecReduce_1  9# happyReduction_22+happyReduction_22 happy_x_1+	 =  happyIn13+		 (return ()+	)++happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_23 = happySpecReduce_3  9# happyReduction_23+happyReduction_23 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn13+		 (withSourceNote happy_var_1 happy_var_3 happy_var_2+	)}}}++happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24+happyReduction_24 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	( do+                     home_unit_id <- getHomeUnitId+                     liftP $ pure $ do+                       newFunctionName happy_var_1 home_unit_id+                       return (mkCmmCodeLabel home_unit_id happy_var_1, Nothing, []))})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25+happyReduction_25 (happy_x_14 `HappyStk`+	happy_x_13 `HappyStk`+	happy_x_12 `HappyStk`+	happy_x_11 `HappyStk`+	happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	case happyOutTok happy_x_7 of { (L _ (CmmT_Int       happy_var_7)) -> +	case happyOutTok happy_x_9 of { (L _ (CmmT_Int       happy_var_9)) -> +	case happyOutTok happy_x_11 of { (L _ (CmmT_String    happy_var_11)) -> +	case happyOutTok happy_x_13 of { (L _ (CmmT_String    happy_var_13)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile happy_var_11 happy_var_13+                            rep  = mkRTSRep (fromIntegral happy_var_9) $+                                     mkHeapRep profile False (fromIntegral happy_var_5)+                                                     (fromIntegral happy_var_7) Thunk+                                -- not really Thunk, but that makes the info table+                                -- we want.+                        return (mkCmmEntryLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []))}}}}}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_26 = happyMonadReduce 18# 10# happyReduction_26+happyReduction_26 (happy_x_18 `HappyStk`+	happy_x_17 `HappyStk`+	happy_x_16 `HappyStk`+	happy_x_15 `HappyStk`+	happy_x_14 `HappyStk`+	happy_x_13 `HappyStk`+	happy_x_12 `HappyStk`+	happy_x_11 `HappyStk`+	happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	case happyOutTok happy_x_7 of { (L _ (CmmT_Int       happy_var_7)) -> +	case happyOutTok happy_x_9 of { (L _ (CmmT_Int       happy_var_9)) -> +	case happyOutTok happy_x_11 of { (L _ (CmmT_String    happy_var_11)) -> +	case happyOutTok happy_x_13 of { (L _ (CmmT_String    happy_var_13)) -> +	case happyOutTok happy_x_15 of { (L _ (CmmT_Int       happy_var_15)) -> +	case happyOutTok happy_x_17 of { (L _ (CmmT_Int       happy_var_17)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile happy_var_11 happy_var_13+                            ty   = Fun (fromIntegral happy_var_15) (ArgSpec (fromIntegral happy_var_17))+                            rep = mkRTSRep (fromIntegral happy_var_9) $+                                      mkHeapRep profile False (fromIntegral happy_var_5)+                                                      (fromIntegral happy_var_7) ty+                        return (mkCmmEntryLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []))}}}}}}}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27+happyReduction_27 (happy_x_16 `HappyStk`+	happy_x_15 `HappyStk`+	happy_x_14 `HappyStk`+	happy_x_13 `HappyStk`+	happy_x_12 `HappyStk`+	happy_x_11 `HappyStk`+	happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	case happyOutTok happy_x_7 of { (L _ (CmmT_Int       happy_var_7)) -> +	case happyOutTok happy_x_9 of { (L _ (CmmT_Int       happy_var_9)) -> +	case happyOutTok happy_x_11 of { (L _ (CmmT_Int       happy_var_11)) -> +	case happyOutTok happy_x_13 of { (L _ (CmmT_String    happy_var_13)) -> +	case happyOutTok happy_x_15 of { (L _ (CmmT_String    happy_var_15)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile happy_var_13 happy_var_15+                            ty  = Constr (fromIntegral happy_var_9)  -- Tag+                                         (BS8.pack happy_var_13)+                            rep = mkRTSRep (fromIntegral happy_var_11) $+                                    mkHeapRep profile False (fromIntegral happy_var_5)+                                                    (fromIntegral happy_var_7) ty+                        return (mkCmmEntryLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },+                                []))}}}}}}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28+happyReduction_28 (happy_x_12 `HappyStk`+	happy_x_11 `HappyStk`+	happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	case happyOutTok happy_x_7 of { (L _ (CmmT_Int       happy_var_7)) -> +	case happyOutTok happy_x_9 of { (L _ (CmmT_String    happy_var_9)) -> +	case happyOutTok happy_x_11 of { (L _ (CmmT_String    happy_var_11)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile happy_var_9 happy_var_11+                            ty  = ThunkSelector (fromIntegral happy_var_5)+                            rep = mkRTSRep (fromIntegral happy_var_7) $+                                     mkHeapRep profile False 0 0 ty+                        return (mkCmmEntryLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []))}}}}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29+happyReduction_29 (happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        let prof = NoProfilingInfo+                            rep  = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep []+                        return (mkCmmRetLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []))}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30+happyReduction_30 (happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Int       happy_var_5)) -> +	case happyOut54 happy_x_7 of { (HappyWrap54 happy_var_7) -> +	( do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        platform <- getPlatform+                        live <- sequence happy_var_7+                        let prof = NoProfilingInfo+                            -- drop one for the info pointer+                            bitmap = mkLiveness platform (drop 1 live)+                            rep  = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap+                        return (mkCmmRetLabel home_unit_id happy_var_3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                live))}}})+	) (\r -> happyReturn (happyIn14 r))++happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_31 = happySpecReduce_0  11# happyReduction_31+happyReduction_31  =  happyIn15+		 (return ()+	)++happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_32 = happySpecReduce_2  11# happyReduction_32+happyReduction_32 happy_x_2+	happy_x_1+	 =  case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> +	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> +	happyIn15+		 (do happy_var_1; happy_var_2+	)}}++happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_33 = happySpecReduce_2  11# happyReduction_33+happyReduction_33 happy_x_2+	happy_x_1+	 =  case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> +	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> +	happyIn15+		 (do happy_var_1; happy_var_2+	)}}++happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_34 = happySpecReduce_3  12# happyReduction_34+happyReduction_34 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOut19 happy_x_2 of { (HappyWrap19 happy_var_2) -> +	happyIn16+		 (mapM_ (newLocal happy_var_1) happy_var_2+	)}}++happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_35 = happySpecReduce_3  12# happyReduction_35+happyReduction_35 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut17 happy_x_2 of { (HappyWrap17 happy_var_2) -> +	happyIn16+		 (mapM_ newImport happy_var_2+	)}++happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_36 = happySpecReduce_3  12# happyReduction_36+happyReduction_36 happy_x_3+	happy_x_2+	happy_x_1+	 =  happyIn16+		 (return ()+	)++happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_37 = happySpecReduce_1  13# happyReduction_37+happyReduction_37 happy_x_1+	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> +	happyIn17+		 ([happy_var_1]+	)}++happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_38 = happySpecReduce_3  13# happyReduction_38+happyReduction_38 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> +	case happyOut17 happy_x_3 of { (HappyWrap17 happy_var_3) -> +	happyIn17+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_39 = happySpecReduce_1  14# happyReduction_39+happyReduction_39 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn18+		 ((happy_var_1, mkForeignLabel happy_var_1 ForeignLabelInExternalPackage IsFunction)+	)}++happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_40 = happySpecReduce_2  14# happyReduction_40+happyReduction_40 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	happyIn18+		 ((happy_var_2, mkForeignLabel happy_var_2 ForeignLabelInExternalPackage IsData)+	)}++happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_41 = happySpecReduce_2  14# happyReduction_41+happyReduction_41 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_String    happy_var_1)) -> +	case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	happyIn18+		 ((happy_var_2, mkCmmCodeLabel (UnitId (mkFastString happy_var_1)) happy_var_2)+	)}}++happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_42 = happySpecReduce_1  15# happyReduction_42+happyReduction_42 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn19+		 ([happy_var_1]+	)}++happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_43 = happySpecReduce_3  15# happyReduction_43+happyReduction_43 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> +	happyIn19+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_44 = happySpecReduce_1  16# happyReduction_44+happyReduction_44 happy_x_1+	 =  happyIn20+		 (return ()+	)++happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_45 = happySpecReduce_2  16# happyReduction_45+happyReduction_45 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn20+		 (do l <- newLabel happy_var_1; emitLabel l+	)}++happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_46 = happyReduce 4# 16# happyReduction_46+happyReduction_46 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn20+		 (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e)+	) `HappyStk` happyRest}}}}++happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_47 = happyReduce 8# 16# happyReduction_47+happyReduction_47 (happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> +	case happyOut57 happy_x_4 of { (HappyWrap57 happy_var_4) -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	case happyOutTok happy_x_7 of { happy_var_7 -> +	happyIn20+		 (do reg <- happy_var_1;+                     let lreg = case reg of+                                  { CmmLocal r -> r+                                  ; other -> pprPanic "CmmParse:" (ppr reg <> text "not a local register")+                                  } ;+                     mord <- happy_var_3;+                     let { ty = happy_var_4; w = typeWidth ty };+                     e <- happy_var_6;+                     let op = MO_AtomicRead w mord;+                     withSourceNote happy_var_2 happy_var_7 $ code (emitPrimCall [lreg] op [e])+	) `HappyStk` happyRest}}}}}}++happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_48 = happyReduce 8# 16# happyReduction_48+happyReduction_48 (happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut22 happy_x_1 of { (HappyWrap22 happy_var_1) -> +	case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> +	case happyOut39 happy_x_7 of { (HappyWrap39 happy_var_7) -> +	case happyOutTok happy_x_8 of { happy_var_8 -> +	happyIn20+		 (do mord <- happy_var_1; withSourceNote happy_var_3 happy_var_8 (doStore (Just mord) happy_var_2 happy_var_4 happy_var_7)+	) `HappyStk` happyRest}}}}}}++happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_49 = happyReduce 7# 16# happyReduction_49+happyReduction_49 (happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	case happyOutTok happy_x_7 of { happy_var_7 -> +	happyIn20+		 (withSourceNote happy_var_2 happy_var_7 (doStore Nothing happy_var_1 happy_var_3 happy_var_6)+	) `HappyStk` happyRest}}}}}++happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_50 = happyMonadReduce 10# 16# happyReduction_50+happyReduction_50 (happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> +	case happyOutTok happy_x_3 of { (L _ (CmmT_String    happy_var_3)) -> +	case happyOut24 happy_x_4 of { (HappyWrap24 happy_var_4) -> +	case happyOut42 happy_x_6 of { (HappyWrap42 happy_var_6) -> +	case happyOut28 happy_x_8 of { (HappyWrap28 happy_var_8) -> +	case happyOut25 happy_x_9 of { (HappyWrap25 happy_var_9) -> +	( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}})+	) (\r -> happyReturn (happyIn20 r))++happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_51 = happyMonadReduce 8# 16# happyReduction_51+happyReduction_51 (happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> +	case happyOutTok happy_x_4 of { (L _ (CmmT_Name      happy_var_4)) -> +	case happyOut45 happy_x_6 of { (HappyWrap45 happy_var_6) -> +	( primCall happy_var_1 happy_var_4 happy_var_6)}}})+	) (\r -> happyReturn (happyIn20 r))++happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_52 = happyMonadReduce 5# 16# happyReduction_52+happyReduction_52 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> +	( stmtMacro happy_var_1 happy_var_3)}})+	) (\r -> happyReturn (happyIn20 r))++happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_53 = happyReduce 7# 16# happyReduction_53+happyReduction_53 (happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	case happyOut32 happy_x_5 of { (HappyWrap32 happy_var_5) -> +	case happyOut36 happy_x_6 of { (HappyWrap36 happy_var_6) -> +	happyIn20+		 (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6+	) `HappyStk` happyRest}}}}++happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_54 = happySpecReduce_3  16# happyReduction_54+happyReduction_54 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	happyIn20+		 (do l <- lookupLabel happy_var_2; emit (mkBranch l)+	)}++happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_55 = happyReduce 5# 16# happyReduction_55+happyReduction_55 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> +	happyIn20+		 (doReturn happy_var_3+	) `HappyStk` happyRest}++happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_56 = happyReduce 4# 16# happyReduction_56+happyReduction_56 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> +	happyIn20+		 (doRawJump happy_var_2 happy_var_3+	) `HappyStk` happyRest}}++happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_57 = happyReduce 6# 16# happyReduction_57+happyReduction_57 (happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	happyIn20+		 (doJumpWithStack happy_var_2 [] happy_var_4+	) `HappyStk` happyRest}}++happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_58 = happyReduce 9# 16# happyReduction_58+happyReduction_58 (happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	case happyOut45 happy_x_7 of { (HappyWrap45 happy_var_7) -> +	happyIn20+		 (doJumpWithStack happy_var_2 happy_var_4 happy_var_7+	) `HappyStk` happyRest}}}++happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_59 = happyReduce 6# 16# happyReduction_59+happyReduction_59 (happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	happyIn20+		 (doCall happy_var_2 [] happy_var_4+	) `HappyStk` happyRest}}++happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_60 = happyReduce 10# 16# happyReduction_60+happyReduction_60 (happy_x_10 `HappyStk`+	happy_x_9 `HappyStk`+	happy_x_8 `HappyStk`+	happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> +	case happyOut39 happy_x_6 of { (HappyWrap39 happy_var_6) -> +	case happyOut45 happy_x_8 of { (HappyWrap45 happy_var_8) -> +	happyIn20+		 (doCall happy_var_6 happy_var_2 happy_var_8+	) `HappyStk` happyRest}}}++happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_61 = happyReduce 5# 16# happyReduction_61+happyReduction_61 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOutTok happy_x_5 of { (L _ (CmmT_Name      happy_var_5)) -> +	happyIn20+		 (do l <- lookupLabel happy_var_5; cmmRawIf happy_var_2 l happy_var_3+	) `HappyStk` happyRest}}}++happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_62 = happyReduce 7# 16# happyReduction_62+happyReduction_62 (happy_x_7 `HappyStk`+	happy_x_6 `HappyStk`+	happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> +	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	case happyOut15 happy_x_5 of { (HappyWrap15 happy_var_5) -> +	case happyOutTok happy_x_6 of { happy_var_6 -> +	case happyOut37 happy_x_7 of { (HappyWrap37 happy_var_7) -> +	happyIn20+		 (cmmIfThenElse happy_var_2 (withSourceNote happy_var_4 happy_var_6 happy_var_5) happy_var_7 happy_var_3+	) `HappyStk` happyRest}}}}}}++happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_63 = happyReduce 5# 16# happyReduction_63+happyReduction_63 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> +	case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> +	happyIn20+		 (pushStackFrame happy_var_3 happy_var_5+	) `HappyStk` happyRest}}++happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_64 = happyReduce 5# 16# happyReduction_64+happyReduction_64 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	case happyOut52 happy_x_4 of { (HappyWrap52 happy_var_4) -> +	case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> +	happyIn20+		 (reserveStackFrame happy_var_2 happy_var_4 happy_var_5+	) `HappyStk` happyRest}}}++happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_65 = happySpecReduce_3  16# happyReduction_65+happyReduction_65 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut21 happy_x_2 of { (HappyWrap21 happy_var_2) -> +	happyIn20+		 (happy_var_2 >>= code . emitUnwind+	)}++happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_66 = happyReduce 5# 17# happyReduction_66+happyReduction_66 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> +	case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> +	happyIn21+		 (do e <- happy_var_3; rest <- happy_var_5; return ((globalRegUse_reg happy_var_1, e) : rest)+	) `HappyStk` happyRest}}}++happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_67 = happySpecReduce_3  17# happyReduction_67+happyReduction_67 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	case happyOut23 happy_x_3 of { (HappyWrap23 happy_var_3) -> +	happyIn21+		 (do e <- happy_var_3; return [(globalRegUse_reg happy_var_1, e)]+	)}}++happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_68 = happySpecReduce_1  18# happyReduction_68+happyReduction_68 happy_x_1+	 =  happyIn22+		 (do return MemOrderRelaxed+	)++happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_69 = happySpecReduce_1  18# happyReduction_69+happyReduction_69 happy_x_1+	 =  happyIn22+		 (do return MemOrderRelease+	)++happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_70 = happySpecReduce_1  18# happyReduction_70+happyReduction_70 happy_x_1+	 =  happyIn22+		 (do return MemOrderAcquire+	)++happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_71 = happySpecReduce_1  18# happyReduction_71+happyReduction_71 happy_x_1+	 =  happyIn22+		 (do return MemOrderSeqCst+	)++happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_72 = happySpecReduce_1  19# happyReduction_72+happyReduction_72 happy_x_1+	 =  happyIn23+		 (do return Nothing+	)++happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_73 = happySpecReduce_1  19# happyReduction_73+happyReduction_73 happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	happyIn23+		 (do e <- happy_var_1; return (Just e)+	)}++happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_74 = happySpecReduce_1  20# happyReduction_74+happyReduction_74 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn24+		 (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 ForeignLabelInThisPackage IsFunction)))+	)}++happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_75 = happySpecReduce_0  21# happyReduction_75+happyReduction_75  =  happyIn25+		 (CmmMayReturn+	)++happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_76 = happySpecReduce_2  21# happyReduction_76+happyReduction_76 happy_x_2+	happy_x_1+	 =  happyIn25+		 (CmmNeverReturns+	)++happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_77 = happySpecReduce_1  22# happyReduction_77+happyReduction_77 happy_x_1+	 =  case happyOut27 happy_x_1 of { (HappyWrap27 happy_var_1) -> +	happyIn26+		 (happy_var_1+	)}++happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_78 = happySpecReduce_1  22# happyReduction_78+happyReduction_78 happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	happyIn26+		 (do e <- happy_var_1; return (BoolTest e)+	)}++happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_79 = happySpecReduce_3  23# happyReduction_79+happyReduction_79 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> +	case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> +	happyIn27+		 (do e1 <- happy_var_1; e2 <- happy_var_3;+                                          return (BoolAnd e1 e2)+	)}}++happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_80 = happySpecReduce_3  23# happyReduction_80+happyReduction_80 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> +	case happyOut26 happy_x_3 of { (HappyWrap26 happy_var_3) -> +	happyIn27+		 (do e1 <- happy_var_1; e2 <- happy_var_3;+                                          return (BoolOr e1 e2)+	)}}++happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_81 = happySpecReduce_2  23# happyReduction_81+happyReduction_81 happy_x_2+	happy_x_1+	 =  case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> +	happyIn27+		 (do e <- happy_var_2; return (BoolNot e)+	)}++happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_82 = happySpecReduce_3  23# happyReduction_82+happyReduction_82 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut27 happy_x_2 of { (HappyWrap27 happy_var_2) -> +	happyIn27+		 (happy_var_2+	)}++happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_83 = happySpecReduce_0  24# happyReduction_83+happyReduction_83  =  happyIn28+		 (PlayRisky+	)++happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_84 = happyMonadReduce 1# 24# happyReduction_84+happyReduction_84 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String    happy_var_1)) -> +	( parseSafety happy_var_1)})+	) (\r -> happyReturn (happyIn28 r))++happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_85 = happySpecReduce_2  25# happyReduction_85+happyReduction_85 happy_x_2+	happy_x_1+	 =  happyIn29+		 ([]+	)++happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_86 = happyMonadReduce 1# 25# happyReduction_86+happyReduction_86 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform GP_ARG_REGS ]))+	) (\r -> happyReturn (happyIn29 r))++happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_87 = happyMonadReduce 1# 25# happyReduction_87+happyReduction_87 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform SCALAR_ARG_REGS ]))+	) (\r -> happyReturn (happyIn29 r))++happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_88 = happyMonadReduce 1# 25# happyReduction_88+happyReduction_88 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V16_ARG_REGS ]))+	) (\r -> happyReturn (happyIn29 r))++happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_89 = happyMonadReduce 1# 25# happyReduction_89+happyReduction_89 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V32_ARG_REGS ]))+	) (\r -> happyReturn (happyIn29 r))++happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_90 = happyMonadReduce 1# 25# happyReduction_90+happyReduction_90 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform;+                                              return+                                                [ GlobalRegUse r (globalRegSpillType platform r)+                                                | r <- realArgRegsCover platform V64_ARG_REGS ]))+	) (\r -> happyReturn (happyIn29 r))++happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_91 = happySpecReduce_3  25# happyReduction_91+happyReduction_91 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> +	happyIn29+		 (happy_var_2+	)}++happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_92 = happySpecReduce_1  26# happyReduction_92+happyReduction_92 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	happyIn30+		 ([happy_var_1]+	)}++happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_93 = happySpecReduce_3  26# happyReduction_93+happyReduction_93 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	case happyOut30 happy_x_3 of { (HappyWrap30 happy_var_3) -> +	happyIn30+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_94 = happyReduce 5# 27# happyReduction_94+happyReduction_94 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_2 of { (L _ (CmmT_Int       happy_var_2)) -> +	case happyOutTok happy_x_4 of { (L _ (CmmT_Int       happy_var_4)) -> +	happyIn31+		 (Just (happy_var_2, happy_var_4)+	) `HappyStk` happyRest}}++happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_95 = happySpecReduce_0  27# happyReduction_95+happyReduction_95  =  happyIn31+		 (Nothing+	)++happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_96 = happySpecReduce_0  28# happyReduction_96+happyReduction_96  =  happyIn32+		 ([]+	)++happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_97 = happySpecReduce_2  28# happyReduction_97+happyReduction_97 happy_x_2+	happy_x_1+	 =  case happyOut33 happy_x_1 of { (HappyWrap33 happy_var_1) -> +	case happyOut32 happy_x_2 of { (HappyWrap32 happy_var_2) -> +	happyIn32+		 (happy_var_1 : happy_var_2+	)}}++happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_98 = happyReduce 4# 29# happyReduction_98+happyReduction_98 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut35 happy_x_2 of { (HappyWrap35 happy_var_2) -> +	case happyOut34 happy_x_4 of { (HappyWrap34 happy_var_4) -> +	happyIn33+		 (do b <- happy_var_4; return (happy_var_2, b)+	) `HappyStk` happyRest}}++happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_99 = happySpecReduce_3  30# happyReduction_99+happyReduction_99 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { happy_var_1 -> +	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> +	case happyOutTok happy_x_3 of { happy_var_3 -> +	happyIn34+		 (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2))+	)}}}++happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_100 = happySpecReduce_3  30# happyReduction_100+happyReduction_100 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	happyIn34+		 (do l <- lookupLabel happy_var_2; return (Left l)+	)}++happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_101 = happySpecReduce_1  31# happyReduction_101+happyReduction_101 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int       happy_var_1)) -> +	happyIn35+		 ([ happy_var_1 ]+	)}++happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_102 = happySpecReduce_3  31# happyReduction_102+happyReduction_102 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int       happy_var_1)) -> +	case happyOut35 happy_x_3 of { (HappyWrap35 happy_var_3) -> +	happyIn35+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_103 = happyReduce 5# 32# happyReduction_103+happyReduction_103 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_3 of { happy_var_3 -> +	case happyOut15 happy_x_4 of { (HappyWrap15 happy_var_4) -> +	case happyOutTok happy_x_5 of { happy_var_5 -> +	happyIn36+		 (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4)+	) `HappyStk` happyRest}}}++happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_104 = happySpecReduce_0  32# happyReduction_104+happyReduction_104  =  happyIn36+		 (Nothing+	)++happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_105 = happySpecReduce_0  33# happyReduction_105+happyReduction_105  =  happyIn37+		 (return ()+	)++happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_106 = happyReduce 4# 33# happyReduction_106+happyReduction_106 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOutTok happy_x_2 of { happy_var_2 -> +	case happyOut15 happy_x_3 of { (HappyWrap15 happy_var_3) -> +	case happyOutTok happy_x_4 of { happy_var_4 -> +	happyIn37+		 (withSourceNote happy_var_2 happy_var_4 happy_var_3+	) `HappyStk` happyRest}}}++happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_107 = happyReduce 5# 34# happyReduction_107+happyReduction_107 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = happyIn38+		 (Just True+	) `HappyStk` happyRest++happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_108 = happyReduce 5# 34# happyReduction_108+happyReduction_108 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = happyIn38+		 (Just False+	) `HappyStk` happyRest++happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_109 = happySpecReduce_0  34# happyReduction_109+happyReduction_109  =  happyIn38+		 (Nothing+	)++happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_110 = happySpecReduce_3  35# happyReduction_110+happyReduction_110 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Quot [happy_var_1,happy_var_3]+	)}}++happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_111 = happySpecReduce_3  35# happyReduction_111+happyReduction_111 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Mul [happy_var_1,happy_var_3]+	)}}++happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_112 = happySpecReduce_3  35# happyReduction_112+happyReduction_112 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Rem [happy_var_1,happy_var_3]+	)}}++happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_113 = happySpecReduce_3  35# happyReduction_113+happyReduction_113 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Sub [happy_var_1,happy_var_3]+	)}}++happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_114 = happySpecReduce_3  35# happyReduction_114+happyReduction_114 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Add [happy_var_1,happy_var_3]+	)}}++happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_115 = happySpecReduce_3  35# happyReduction_115+happyReduction_115 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Shr [happy_var_1,happy_var_3]+	)}}++happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_116 = happySpecReduce_3  35# happyReduction_116+happyReduction_116 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Shl [happy_var_1,happy_var_3]+	)}}++happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_117 = happySpecReduce_3  35# happyReduction_117+happyReduction_117 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_And [happy_var_1,happy_var_3]+	)}}++happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_118 = happySpecReduce_3  35# happyReduction_118+happyReduction_118 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Xor [happy_var_1,happy_var_3]+	)}}++happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_119 = happySpecReduce_3  35# happyReduction_119+happyReduction_119 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Or [happy_var_1,happy_var_3]+	)}}++happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_120 = happySpecReduce_3  35# happyReduction_120+happyReduction_120 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Ge [happy_var_1,happy_var_3]+	)}}++happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_121 = happySpecReduce_3  35# happyReduction_121+happyReduction_121 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Gt [happy_var_1,happy_var_3]+	)}}++happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_122 = happySpecReduce_3  35# happyReduction_122+happyReduction_122 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Le [happy_var_1,happy_var_3]+	)}}++happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_123 = happySpecReduce_3  35# happyReduction_123+happyReduction_123 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_U_Lt [happy_var_1,happy_var_3]+	)}}++happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_124 = happySpecReduce_3  35# happyReduction_124+happyReduction_124 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Ne [happy_var_1,happy_var_3]+	)}}++happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_125 = happySpecReduce_3  35# happyReduction_125+happyReduction_125 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn39+		 (mkMachOp MO_Eq [happy_var_1,happy_var_3]+	)}}++happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_126 = happySpecReduce_2  35# happyReduction_126+happyReduction_126 happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	happyIn39+		 (mkMachOp MO_Not [happy_var_2]+	)}++happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_127 = happySpecReduce_2  35# happyReduction_127+happyReduction_127 happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	happyIn39+		 (mkMachOp MO_S_Neg [happy_var_2]+	)}++happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_128 = happyMonadReduce 5# 35# happyReduction_128+happyReduction_128 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> +	case happyOutTok happy_x_3 of { (L _ (CmmT_Name      happy_var_3)) -> +	case happyOut40 happy_x_5 of { (HappyWrap40 happy_var_5) -> +	( do { mo <- nameToMachOp happy_var_3 ;+                                                return (mkMachOp mo [happy_var_1,happy_var_5]) })}}})+	) (\r -> happyReturn (happyIn39 r))++happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_129 = happySpecReduce_1  35# happyReduction_129+happyReduction_129 happy_x_1+	 =  case happyOut40 happy_x_1 of { (HappyWrap40 happy_var_1) -> +	happyIn39+		 (happy_var_1+	)}++happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_130 = happySpecReduce_2  36# happyReduction_130+happyReduction_130 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int       happy_var_1)) -> +	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	happyIn40+		 (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2)))+	)}}++happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_131 = happySpecReduce_2  36# happyReduction_131+happyReduction_131 happy_x_2+	happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Float     happy_var_1)) -> +	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> +	happyIn40+		 (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2)))+	)}}++happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_132 = happySpecReduce_1  36# happyReduction_132+happyReduction_132 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_String    happy_var_1)) -> +	happyIn40+		 (do s <- code (newStringCLit happy_var_1);+                                      return (CmmLit s)+	)}++happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_133 = happySpecReduce_1  36# happyReduction_133+happyReduction_133 happy_x_1+	 =  case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> +	happyIn40+		 (happy_var_1+	)}++happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_134 = happyReduce 5# 36# happyReduction_134+happyReduction_134 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> +	happyIn40+		 (do ptr <- happy_var_4; return (CmmMachOp (MO_RelaxedRead (typeWidth happy_var_1)) [ptr])+	) `HappyStk` happyRest}}++happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_135 = happyReduce 5# 36# happyReduction_135+happyReduction_135 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOut39 happy_x_4 of { (HappyWrap39 happy_var_4) -> +	happyIn40+		 (do ptr <- happy_var_4; return (CmmLoad ptr happy_var_1 Unaligned)+	) `HappyStk` happyRest}}++happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_136 = happyReduce 4# 36# happyReduction_136+happyReduction_136 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOut39 happy_x_3 of { (HappyWrap39 happy_var_3) -> +	happyIn40+		 (do ptr <- happy_var_3; return (CmmLoad ptr happy_var_1 NaturallyAligned)+	) `HappyStk` happyRest}}++happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_137 = happyMonadReduce 5# 36# happyReduction_137+happyReduction_137 (happy_x_5 `HappyStk`+	happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> +	( exprOp happy_var_2 happy_var_4)}})+	) (\r -> happyReturn (happyIn40 r))++happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_138 = happySpecReduce_3  36# happyReduction_138+happyReduction_138 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_2 of { (HappyWrap39 happy_var_2) -> +	happyIn40+		 (happy_var_2+	)}++happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_139 = happyMonadReduce 0# 37# happyReduction_139+happyReduction_139 (happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform))+	) (\r -> happyReturn (happyIn41 r))++happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_140 = happySpecReduce_2  37# happyReduction_140+happyReduction_140 happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> +	happyIn41+		 (happy_var_2+	)}++happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_141 = happySpecReduce_0  38# happyReduction_141+happyReduction_141  =  happyIn42+		 ([]+	)++happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_142 = happySpecReduce_1  38# happyReduction_142+happyReduction_142 happy_x_1+	 =  case happyOut43 happy_x_1 of { (HappyWrap43 happy_var_1) -> +	happyIn42+		 (happy_var_1+	)}++happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_143 = happySpecReduce_1  39# happyReduction_143+happyReduction_143 happy_x_1+	 =  case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> +	happyIn43+		 ([happy_var_1]+	)}++happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_144 = happySpecReduce_3  39# happyReduction_144+happyReduction_144 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> +	case happyOut43 happy_x_3 of { (HappyWrap43 happy_var_3) -> +	happyIn43+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_145 = happySpecReduce_1  40# happyReduction_145+happyReduction_145 happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	happyIn44+		 (do e <- happy_var_1;+                                             return (e, inferCmmHint e)+	)}++happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_146 = happyMonadReduce 2# 40# happyReduction_146+happyReduction_146 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOutTok happy_x_2 of { (L _ (CmmT_String    happy_var_2)) -> +	( do h <- parseCmmHint happy_var_2;+                                              return $ do+                                                e <- happy_var_1; return (e, h))}})+	) (\r -> happyReturn (happyIn44 r))++happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_147 = happySpecReduce_0  41# happyReduction_147+happyReduction_147  =  happyIn45+		 ([]+	)++happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_148 = happySpecReduce_1  41# happyReduction_148+happyReduction_148 happy_x_1+	 =  case happyOut46 happy_x_1 of { (HappyWrap46 happy_var_1) -> +	happyIn45+		 (happy_var_1+	)}++happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_149 = happySpecReduce_1  42# happyReduction_149+happyReduction_149 happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	happyIn46+		 ([ happy_var_1 ]+	)}++happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_150 = happySpecReduce_3  42# happyReduction_150+happyReduction_150 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> +	case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> +	happyIn46+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_151 = happySpecReduce_1  43# happyReduction_151+happyReduction_151 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn47+		 (lookupName happy_var_1+	)}++happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_152 = happySpecReduce_1  43# happyReduction_152+happyReduction_152 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	happyIn47+		 (return (CmmReg (CmmGlobal happy_var_1))+	)}++happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_153 = happySpecReduce_0  44# happyReduction_153+happyReduction_153  =  happyIn48+		 ([]+	)++happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_154 = happyReduce 4# 44# happyReduction_154+happyReduction_154 (happy_x_4 `HappyStk`+	happy_x_3 `HappyStk`+	happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest)+	 = case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> +	happyIn48+		 (happy_var_2+	) `HappyStk` happyRest}++happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_155 = happySpecReduce_1  45# happyReduction_155+happyReduction_155 happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	happyIn49+		 ([happy_var_1]+	)}++happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_156 = happySpecReduce_2  45# happyReduction_156+happyReduction_156 happy_x_2+	happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	happyIn49+		 ([happy_var_1]+	)}++happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_157 = happySpecReduce_3  45# happyReduction_157+happyReduction_157 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> +	case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> +	happyIn49+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_158 = happySpecReduce_1  46# happyReduction_158+happyReduction_158 happy_x_1+	 =  case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> +	happyIn50+		 (do e <- happy_var_1; return (e, inferCmmHint (CmmReg (CmmLocal e)))+	)}++happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_159 = happyMonadReduce 2# 46# happyReduction_159+happyReduction_159 (happy_x_2 `HappyStk`+	happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String    happy_var_1)) -> +	case happyOut51 happy_x_2 of { (HappyWrap51 happy_var_2) -> +	( do h <- parseCmmHint happy_var_1;+                                      return $ do+                                         e <- happy_var_2; return (e,h))}})+	) (\r -> happyReturn (happyIn50 r))++happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_160 = happySpecReduce_1  47# happyReduction_160+happyReduction_160 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn51+		 (do e <- lookupName happy_var_1;+                                     return $+                                       case e of+                                        CmmReg (CmmLocal r) -> r+                                        other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register")+	)}++happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_161 = happySpecReduce_1  48# happyReduction_161+happyReduction_161 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name      happy_var_1)) -> +	happyIn52+		 (do e <- lookupName happy_var_1;+                                     return $+                                       case e of+                                        CmmReg r -> r+                                        other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register")+	)}++happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_162 = happySpecReduce_1  48# happyReduction_162+happyReduction_162 happy_x_1+	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> +	happyIn52+		 (return (CmmGlobal happy_var_1)+	)}++happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_163 = happySpecReduce_0  49# happyReduction_163+happyReduction_163  =  happyIn53+		 (Nothing+	)++happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_164 = happySpecReduce_3  49# happyReduction_164+happyReduction_164 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> +	happyIn53+		 (Just happy_var_2+	)}++happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_165 = happySpecReduce_0  50# happyReduction_165+happyReduction_165  =  happyIn54+		 ([]+	)++happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_166 = happySpecReduce_1  50# happyReduction_166+happyReduction_166 happy_x_1+	 =  case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> +	happyIn54+		 (happy_var_1+	)}++happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_167 = happySpecReduce_2  51# happyReduction_167+happyReduction_167 happy_x_2+	happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	happyIn55+		 ([happy_var_1]+	)}++happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_168 = happySpecReduce_1  51# happyReduction_168+happyReduction_168 happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	happyIn55+		 ([happy_var_1]+	)}++happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_169 = happySpecReduce_3  51# happyReduction_169+happyReduction_169 happy_x_3+	happy_x_2+	happy_x_1+	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> +	case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> +	happyIn55+		 (happy_var_1 : happy_var_3+	)}}++happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_170 = happySpecReduce_2  52# happyReduction_170+happyReduction_170 happy_x_2+	happy_x_1+	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> +	case happyOutTok happy_x_2 of { (L _ (CmmT_Name      happy_var_2)) -> +	happyIn56+		 (newLocal happy_var_1 happy_var_2+	)}}++happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_171 = happySpecReduce_1  53# happyReduction_171+happyReduction_171 happy_x_1+	 =  happyIn57+		 (b8+	)++happyReduce_172 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_172 = happySpecReduce_1  53# happyReduction_172+happyReduction_172 happy_x_1+	 =  case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> +	happyIn57+		 (happy_var_1+	)}++happyReduce_173 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_173 = happySpecReduce_1  54# happyReduction_173+happyReduction_173 happy_x_1+	 =  happyIn58+		 (b16+	)++happyReduce_174 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_174 = happySpecReduce_1  54# happyReduction_174+happyReduction_174 happy_x_1+	 =  happyIn58+		 (b32+	)++happyReduce_175 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_175 = happySpecReduce_1  54# happyReduction_175+happyReduction_175 happy_x_1+	 =  happyIn58+		 (b64+	)++happyReduce_176 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_176 = happySpecReduce_1  54# happyReduction_176+happyReduction_176 happy_x_1+	 =  happyIn58+		 (cmmVec 2 f64+	)++happyReduce_177 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_177 = happySpecReduce_1  54# happyReduction_177+happyReduction_177 happy_x_1+	 =  happyIn58+		 (cmmVec 4 f64+	)++happyReduce_178 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_178 = happySpecReduce_1  54# happyReduction_178+happyReduction_178 happy_x_1+	 =  happyIn58+		 (cmmVec 8 f64+	)++happyReduce_179 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_179 = happySpecReduce_1  54# happyReduction_179+happyReduction_179 happy_x_1+	 =  happyIn58+		 (f32+	)++happyReduce_180 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_180 = happySpecReduce_1  54# happyReduction_180+happyReduction_180 happy_x_1+	 =  happyIn58+		 (f64+	)++happyReduce_181 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )+happyReduce_181 = happyMonadReduce 1# 54# happyReduction_181+happyReduction_181 (happy_x_1 `HappyStk`+	happyRest) tk+	 = happyThen ((( do platform <- PD.getPlatform; return $ gcWord platform))+	) (\r -> happyReturn (happyIn58 r))++happyNewToken action sts stk+	= cmmlex(\tk -> +	let cont i = happyDoAction i tk action sts stk in+	case tk of {+	L _ CmmT_EOF -> happyDoAction 86# tk action sts stk;+	L _ (CmmT_SpecChar ':') -> cont 1#;+	L _ (CmmT_SpecChar ';') -> cont 2#;+	L _ (CmmT_SpecChar '{') -> cont 3#;+	L _ (CmmT_SpecChar '}') -> cont 4#;+	L _ (CmmT_SpecChar '[') -> cont 5#;+	L _ (CmmT_SpecChar ']') -> cont 6#;+	L _ (CmmT_SpecChar '(') -> cont 7#;+	L _ (CmmT_SpecChar ')') -> cont 8#;+	L _ (CmmT_SpecChar '=') -> cont 9#;+	L _ (CmmT_SpecChar '`') -> cont 10#;+	L _ (CmmT_SpecChar '~') -> cont 11#;+	L _ (CmmT_SpecChar '/') -> cont 12#;+	L _ (CmmT_SpecChar '*') -> cont 13#;+	L _ (CmmT_SpecChar '%') -> cont 14#;+	L _ (CmmT_SpecChar '-') -> cont 15#;+	L _ (CmmT_SpecChar '+') -> cont 16#;+	L _ (CmmT_SpecChar '&') -> cont 17#;+	L _ (CmmT_SpecChar '^') -> cont 18#;+	L _ (CmmT_SpecChar '|') -> cont 19#;+	L _ (CmmT_SpecChar '>') -> cont 20#;+	L _ (CmmT_SpecChar '<') -> cont 21#;+	L _ (CmmT_SpecChar ',') -> cont 22#;+	L _ (CmmT_SpecChar '!') -> cont 23#;+	L _ (CmmT_DotDot) -> cont 24#;+	L _ (CmmT_DoubleColon) -> cont 25#;+	L _ (CmmT_Shr) -> cont 26#;+	L _ (CmmT_Shl) -> cont 27#;+	L _ (CmmT_Ge) -> cont 28#;+	L _ (CmmT_Le) -> cont 29#;+	L _ (CmmT_Eq) -> cont 30#;+	L _ (CmmT_Ne) -> cont 31#;+	L _ (CmmT_BoolAnd) -> cont 32#;+	L _ (CmmT_BoolOr) -> cont 33#;+	L _ (CmmT_True ) -> cont 34#;+	L _ (CmmT_False) -> cont 35#;+	L _ (CmmT_likely) -> cont 36#;+	L _ (CmmT_Relaxed) -> cont 37#;+	L _ (CmmT_Acquire) -> cont 38#;+	L _ (CmmT_Release) -> cont 39#;+	L _ (CmmT_SeqCst) -> cont 40#;+	L _ (CmmT_CLOSURE) -> cont 41#;+	L _ (CmmT_INFO_TABLE) -> cont 42#;+	L _ (CmmT_INFO_TABLE_RET) -> cont 43#;+	L _ (CmmT_INFO_TABLE_FUN) -> cont 44#;+	L _ (CmmT_INFO_TABLE_CONSTR) -> cont 45#;+	L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 46#;+	L _ (CmmT_else) -> cont 47#;+	L _ (CmmT_export) -> cont 48#;+	L _ (CmmT_section) -> cont 49#;+	L _ (CmmT_goto) -> cont 50#;+	L _ (CmmT_if) -> cont 51#;+	L _ (CmmT_call) -> cont 52#;+	L _ (CmmT_jump) -> cont 53#;+	L _ (CmmT_foreign) -> cont 54#;+	L _ (CmmT_never) -> cont 55#;+	L _ (CmmT_prim) -> cont 56#;+	L _ (CmmT_reserve) -> cont 57#;+	L _ (CmmT_return) -> cont 58#;+	L _ (CmmT_returns) -> cont 59#;+	L _ (CmmT_import) -> cont 60#;+	L _ (CmmT_switch) -> cont 61#;+	L _ (CmmT_case) -> cont 62#;+	L _ (CmmT_default) -> cont 63#;+	L _ (CmmT_push) -> cont 64#;+	L _ (CmmT_unwind) -> cont 65#;+	L _ (CmmT_bits8) -> cont 66#;+	L _ (CmmT_bits16) -> cont 67#;+	L _ (CmmT_bits32) -> cont 68#;+	L _ (CmmT_bits64) -> cont 69#;+	L _ (CmmT_vec128) -> cont 70#;+	L _ (CmmT_vec256) -> cont 71#;+	L _ (CmmT_vec512) -> cont 72#;+	L _ (CmmT_float32) -> cont 73#;+	L _ (CmmT_float64) -> cont 74#;+	L _ (CmmT_gcptr) -> cont 75#;+	L _ (CmmT_GlobalReg happy_dollar_dollar) -> cont 76#;+	L _ (CmmT_Name      happy_dollar_dollar) -> cont 77#;+	L _ (CmmT_String    happy_dollar_dollar) -> cont 78#;+	L _ (CmmT_Int       happy_dollar_dollar) -> cont 79#;+	L _ (CmmT_Float     happy_dollar_dollar) -> cont 80#;+	L _ (CmmT_GlobalArgRegs GP_ARG_REGS) -> cont 81#;+	L _ (CmmT_GlobalArgRegs SCALAR_ARG_REGS) -> cont 82#;+	L _ (CmmT_GlobalArgRegs V16_ARG_REGS) -> cont 83#;+	L _ (CmmT_GlobalArgRegs V32_ARG_REGS) -> cont 84#;+	L _ (CmmT_GlobalArgRegs V64_ARG_REGS) -> cont 85#;+	_ -> happyError' (tk, [])+	})++happyError_ explist 86# tk = happyError' (tk, explist)+happyError_ explist _ tk = happyError' (tk, explist)++happyThen :: () => PD a -> (a -> PD b) -> PD b+happyThen = (>>=)+happyReturn :: () => a -> PD a+happyReturn = (return)+happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn )++happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )++happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )++happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ))++happyThen1 :: () => PD a -> (a -> PD b) -> PD b+happyThen1 = happyThen+happyReturn1 :: () => a -> PD a+happyReturn1 = happyReturn+happyError' :: () => ((Located CmmToken), [Prelude.String]) -> PD a+happyError' tk = (\(tokens, explist) -> happyError) tk+cmmParse = happySomeParser where+ happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap4 x') = happyOut4 x} in x'))++happySeq = happyDoSeq+++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 :: UniqFM FastString (Width -> MachOp)+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 ),+        ( "fmin",       MO_F_Min ),+        ( "fmax",       MO_F_Max ),++        ( "fmadd" ,     MO_FMA FMAdd  1 ),+        ( "fmsub" ,     MO_FMA FMSub  1 ),+        ( "fnmadd",     MO_FMA FNMAdd 1 ),+        ( "fnmsub",     MO_FMA FNMSub 1 ),++        ( "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_Truncate W8 ),+        ( "f2i16",    flip MO_FS_Truncate W16 ),+        ( "f2i32",    flip MO_FS_Truncate W32 ),+        ( "f2i64",    flip MO_FS_Truncate W64 ),+        ( "i2f32",    flip MO_SF_Round W32 ),+        ( "i2f64",    flip MO_SF_Round W64 ),++        ( "w2f_bitcast", MO_WF_Bitcast ),+        ( "f2w_bitcast", MO_FW_Bitcast )+        ]++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,) ),++        -- TODO: It would be nice to rename the following operations to+        -- acquire_fence and release_fence. Be aware that there'll be issues+        -- with an overlapping token ('acquire') in the lexer.+        ( "fence_acquire", (MO_AcquireFence,)),+        ( "fence_release", (MO_ReleaseFence,)),+        ( "fence_seq_cst", (MO_SeqCstFence,)),++        ( "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,)),++        ( "bswap16", (MO_BSwap W16,) ),+        ( "bswap32", (MO_BSwap W32,) ),+        ( "bswap64", (MO_BSwap W64,) )+    ] ++ concat+    [ allWidths "popcnt" MO_PopCnt+    , allWidths "pdep" MO_Pdep+    , allWidths "pext" MO_Pext+    , allWidths "cmpxchg" MO_Cmpxchg+    , allWidths "xchg" MO_Xchg+    , allWidths "load_relaxed" (\w -> MO_AtomicRead w MemOrderAcquire)+    , allWidths "load_acquire" (\w -> MO_AtomicRead w MemOrderAcquire)+    , allWidths "load_seqcst" (\w -> MO_AtomicRead w MemOrderSeqCst)+    , allWidths "store_release" (\w -> MO_AtomicWrite w MemOrderRelease)+    , allWidths "store_seqcst" (\w -> MO_AtomicWrite w MemOrderSeqCst)+    , allWidths "fetch_add" (\w -> MO_AtomicRMW w AMO_Add)+    , allWidths "fetch_sub" (\w -> MO_AtomicRMW w AMO_Sub)+    , allWidths "fetch_and" (\w -> MO_AtomicRMW w AMO_And)+    , allWidths "fetch_nand" (\w -> MO_AtomicRMW w AMO_Nand)+    , allWidths "fetch_or" (\w -> MO_AtomicRMW w AMO_Or)+    , allWidths "fetch_xor" (\w -> MO_AtomicRMW w AMO_Xor)+    , allWidths "mul2_" (\w -> MO_S_Mul2 w)+    , allWidths "mul2u_" (\w -> MO_U_Mul2 w)+    ]+  where+    allWidths+        :: String+        -> (Width -> CallishMachOp)+        -> [(FastString, a -> (CallishMachOp, a))]+    allWidths name f =+        [ (mkFastString $ name ++ show (widthInBits w), (f w,))+        | w <- [W8, W16, W32, W64]+        ]++    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 reg))+  | isPtrGlobalRegUse reg+  = AddrHint+inferCmmHint _+  = NoHint++isPtrGlobalRegUse :: GlobalRegUse -> Bool+isPtrGlobalRegUse (GlobalRegUse reg ty)+  | VanillaReg {} <- reg+  , isGcPtrType ty+  = True+  | otherwise+  = go reg+  where+    go Sp             = True+    go SpLim          = True+    go Hp             = True+    go HpLim          = True+    go CCCS           = True+    go CurrentTSO     = True+    go CurrentNursery = True+    go _              = 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_GP_ARG_REGS",         \[] -> emitSaveRegs GP_ARG_REGS ),+  ( fsLit "RESTORE_GP_ARG_REGS",      \[] -> emitRestoreRegs GP_ARG_REGS ),+  ( fsLit "SAVE_SCALAR_ARG_REGS",     \[] -> emitSaveRegs SCALAR_ARG_REGS ),+  ( fsLit "RESTORE_SCALAR_ARG_REGS",  \[] -> emitRestoreRegs SCALAR_ARG_REGS ),+  ( fsLit "SAVE_V16_ARG_REGS",        \[] -> emitSaveRegs V16_ARG_REGS ),+  ( fsLit "RESTORE_V16_ARG_REGS",     \[] -> emitRestoreRegs V16_ARG_REGS ),+  ( fsLit "SAVE_V32_ARG_REGS",        \[] -> emitSaveRegs V32_ARG_REGS ),+  ( fsLit "RESTORE_V32_ARG_REGS",     \[] -> emitRestoreRegs V32_ARG_REGS ),+  ( fsLit "SAVE_V64_ARG_REGS",         \[] -> emitSaveRegs V64_ARG_REGS ),+  ( fsLit "RESTORE_V64_ARG_REGS",      \[] -> emitRestoreRegs V64_ARG_REGS ),++  ( fsLit "PUSH_SCALAR_ARG_REGS",     \[live_regs] -> emitPushArgRegs SCALAR_ARG_REGS live_regs ),+  ( fsLit "POP_SCALAR_ARG_REGS",      \[live_regs] -> emitPopArgRegs SCALAR_ARG_REGS live_regs ),++  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),+  ( fsLit "PROF_HEADER_CREATE",     \[e] -> profHeaderCreate e ),++  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "PUSH_BH_UPD_FRAME",     \[sp,e] -> emitPushBHUpdateFrame 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++emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushBHUpdateFrame sp e = do+  emitUpdateFrame sp mkBHUpdInfoLabel 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+                  (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 -> [GlobalRegUse] -> 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++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 :: Maybe MemoryOrdering+        -> CmmType+        -> CmmParse CmmExpr   -- ^ address+        -> CmmParse CmmExpr   -- ^ value+        -> CmmParse ()+doStore mem_ord 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 mem_ord 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 $ LexicalFastString $ mkFastString 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 (DCmmGroup, [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 topInfoTableD cmm)+                    | otherwise = []+                    where+                      do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig+              -- We need to pass a deterministic unique supply to generate IPE+              -- symbols deterministically. The symbols created by+              -- emitIpeBufferListNode must all be local to the object (see+              -- comment on its definition). If the symbols weren't local, using a+              -- counter starting from zero for every Cmm file would cause+              -- conflicts when compiling more than one Cmm file together.+              (_, cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info (initDUniqSupply 'P' 0)+              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)+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $++++++++++++++-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ > 706+#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool)+#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool)+#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool)+#else+#define LT(n,m) (n Happy_GHC_Exts.<# m)+#define GTE(n,m) (n Happy_GHC_Exts.>=# m)+#define EQ(n,m) (n Happy_GHC_Exts.==# m)+#endif++++++++++++++++++++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList+++++++++++++++++++++++++++++++++++++++++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is ERROR_TOK, it means we've just accepted a partial+-- parse (a %partial parser).  We must ignore the saved token on the top of+-- the stack in this case.+happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =+        happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = +        (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+        = {- nothing -}+          case action of+                0#           -> {- nothing -}+                                     happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Prelude.Int)) i tk st+                -1#          -> {- nothing -}+                                     happyAccept i tk st+                n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -}+                                                   (happyReduceArr Happy_Data_Array.! rule) i tk st+                                                   where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#))))))+                n                 -> {- nothing -}+                                     happyShift new_state i tk st+                                     where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+   where off    = happyAdjustOffset (indexShortOffAddr happyActOffsets st)+         off_i  = (off Happy_GHC_Exts.+# i)+         check  = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#))+                  then EQ(indexShortOffAddr happyCheck off_i, i)+                  else Prelude.False+         action+          | check     = indexShortOffAddr happyTable off_i+          | Prelude.otherwise = indexShortOffAddr happyDefActions st+++++indexShortOffAddr (HappyA# arr) off =+        Happy_GHC_Exts.narrow16Int# i+  where+        i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+        high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+        low  = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+        off' = off Happy_GHC_Exts.*# 2#+++++{-# INLINE happyLt #-}+happyLt x y = LT(x,y)+++readArrayBit arr bit =+    Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `Prelude.mod` 16)+  where unbox_int (Happy_GHC_Exts.I# x) = x+++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++++++++++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--     trace "shifting the error token" $+     happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+     happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+     = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+     = let r = fn v1 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+     = let r = fn v1 v2 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+     = let r = fn v1 v2 v3 in+       happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happyReduce k nt fn j tk st sts stk+     = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of+         sts1@((HappyCons (st1@(action)) (_))) ->+                let r = fn stk in  -- it doesn't hurt to always seq here...+                happyDoSeq r (happyGoto nt j tk st1 sts1 r)++happyMonadReduce k nt fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+          let drop_stk = happyDropStk k stk in+          happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn 0# tk st sts stk+     = happyFail [] 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+      case happyDrop k (HappyCons (st) (sts)) of+        sts1@((HappyCons (st1@(action)) (_))) ->+         let drop_stk = happyDropStk k stk++             off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1)+             off_i = (off Happy_GHC_Exts.+# nt)+             new_state = indexShortOffAddr happyTable off_i+++++          in+          happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = +   {- nothing -}+   happyDoAction j tk new_state+   where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st)+         off_i = (off Happy_GHC_Exts.+# nt)+         new_state = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (ERROR_TOK is the error token)++-- parse error if we are in recovery and we fail again+happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) =+     let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+--      trace "failing" $ +        happyError_ explist i tk++{-  We don't need state discarding for our restricted implementation of+    "error".  In fact, it can cause some bogus parses, so I've disabled it+    for now --SDM++-- discard a state+happyFail  ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) +                                                (saved_tok `HappyStk` _ `HappyStk` stk) =+--      trace ("discarding state, depth " ++ show (length stk))  $+        DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+--                       save the old token and carry on.+happyFail explist i tk (action) sts stk =+--      trace "entering error recovery" $+        happyDoAction 0# tk action sts ((Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = Prelude.error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing.  If the --strict flag is given, then Happy emits +--      happySeq = happyDoSeq+-- otherwise it emits+--      happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq   a b = a `Prelude.seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template.  GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ GHC/Cmm/Parser/Config.hs view
@@ -0,0 +1,24 @@+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+  }
+ GHC/Cmm/Parser/Monad.hs view
@@ -0,0 +1,75 @@+-----------------------------------------------------------------------------+-- 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)
+ GHC/Cmm/Pipeline.hs view
@@ -0,0 +1,381 @@++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.Label+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.Cmm.ThreadSanitizer++import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM++import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Misc ( partitionWith )++import GHC.Platform++import Control.Monad+import GHC.Utils.Monad (mapAccumLM)++-----------------------------------------------------------------------------+-- | 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+ -> DUniqSupply+ -> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply) -- Output CPS transformed C--++cmmPipeline logger cmm_config srtInfo prog dus0 = do+  let forceRes ((info, group), us) = info `seq` us `seq` foldr seq () group+  let platform = cmmPlatform cmm_config+  withTimingSilent logger (text "Cmm pipeline") forceRes $ do+     (dus1, prog')  <- {-# SCC "tops" #-} mapAccumLM (cpsTop logger platform cmm_config) dus0 prog+     let (procs, data_) = partitionWith id prog'+     (srtInfo, dus, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo dus1 procs data_+     dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)++     return ((srtInfo, cmms), dus)++-- | 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 -> DUniqSupply -> CmmDecl -> IO (DUniqSupply, Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))+cpsTop _logger platform _ dus (CmmData section statics) =+  return (dus, Right (cafAnalData platform statics, CmmData section statics))+cpsTop logger platform cfg dus 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 (1)" 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, dus) <- if cmmDoCmmSwitchPlans cfg+             then {-# SCC "createSwitchPlans" #-}+                  pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g+             else pure (g, dus)+      dump Opt_D_dump_cmm_switch "Post switch plan" g++      ----------- ThreadSanitizer instrumentation -----------------------------+      g <- {-# SCC "annotateTSAN" #-}+          if cmmOptThreadSanitizer cfg+          then do+             -- TODO(#25273): Use the deterministic UniqDSM (ie `runUniqueDSM`) instead+             -- of UniqSM (see `initUs_`) to guarantee deterministic objects+             -- when doing thread sanitization.+            us <- mkSplitUniqSupply 'u'+            return $ initUs_ us $+              annotateTSAN platform g+          else return g+      dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g++      ----------- Proc points -------------------------------------------------+      let+        call_pps :: ProcPointSet -- LabelMap+        call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+      (proc_points, dus) <-+         if splitting_proc_points+            then do+              let (pp, dus') = {-# SCC "minimalProcPointSet" #-} runUniqueDSM dus $+                    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, dus')+            else+              return (call_pps, dus)++      ----------- Layout the stack and manifest Sp ----------------------------+      ((g, stackmaps), dus) <- pure $+         {-# SCC "layoutStack" #-}+         if do_layout+            then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g+            else ((g, mapEmpty), dus)+      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, dus) <- 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, dus) <- {-# SCC "splitAtProcPoints" #-} pure $ runUniqueDSM dus $+                  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, dus)+           else+             -- attach info tables to return points+             return ([attachContInfoTables call_pps (CmmProc h l v g)], dus)++      ------------- 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 (2)" g++      return (dus, 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.++-}++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
+ GHC/Cmm/ProcPoint.hs view
@@ -0,0 +1,492 @@+{-# 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.DSM+import GHC.Cmm.Dataflow.Block+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+                    -> UniqDSM 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 -> UniqDSM 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+                  -> UniqDSM [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 . globalRegUse_reg) $ regSetToList $+                        expectJust $ 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)+                     -> UniqDSM (LabelMap Label, [CmmBlock])+      add_jump_block (env, bs) (pp, l) = do+        bid <- liftM mkBlockId getUniqueDSM+        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) -> UniqDSM (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 $ 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 $ 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 $ mapLookup bid  block_order)+                (expectJust $ 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.+-}
+ GHC/Cmm/Reducibility.hs view
@@ -0,0 +1,223 @@+{-# 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.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.DSM+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+            -> UniqDSM (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+          -> UniqDSM (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 = liftUniqDSM $ 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 -> UniqDSM CmmSuper+relabel node = do+     finite_map <- foldM addPair mapEmpty $ definedLabels node+     return $ changeLabels (labelChanger finite_map) node+  where addPair :: LabelMap Label -> Label -> UniqDSM (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
+ GHC/Cmm/Reg.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module GHC.Cmm.Reg+    ( -- * Cmm Registers+      CmmReg(..)+    , cmmRegType+    , cmmRegWidth+      -- * Local registers+    , LocalReg(..)+    , localRegType+      -- * Global registers+    , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+    , node, baseReg+    , GlobalRegUse(..), pprGlobalRegUse++    , GlobalArgRegs(..)+    ) where++import GHC.Prelude++import GHC.Platform+import GHC.Utils.Outputable+import GHC.Types.Unique+import GHC.Cmm.Type++-----------------------------------------------------------------------------+--              Cmm registers+-----------------------------------------------------------------------------++{- Note [GlobalReg vs GlobalRegUse]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We distinguish GlobalReg, which describes registers in the STG abstract machine,+with GlobalRegUse, which describes an usage of such a register to store values+of a particular CmmType.++For example, we might want to load/store an 8-bit integer in a register that+can store 32-bit integers.++The width of the type must fit in the register, i.e. for a usage+@GlobalRegUse reg ty@ we must have that++  > typeWidth ty <= typeWidth (globalRegSpillType reg)++The restrictions about what categories of types can be stored in a given+register are less easily stated. Some examples are:++  - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord),+    as well as sub-word sized values (e.g. b16).+  - On x86_64, SIMD registers can be used to hold vectors of both floating+    and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values).+-}++-- | A use of a global register at a particular type.+--+-- While a 'GlobalReg' identifies a global register in the STG machine,+-- a 'GlobalRegUse' also contains information about the type we are storing+-- in the register.+--+-- See Note [GlobalReg vs GlobalRegUse] for more information.+data GlobalRegUse+  = GlobalRegUse+    { globalRegUse_reg  :: !GlobalReg+      -- ^ The underlying 'GlobalReg'+    , globalRegUse_type :: !CmmType+      -- ^ The 'CmmType' at which we are using the 'GlobalReg'.+      --+      -- Its width must be less than the width of the 'GlobalReg':+      --+      -- > typeWidth ty <= typeWidth (globalRegSpillType platform reg)+    }+  deriving Show++instance Outputable GlobalRegUse where+  ppr (GlobalRegUse reg _) = ppr reg++pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc+pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg++-- TODO: these instances should be removed in favour+-- of more surgical uses of equality.+instance Eq GlobalRegUse where+  GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2+instance Ord GlobalRegUse where+  GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2++data CmmReg+  = CmmLocal  {-# UNPACK #-} !LocalReg+  | CmmGlobal GlobalRegUse+  deriving ( Eq, Ord, Show )++instance Outputable CmmReg where+    ppr e = pprReg e++pprReg :: CmmReg -> SDoc+pprReg r+   = case r of+        CmmLocal  local                   -> pprLocalReg  local+        CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global++cmmRegType :: CmmReg -> CmmType+cmmRegType (CmmLocal  reg) = localRegType reg+cmmRegType (CmmGlobal reg) = globalRegUse_type reg++cmmRegWidth :: CmmReg -> Width+cmmRegWidth = typeWidth . cmmRegType++-----------------------------------------------------------------------------+--              Local registers+-----------------------------------------------------------------------------++data LocalReg+  = LocalReg {-# UNPACK #-} !Unique !CmmType+    -- ^ Parameters:+    --   1. Identifier+    --   2. Type+  deriving Show++instance Eq LocalReg where+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++instance Outputable LocalReg where+    ppr e = pprLocalReg e++-- 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++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++--+-- We only print the type of the local reg if it isn't wordRep+--+pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq rep) =+--   = ppr rep <> char '_' <> ppr uniq+-- Temp Jan08+    char '_' <> pprUnique uniq <>+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh+                    then dcolon <> ptr <> ppr rep+                    else dcolon <> ptr <> ppr rep)+   where+     pprUnique unique = sdocOption sdocSuppressUniques $ \case+       True  -> text "_locVar_"+       False -> ppr unique+     ptr = empty+         --if isGcPtrType rep+         --      then doubleQuotes (text "ptr")+         --      else empty++-----------------------------------------------------------------------------+--              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 GHC.Cmm.Utils.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!+-}++-- | An abstract global register for the STG machine.+--+-- See also 'GlobalRegUse', which denotes a usage of a register at a particular+-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per+-- Note [GlobalReg vs GlobalRegUse].+data GlobalReg+  -- Argument and return registers+  = VanillaReg                  -- pointers, unboxed ints and chars+        {-# UNPACK #-} !Int     -- its number++  | 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++  -- I think we should redesign 'GlobalReg', for example instead of+  -- FloatReg/DoubleReg/XmmReg/YmmReg/ZmmReg we could have a single VecReg+  -- which also stores the type we are storing in it.+  --+  -- We might then be able to get rid of GlobalRegUse, as the type information+  -- would already be contained in a 'GlobalReg'.++  | 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  -- ^ address of stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- ^ address of stg_gc_enter_1+  | GCFun               -- ^ address of 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++  -- | 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. Its exact meaning differs+  -- from platform to platform (see module PositionIndependentCode).+  | PicBaseReg++  deriving( Eq, Ord, Show )+    -- NOTE: the Ord instance affects the tuple layout in GHCi, see+    --       Note [GHCi and native call registers]++instance Outputable GlobalReg where+    ppr e = pprGlobalReg e++instance OutputableP env GlobalReg where+    pdoc _ = ppr++pprGlobalReg :: IsLine doc => GlobalReg -> doc+pprGlobalReg gr+    = case gr of+        VanillaReg n   -> char 'R' <> 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"+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-}+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg+baseReg           p = CmmGlobal (GlobalRegUse BaseReg        $ bWord p)+spReg             p = CmmGlobal (GlobalRegUse Sp             $ bWord p)+hpReg             p = CmmGlobal (GlobalRegUse Hp             $ gcWord p)+hpLimReg          p = CmmGlobal (GlobalRegUse HpLim          $ bWord p)+spLimReg          p = CmmGlobal (GlobalRegUse SpLim          $ bWord p)+nodeReg           p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p)+currentTSOReg     p = CmmGlobal (GlobalRegUse CurrentTSO     $ bWord p)+currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p)+hpAllocReg        p = CmmGlobal (GlobalRegUse HpAlloc        $ bWord p)+cccsReg           p = CmmGlobal (GlobalRegUse CCCS           $ bWord p)++node :: GlobalReg+node = VanillaReg 1++globalRegSpillType :: Platform -> GlobalReg -> CmmType+globalRegSpillType platform = \case+   VanillaReg _ -> gcWord platform+   FloatReg   _ -> cmmFloat W32+   DoubleReg  _ -> cmmFloat W64+   LongReg    _ -> cmmBits  W64++   -- TODO: improve the internal model of SIMD/vectorized registers+   -- the right design SHOULD improve handling of float and double code too.+   -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim+   XmmReg    _ -> cmmVec  4 (cmmBits W32)+   YmmReg    _ -> cmmVec  8 (cmmBits W32)+   ZmmReg    _ -> cmmVec 16 (cmmBits W32)++   Hp          -> gcWord platform -- The initialiser for all+                                  -- dynamically allocated closures+   _           -> bWord platform++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++-- --------------------------------------------------------------------------++-- | Global registers used for argument passing.+--+-- See Note [realArgRegsCover] in GHC.Cmm.CallConv.+data GlobalArgRegs+  -- | General-purpose (integer) argument-passing registers.+  = GP_ARG_REGS+  -- | Scalar (integer & floating-point) argument-passing registers.+  | SCALAR_ARG_REGS+  -- | 16 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V16_ARG_REGS+  -- | 32 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V32_ARG_REGS+  -- | 64 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V64_ARG_REGS+  deriving ( Show, Eq, Ord )
+ GHC/Cmm/Sink.hs view
@@ -0,0 +1,953 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}++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.Graph+import GHC.Platform.Regs++import GHC.Platform+import GHC.Types.Unique.FM++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 = unionsLRegSet (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 = unionsLRegSet (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 `unionLRegSet` 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 (GlobalRegUse 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 two 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 UniqDSM.+--+-- 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 (GlobalRegUse Hp _)) _ <- node        = True+  | StackMem   <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node        = True+  | SpMem{}    <- addr, CmmAssign (CmmGlobal (GlobalRegUse 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 || globalRegUsedIn platform (globalRegUse_reg 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 r 0 w+   CmmRegOff r i  -> regAddr r i w+   _other | regUsedIn platform (spReg platform) e -> StackMem+          | otherwise                             -> AnyMem++regAddr :: CmmReg -> Int -> Width -> AbsMem+regAddr (CmmGlobal (GlobalRegUse Sp _)) i w = SpMem i (widthInBytes w)+regAddr (CmmGlobal (GlobalRegUse Hp _)) _ _ = HeapMem+regAddr (CmmGlobal (GlobalRegUse CurrentTSO _)) _ _ = HeapMem -- important for PrimOps+regAddr r _ _ | isGcPtrType (cmmRegType 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));+-}
+ GHC/Cmm/Switch.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module GHC.Cmm.Switch (+     SwitchTargets,+     mkSwitchTargets,+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,+     mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough,+     switchTargetsToList, eqSwitchTargetWith,++     SwitchPlan(..),+     backendHasNativeSwitch,+     createSwitchPlan,+  ) where++import GHC.Prelude hiding (head)++import GHC.Utils.Outputable+import GHC.Driver.Backend+import GHC.Utils.Panic+import GHC.Cmm.Dataflow.Label (Label)++import Data.Maybe+import Data.List.NonEmpty (NonEmpty (..), groupWith, head)+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 GHC.StgToCmm.Utils.+--    At this stage, they are unsuitable for code generation.+--  * A dedicated Cmm transformation (GHC.Cmm.Switch.Implement) 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, GHC.Cmm.Switch.Implement 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 [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement] why the two module are+-- separated.+++-- Note [Magic Constants in GHC.Cmm.Switch]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 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)++-- | Changes all labels mentioned in the SwitchTargets value+mapSwitchTargetsA :: Applicative m => (Label -> m Label) -> SwitchTargets -> m SwitchTargets+mapSwitchTargetsA f (SwitchTargets signed range mbdef branches)+    = SwitchTargets signed range <$> traverse f mbdef <*> traverse 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 occurring 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 -> ([(NonEmpty Integer, Label)], Maybe Label)+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)+  where+    groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $+             groupWith snd $+             M.toList branches++-- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"+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 GHC.Cmm.Switch]+--  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.+-}+++-- | 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 quickly 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 in between 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 [GHC.Cmm.Switch vs. GHC.Cmm.Switch.Implement]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- I (Joachim) separated the two somewhat closely related modules+--+--  - GHC.Cmm.Switch, which provides the CmmSwitchTargets type and contains the strategy+--    for implementing a Cmm switch (createSwitchPlan), and+--  - GHC.Cmm.Switch.Implement, which contains the actual Cmm graph modification,+--+-- for these reasons:+--+--  * GHC.Cmm.Switch 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+--    GHC.Cmm.Dataflow (Literal)).+--  * GHC.Cmm.Switch.Implement is the Cmm transformation and hence very high in+--    the dependency tree.+--  * GHC.Cmm.Switch provides the CmmSwitchTargets data type, which is abstract, but+--    used in GHC.Cmm.Node.+--  * Because GHC.Cmm.Switch 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.
+ GHC/Cmm/Switch/Implement.hs view
@@ -0,0 +1,117 @@+{-# 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.Utils.Monad (concatMapM)+import GHC.Types.Unique.DSM++--+-- 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 -> UniqDSM 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 -> UniqDSM [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 -> UniqDSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr _        reg@(CmmReg {})  = return (emptyBlock, reg)+floatSwitchExpr platform expr             = do+  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueDSM+  return (BMiddle assign, expr')+++-- Implementing a switch plan (returning a tail block)+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqDSM (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` getUniqueDSM+        (last, newBlocks) <- go p+        let block = CmmEntry bid scope `blockJoinHead` last+        return (bid, block: newBlocks)
+ GHC/Cmm/ThreadSanitizer.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls.+module GHC.Cmm.ThreadSanitizer (annotateTSAN) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Regs (activeStgRegs, callerSaves)+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Data.FastString+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique+import GHC.Types.Unique.Supply+import GHC.Cmm.Dataflow.Label++import Data.Maybe (fromMaybe)++data Env = Env { platform :: Platform+               , uniques :: UniqSupply+               }++annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph+annotateTSAN platform graph = do+    env <- Env platform <$> getUniqueSupplyM+    return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph++mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')+             -> Block n e x -> Block n e x+mapBlockList f (BlockCO n rest  ) = f n `blockAppend` mapBlockList f rest+mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m+mapBlockList f (BlockOC   rest m) = mapBlockList f rest `blockAppend` f m+mapBlockList _ BNil               = BNil+mapBlockList f (BMiddle blk)      = f blk+mapBlockList f (BCat a b)         = mapBlockList f a `blockAppend` mapBlockList f b+mapBlockList f (BSnoc a n)        = mapBlockList f a `blockAppend` f n+mapBlockList f (BCons n a)        = f n `blockAppend` mapBlockList f a++annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x+annotateBlock env = mapBlockList (annotateNode env)++annotateNode :: Env -> CmmNode e x -> Block CmmNode e x+annotateNode env node =+    case node of+      CmmEntry{}              -> BlockCO node BNil+      CmmComment{}            -> BMiddle node+      CmmTick{}               -> BMiddle node+      CmmUnwind{}             -> BMiddle node+      CmmAssign{}             -> annotateNodeOO env node+      -- TODO: Track unaligned stores+      CmmStore _ _ Unaligned  -> annotateNodeOO env node+      CmmStore lhs rhs NaturallyAligned  ->+          let ty = cmmExprType (platform env) rhs+              rhs_nodes = annotateLoads env (collectExprLoads rhs)+              lhs_nodes = annotateLoads env (collectExprLoads lhs)+              st        = tsanStore env ty lhs+          in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node+      CmmUnsafeForeignCall (PrimTarget op) formals args ->+          let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args)+              arg_nodes = blockConcat $ map (annotateExpr env) args+          in arg_nodes `blockAppend` node'+      CmmUnsafeForeignCall{}  -> annotateNodeOO env node+      CmmBranch{}             -> annotateNodeOC env node+      CmmCondBranch{}         -> annotateNodeOC env node+      CmmSwitch{}             -> annotateNodeOC env node+      CmmCall{}               -> annotateNodeOC env node+      CmmForeignCall{}        -> annotateNodeOC env node++annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O+annotateNodeOO env node =+    annotateLoads env (collectLoadsNode node) `blockSnoc` node++annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C+annotateNodeOC env node =+    annotateLoads env (collectLoadsNode node) `blockJoinTail` node++annotateExpr :: Env -> CmmExpr -> Block CmmNode O O+annotateExpr env expr =+    annotateLoads env (collectExprLoads expr)++-- | A load mentioned in a 'CmmExpr'.+data Load = Load CmmType AlignmentSpec CmmExpr++annotateLoads :: Env -> [Load] -> Block CmmNode O O+annotateLoads env loads =+    blockConcat+    [ tsanLoad env align ty addr+    | Load ty align addr <- loads+    ]++collectLoadsNode :: CmmNode e x -> [Load]+collectLoadsNode node =+    foldExp (\exp rest -> collectExprLoads exp ++ rest) node []++-- | Collect all of the memory locations loaded from by a 'CmmExpr'.+collectExprLoads :: CmmExpr -> [Load]+collectExprLoads (CmmLit _)           = []+collectExprLoads (CmmLoad e ty align) = [Load ty align e]+collectExprLoads (CmmReg _)           = []+-- N.B. we don't bother telling TSAN about MO_RelaxedReads+-- since doing so would be inconvenient and they by+-- definition can neither race nor introduce ordering.+collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args+collectExprLoads (CmmStackSlot _ _)   = []+collectExprLoads (CmmRegOff _ _)      = []++-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence.+annotatePrim :: Env+             -> CallishMachOp   -- ^ the applied operation+             -> [CmmFormal]     -- ^ results+             -> [CmmActual]     -- ^ arguments+             -> Maybe (Block CmmNode O O)+                                -- ^ 'Just' a block of instrumentation, if applicable+annotatePrim env (MO_AtomicRMW w aop)    [dest]   [addr, val]  = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest+annotatePrim env (MO_AtomicRead w mord)  [dest]   [addr]       = Just $ tsanAtomicLoad env mord w addr dest+annotatePrim env (MO_AtomicWrite w mord) []       [addr, val]  = Just $ tsanAtomicStore env mord w val addr+annotatePrim env (MO_Xchg w)             [dest]   [addr, val]  = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest+annotatePrim env (MO_Cmpxchg w)          [dest]   [addr, expected, new]+                                                               = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest+annotatePrim _    _                       _        _           = Nothing++mkUnsafeCall :: Env+             -> ForeignTarget  -- ^ function+             -> [CmmFormal]    -- ^ results+             -> [CmmActual]    -- ^ arguments+             -> Block CmmNode O O+mkUnsafeCall env ftgt formals args =+    save `blockAppend`     -- save global registers+    bind_args `blockSnoc`  -- bind arguments to local registers+    call `blockAppend`     -- perform call+    restore                -- restore global registers+  where+    (save, restore) = saveRestoreCallerRegs gregs_us (platform env)++    (arg_us, gregs_us) = splitUniqSupply (uniques env)++    -- We also must be careful not to mention caller-saved registers in+    -- arguments as Cmm-Lint checks this. To accomplish this we instead bind+    -- the arguments to local registers.+    arg_regs :: [CmmReg]+    arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args+      where+        arg_reg :: Unique -> CmmExpr -> CmmReg+        arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)++    bind_args :: Block CmmNode O O+    bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args++    call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs)++-- | We save the contents of global registers in locals and allow the+-- register allocator to spill them to the stack around the call.+-- We cannot use the register table for this since we would interface+-- with {SAVE,RESTORE}_THREAD_STATE.+saveRestoreCallerRegs :: UniqSupply -> Platform+                      -> (Block CmmNode O O, Block CmmNode O O)+saveRestoreCallerRegs us platform =+    (save, restore)+  where+    regs_to_save :: [GlobalReg]+    regs_to_save = filter (callerSaves platform) (activeStgRegs platform)++    nodes :: [(CmmNode O O, CmmNode O O)]+    nodes =+        zipWith mk_reg regs_to_save (uniqsFromSupply us)+      where+        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)+        mk_reg reg u =+            let ty = globalRegSpillType platform reg+                greg = CmmGlobal (GlobalRegUse reg ty)+                lreg = CmmLocal (LocalReg u ty)+                save = CmmAssign lreg (CmmReg greg)+                restore = CmmAssign greg (CmmReg lreg)+            in (save, restore)++    (save_nodes, restore_nodes) = unzip nodes+    save = blockFromList save_nodes+    restore = blockFromList restore_nodes++-- | Mirrors __tsan_memory_order+-- <https://github.com/llvm/llvm-project/blob/main/compiler-rt/include/sanitizer/tsan_interface_atomic.h#L34>+memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr+memoryOrderToTsanMemoryOrder env mord =+    mkIntExpr (platform env) n+  where+    n = case mord of+      MemOrderRelaxed -> 0+      MemOrderAcquire -> 2+      MemOrderRelease -> 3+      MemOrderSeqCst  -> 5++tsanTarget :: FastString     -- ^ function name+           -> [ForeignHint]  -- ^ formals+           -> [ForeignHint]  -- ^ arguments+           -> ForeignTarget+tsanTarget fn formals args =+    ForeignTarget (CmmLit (CmmLabel lbl)) conv+  where+    conv = ForeignConvention CCallConv args formals CmmMayReturn+    lbl = mkForeignLabel fn ForeignLabelInExternalPackage IsFunction++tsanStore :: Env+          -> CmmType -> CmmExpr+          -> Block CmmNode O O+tsanStore env ty addr+  | typeWidth ty < W128 = mkUnsafeCall env ftarget [] [addr]+  | otherwise           = emptyBlock+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = fsLit $ "__tsan_write" ++ show w++tsanLoad :: Env+         -> AlignmentSpec -> CmmType -> CmmExpr+         -> Block CmmNode O O+tsanLoad env align ty addr+  | typeWidth ty < W128  = mkUnsafeCall env ftarget [] [addr]+  | otherwise            = emptyBlock+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = case align of+           Unaligned+             | w > 1    -> fsLit $ "__tsan_unaligned_read" ++ show w+           _            -> fsLit $ "__tsan_read" ++ show w++tsanAtomicStore :: Env+                -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr+                -> Block CmmNode O O+tsanAtomicStore env mord w val addr =+    mkUnsafeCall env ftarget [] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store"++tsanAtomicLoad :: Env+               -> MemoryOrdering -> Width -> CmmExpr -> LocalReg+               -> Block CmmNode O O+tsanAtomicLoad env mord w addr dest =+    mkUnsafeCall env ftarget [dest] [addr, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load"++tsanAtomicExchange :: Env+                   -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg+                   -> Block CmmNode O O+tsanAtomicExchange env mord w val addr dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange"++-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS+-- returns the expected value. We use define a shim in the RTS to provide+-- Cmm's semantics using the TSAN C11 primitive.+tsanAtomicCas :: Env+              -> MemoryOrdering  -- ^ success ordering+              -> MemoryOrdering  -- ^ failure ordering+              -> Width+              -> CmmExpr         -- ^ address+              -> CmmExpr         -- ^ expected value+              -> CmmExpr         -- ^ new value+              -> LocalReg        -- ^ result destination+              -> Block CmmNode O O+tsanAtomicCas env mord_success mord_failure w addr expected new dest =+    mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure']+  where+    mord_success' = memoryOrderToTsanMemoryOrder env mord_success+    mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint]+    fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange"++tsanAtomicRMW :: Env+              -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg+              -> Block CmmNode O O+tsanAtomicRMW env mord op w addr val dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    op' = case op of+           AMO_Add  -> "fetch_add"+           AMO_Sub  -> "fetch_sub"+           AMO_And  -> "fetch_and"+           AMO_Nand -> "fetch_nand"+           AMO_Or   -> "fetch_or"+           AMO_Xor  -> "fetch_xor"+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op'
+ GHC/Cmm/Type.hs view
@@ -0,0 +1,498 @@+module GHC.Cmm.Type+    ( CmmType   -- Abstract+    , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord+    , cInt+    , cmmBits, cmmFloat+    , typeWidth, setCmmTypeWidth+    , cmmEqType, cmmCompatType+    , isFloatType, isGcPtrType, isBitsType+    , isWordAny, isWord32, isWord64+    , isFloat64, isFloat32++    , Width(..)+    , widthInBits, widthInBytes, widthInLog, widthFromBytes+    , wordWidth, halfWordWidth, cIntWidth+    , halfWordMask+    , narrowU, narrowS+    , rEP_CostCentreStack_mem_alloc+    , rEP_CostCentreStack_scc_count+    , rEP_StgEntCounter_allocs+    , rEP_StgEntCounter_allocd++    , ForeignHint(..)++    , Length+    , vec, vec2, vec4, vec8, vec16+    , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8+    , cmmVec+    , vecLength, vecElemType+    , isVecType++    , DoAlignSanitisation+   )+where+++import GHC.Prelude++import GHC.Platform+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Word+import Data.Int++-----------------------------------------------------------------------------+--              CmmType+-----------------------------------------------------------------------------++  -- NOTE: CmmType is an abstract type, not exported from this+  --       module so you can easily change its representation+  --+  -- However Width is exported in a concrete way,+  -- and is used extensively in pattern-matching++data CmmType    -- The important one!+  = CmmType CmmCat !Width+  deriving Show++data CmmCat                -- "Category" (not exported)+   = GcPtrCat              -- ^ GC pointer+   | BitsCat               -- ^ Integer (including non-GC pointer addresses)+                           --+                           -- Makes no distinction between signed and unsigned integers,+                           -- see Note [Signed vs unsigned] in GHC.Cmm.Type.+   | FloatCat              -- ^ Float+   | VecCat Length CmmCat  -- ^ Vector+   deriving( Eq, Show )++instance Outputable CmmType where+  ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)++instance Outputable CmmCat where+  ppr FloatCat       = text "F"+  ppr GcPtrCat       = text "P"+  ppr BitsCat        = text "I"+  ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V"++-- Why is CmmType stratified?  For native code generation,+-- most of the time you just want to know what sort of register+-- to put the thing in, and for this you need to know how+-- many bits thing has, and whether it goes in a floating-point+-- register.  By contrast, the distinction between GcPtr and+-- GcNonPtr is of interest to only a few parts of the code generator.++-------- Equality on CmmType --------------+-- CmmType is *not* an instance of Eq; sometimes we care about the+-- Gc/NonGc distinction, and sometimes we don't+-- So we use an explicit function to force you to think about it+cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality+cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2++-- | A weaker notion of equality of 'CmmType's than 'cmmEqType',+-- used (only) in Cmm Lint.+--+-- Why "weaker"? Because:+--+--  - we don't distinguish GcPtr vs NonGcPtr, because the the RTS files+--    are not yet well-typed wrt pointers,+--  - for vectors, we only compare the widths, because in practice things like+--    X86 xmm registers support different types of data (e.g. 4xf32, 2xf64, 2xu64 etc).+cmmCompatType :: CmmType -> CmmType -> Bool+cmmCompatType (CmmType c1 w1) (CmmType c2 w2)+   = c1 `weak_eq` c2 && w1 == w2+   where+     weak_eq :: CmmCat -> CmmCat -> Bool+     FloatCat    `weak_eq` FloatCat    = True+     FloatCat    `weak_eq` _other      = False+     _other      `weak_eq` FloatCat    = False+     (VecCat {}) `weak_eq` (VecCat {}) = True  -- only compare overall width+     (VecCat {}) `weak_eq` _other      = False+     _other      `weak_eq` (VecCat {}) = False+     _word1      `weak_eq` _word2      = True  -- Ignores GcPtr++--- Simple operations on CmmType -----+typeWidth :: CmmType -> Width+typeWidth (CmmType _ w) = w++setCmmTypeWidth :: Width -> CmmType -> CmmType+setCmmTypeWidth w (CmmType c _) = CmmType c w++cmmBits, cmmFloat :: Width -> CmmType+cmmBits  = CmmType BitsCat+cmmFloat = CmmType FloatCat++-------- Common CmmTypes ------------+-- Floats and words of specific widths+b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType+b8     = cmmBits W8+b16    = cmmBits W16+b32    = cmmBits W32+b64    = cmmBits W64+b128   = cmmBits W128+b256   = cmmBits W256+b512   = cmmBits W512+f32    = cmmFloat W32+f64    = cmmFloat W64++-- CmmTypes of native word widths+bWord :: Platform -> CmmType+bWord platform = cmmBits (wordWidth platform)++bHalfWord :: Platform -> CmmType+bHalfWord platform = cmmBits (halfWordWidth platform)++gcWord :: Platform -> CmmType+gcWord platform = CmmType GcPtrCat (wordWidth platform)++cInt :: Platform -> CmmType+cInt platform = cmmBits (cIntWidth platform)++------------ Predicates ----------------+isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool+isFloatType (CmmType FloatCat    _) = True+isFloatType _other                  = False++isGcPtrType (CmmType GcPtrCat _) = True+isGcPtrType _other               = False++isBitsType (CmmType BitsCat _) = True+isBitsType _                   = False++isWordAny, isWord32, isWord64,+  isFloat32, isFloat64 :: CmmType -> Bool+-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)+-- isFloat32 and 64 are obvious++isWordAny (CmmType BitsCat  _) = True+isWordAny (CmmType GcPtrCat _) = True+isWordAny _other               = False++isWord64 (CmmType BitsCat  W64) = True+isWord64 (CmmType GcPtrCat W64) = True+isWord64 _other                 = False++isWord32 (CmmType BitsCat  W32) = True+isWord32 (CmmType GcPtrCat W32) = True+isWord32 _other                 = False++isFloat32 (CmmType FloatCat W32) = True+isFloat32 _other                 = False++isFloat64 (CmmType FloatCat W64) = True+isFloat64 _other                 = False++-----------------------------------------------------------------------------+--              Width+-----------------------------------------------------------------------------++data Width+  = W8+  | W16+  | W32+  | W64+  | W128+  | W256+  | W512+  deriving (Eq, Ord, Show)++instance Outputable Width where+   ppr rep = text (show rep)++-------- Common Widths  ------------++-- | The width of the current platform's word size.+wordWidth :: Platform -> Width+wordWidth platform = case platformWordSize platform of+ PW4 -> W32+ PW8 -> W64++-- | The width of the current platform's half-word size.+halfWordWidth :: Platform -> Width+halfWordWidth platform = case platformWordSize platform of+ PW4 -> W16+ PW8 -> W32++-- | A bit-mask for the lower half-word of current platform.+halfWordMask :: Platform -> Integer+halfWordMask platform = case platformWordSize platform of+ PW4 -> 0xFFFF+ PW8 -> 0xFFFFFFFF++-- cIntRep is the Width for a C-language 'int'+cIntWidth :: Platform -> Width+cIntWidth platform = case pc_CINT_SIZE (platformConstants platform) of+                   4 -> W32+                   8 -> W64+                   s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)++-- | A width in bits.+widthInBits :: Width -> Int+widthInBits W8   = 8+widthInBits W16  = 16+widthInBits W32  = 32+widthInBits W64  = 64+widthInBits W128 = 128+widthInBits W256 = 256+widthInBits W512 = 512++-- | A width in bytes.+--+-- > widthFromBytes (widthInBytes w) === w+widthInBytes :: Width -> Int+widthInBytes W8   = 1+widthInBytes W16  = 2+widthInBytes W32  = 4+widthInBytes W64  = 8+widthInBytes W128 = 16+widthInBytes W256 = 32+widthInBytes W512 = 64+++-- | *Partial* A width from the number of bytes.+widthFromBytes :: Int -> Width+widthFromBytes 1  = W8+widthFromBytes 2  = W16+widthFromBytes 4  = W32+widthFromBytes 8  = W64+widthFromBytes 16 = W128+widthFromBytes 32 = W256+widthFromBytes 64 = W512++widthFromBytes n  = pprPanic "no width for given number of bytes" (ppr n)++-- | log_2 of the width in bytes, useful for generating shifts.+widthInLog :: Width -> Int+widthInLog W8   = 0+widthInLog W16  = 1+widthInLog W32  = 2+widthInLog W64  = 3+widthInLog W128 = 4+widthInLog W256 = 5+widthInLog W512 = 6+++-- widening / narrowing++-- | Narrow a signed or unsigned value to the given width. The result will+-- reside in @[0, +2^width)@.+--+-- >>> narrowU W8 256    == 256+-- >>> narrowU W8 255    == 255+-- >>> narrowU W8 128    == 128+-- >>> narrowU W8 127    == 127+-- >>> narrowU W8 0      == 0+-- >>> narrowU W8 (-127) == 129+-- >>> narrowU W8 (-128) == 128+-- >>> narrowU W8 (-129) == 127+-- >>> narrowU W8 (-255) == 1+-- >>> narrowU W8 (-256) == 0+--+narrowU :: Width -> Integer -> Integer+narrowU W8  x = fromIntegral (fromIntegral x :: Word8)+narrowU W16 x = fromIntegral (fromIntegral x :: Word16)+narrowU W32 x = fromIntegral (fromIntegral x :: Word32)+narrowU W64 x = fromIntegral (fromIntegral x :: Word64)+narrowU _ _ = panic "narrowTo"++-- | Narrow a signed value to the given width. The result will reside+-- in @[-2^(width-1), +2^(width-1))@.+--+-- >>> narrowS W8 256    == 0+-- >>> narrowS W8 255    == -1+-- >>> narrowS W8 128    == -128+-- >>> narrowS W8 127    == 127+-- >>> narrowS W8 0      == 0+-- >>> narrowS W8 (-127) == -127+-- >>> narrowS W8 (-128) == -128+-- >>> narrowS W8 (-129) == 127+-- >>> narrowS W8 (-255) == 1+-- >>> narrowS W8 (-256) == 0+--+narrowS :: Width -> Integer -> Integer+narrowS W8  x = fromIntegral (fromIntegral x :: Int8)+narrowS W16 x = fromIntegral (fromIntegral x :: Int16)+narrowS W32 x = fromIntegral (fromIntegral x :: Int32)+narrowS W64 x = fromIntegral (fromIntegral x :: Int64)+narrowS _ _ = panic "narrowTo"++-----------------------------------------------------------------------------+--              SIMD+-----------------------------------------------------------------------------++type Length = Int++vec :: Length -> CmmType -> CmmType+vec l (CmmType cat w) = CmmType (VecCat l cat) vecw+  where+    vecw :: Width+    vecw = widthFromBytes (l*widthInBytes w)++vec2, vec4, vec8, vec16 :: CmmType -> CmmType+vec2  = vec 2+vec4  = vec 4+vec8  = vec 8+vec16 = vec 16++vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType+vec2f64 = vec 2 f64+vec2b64 = vec 2 b64+vec4f32 = vec 4 f32+vec4b32 = vec 4 b32+vec8b16 = vec 8 b16+vec16b8 = vec 16 b8++cmmVec :: Int -> CmmType -> CmmType+cmmVec n (CmmType cat w) =+    CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w))++vecLength :: CmmType -> Length+vecLength (CmmType (VecCat l _) _) = l+vecLength _                        = panic "vecLength: not a vector"++vecElemType :: CmmType -> CmmType+vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw+  where+    scalw :: Width+    scalw = widthFromBytes (widthInBytes w `div` l)+vecElemType _ = panic "vecElemType: not a vector"++isVecType :: CmmType -> Bool+isVecType (CmmType (VecCat {}) _) = True+isVecType _                       = False++-------------------------------------------------------------------------+-- Hints++-- Hints are extra type information we attach to the arguments and+-- results of a foreign call, where more type information is sometimes+-- needed by the ABI to make the correct kind of call.+--+-- See Note [Signed vs unsigned] for one case where this is used.++data ForeignHint+  = NoHint | AddrHint | SignedHint+  deriving( Eq )+        -- Used to give extra per-argument or per-result+        -- information needed by foreign calling conventions++instance Outputable ForeignHint where+  ppr NoHint     = empty+  ppr SignedHint = quotes(text "signed")+--  ppr AddrHint   = quotes(text "address")+-- Temp Jan08+  ppr AddrHint   = (text "PtrHint")+++-------------------------------------------------------------------------++-- These don't really belong here, but I don't know where is best to+-- put them.++rEP_CostCentreStack_mem_alloc :: Platform -> CmmType+rEP_CostCentreStack_mem_alloc platform+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))+    where pc = platformConstants platform++rEP_CostCentreStack_scc_count :: Platform -> CmmType+rEP_CostCentreStack_scc_count platform+    = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))+    where pc = platformConstants platform++rEP_StgEntCounter_allocs :: Platform -> CmmType+rEP_StgEntCounter_allocs platform+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))+    where pc = platformConstants platform++rEP_StgEntCounter_allocd :: Platform -> CmmType+rEP_StgEntCounter_allocd platform+    = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))+    where pc = platformConstants platform++-------------------------------------------------------------------------+{-      Note [Signed vs unsigned]+        ~~~~~~~~~~~~~~~~~~~~~~~~~+Should a CmmType include a signed vs. unsigned distinction?++This is very much like a "hint" in C-- terminology: it isn't necessary+in order to generate correct code, but it might be useful in that the+compiler can generate better code if it has access to higher-level+hints about data.  This is important at call boundaries, because the+definition of a function is not visible at all of its call sites, so+the compiler cannot infer the hints.++Here in Cmm, we're taking a slightly different approach.  We include+the int vs. float hint in the CmmType, because (a) the majority of+platforms have a strong distinction between float and int registers,+and (b) we don't want to do any heavyweight hint-inference in the+native code backend in order to get good code.  We're treating the+hint more like a type: our Cmm is always completely consistent with+respect to hints.  All coercions between float and int are explicit.++What about the signed vs. unsigned hint?  This information might be+useful if we want to keep sub-word-sized values in word-size+registers, which we must do if we only have word-sized registers.++On such a system, there are two straightforward conventions for+representing sub-word-sized values:++(a) Leave the upper bits undefined.  Comparison operations must+    sign- or zero-extend both operands before comparing them,+    depending on whether the comparison is signed or unsigned.++(b) Always keep the values sign- or zero-extended as appropriate.+    Arithmetic operations must narrow the result to the appropriate+    size.++A clever compiler might not use either (a) or (b) exclusively, instead+it would attempt to minimize the coercions by analysis: the same kind+of analysis that propagates hints around.  In Cmm we don't want to+have to do this, so we plump for having richer types and keeping the+type information consistent.++If signed/unsigned hints are missing from CmmType, then the only+choice we have is (a), because we don't know whether the result of an+operation should be sign- or zero-extended.++Many architectures have extending load operations, which work well+with (b).  To make use of them with (a), you need to know whether the+value is going to be sign- or zero-extended by an enclosing comparison+(for example), which involves knowing above the context.  This is+doable but more complex.++Further complicating the issue is foreign calls: a foreign calling+convention can specify that signed 8-bit quantities are passed as+sign-extended 32 bit quantities, for example (this is the case on the+PowerPC).  So we *do* need sign information on foreign call arguments.++Pros for adding signed vs. unsigned to CmmType:++  - It would let us use convention (b) above, and get easier+    code generation for extending loads.++  - Less information required on foreign calls.++  - MachOp type would be simpler++Cons:++  - More complexity++  - What is the CmmType for a VanillaReg?  Currently it is+    always wordRep, but now we have to decide whether it is+    signed or unsigned.  The same VanillaReg can thus have+    different CmmType in different parts of the program.++  - Extra coercions cluttering up expressions.++Currently for GHC, the foreign call point is moot, because we do our+own promotion of sub-word-sized values to word-sized values.  The Int8+type is represented by an Int# which is kept sign-extended at all times+(this is slightly naughty, because we're making assumptions about the+C calling convention rather early on in the compiler).  However, given+this, the cons outweigh the pros.++-}++-- | is @-falignment-sanitisation@ enabled?+type DoAlignSanitisation = Bool
+ GHC/Cmm/UniqueRenamer.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}+module GHC.Cmm.UniqueRenamer+  ( detRenameCmmGroup+  , detRenameIPEMap+  , MonadGetUnique(..)++  -- Careful! Not for general use!+  , DetUniqFM, emptyDetUFM++  , module GHC.Types.Unique.DSM+  )+  where++import GHC.Prelude+import GHC.Utils.Monad.State.Strict+import Data.Tuple (swap)+import GHC.Word+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Switch+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Utils.Outputable as Outputable+import GHC.Types.Id+import GHC.Types.Unique.DSM+import GHC.Types.Name hiding (varName)+import GHC.Types.Var+import GHC.Types.IPE++{-+Note [Renaming uniques deterministically]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As mentioned by Note [Object determinism], a key step in producing+deterministic objects is to rename all existing uniques deterministically.++An important observation is that GHC already produces code in a deterministic+order, both declarations (say, A_closure always comes before B_closure) and the+instructions and data within.++We can leverage this /deterministic order/ to+rename all uniques deterministically, by traversing, specifically, Cmm code+fresh off of StgToCmm and assigning a new unique from a deterministic supply+(an incrementing counter) to every non-external unique in the order they are found.++Since the order is deterministic across runs, so will the renamed uniques.++This Cmm renaming pass is guarded by -fobject-determinism because it means the+compiler must do more work. However, performance profiling has shown the impact+to be small enough that we should consider enabling -fobject-determinism by+default instead eventually.+-}++-- | A mapping from non-deterministic uniques to deterministic uniques, to+-- rename local symbols with the end goal of producing deterministic object files.+-- See Note [Renaming uniques deterministically]+data DetUniqFM = DetUniqFM+  { mapping :: !(UniqFM Unique Unique)+  , supply  :: !Word64+  }++instance Outputable DetUniqFM where+  ppr DetUniqFM{mapping, supply} =+    ppr mapping $$+    text "supply:" Outputable.<> ppr supply++type DetRnM = State DetUniqFM++emptyDetUFM :: DetUniqFM+emptyDetUFM = DetUniqFM+  { mapping = emptyUFM+  -- NB: A lower initial value can get us label `Lsl` which is not parsed+  -- correctly in older versions of LLVM assembler (llvm-project#80571)+  -- So we use an `x` s.t. w64ToBase62 x > "R" > "L" > "r" > "l"+  , supply = 54+  }++renameDetUniq :: Unique -> DetRnM Unique+renameDetUniq uq = do+  m <- gets mapping+  case lookupUFM m uq of+    Nothing -> do+      new_w <- gets supply -- New deterministic unique in this `DetRnM`+      let --(_tag, _) = unpkUnique uq+          det_uniq = mkUnique 'Q' new_w+      modify (\DetUniqFM{mapping, supply} ->+        -- Update supply and mapping+        DetUniqFM+          { mapping = addToUFM mapping uq det_uniq+          , supply = supply + 1+          })+      return det_uniq+    Just det_uniq ->+      return det_uniq++-- The most important function here, which does the actual renaming.+detRenameCLabel :: CLabel -> DetRnM CLabel+detRenameCLabel = mapInternalNonDetUniques renameDetUniq++-- | We want to rename uniques in Ids, but ONLY internal ones.+detRenameId :: Id -> DetRnM Id+detRenameId i+  | isExternalName (varName i) = return i+  | otherwise = setIdUnique i <$> renameDetUniq (getUnique i)++-- | Similar to `detRenameId`, but for `Name`.+detRenameName :: Name -> DetRnM Name+detRenameName n+  | isExternalName n = return n+  | otherwise = setNameUnique n <$> renameDetUniq (getUnique n)++detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup)+detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm)+  where+    detRenameCmmDecl :: DCmmDecl -> DetRnM CmmDecl+    detRenameCmmDecl (CmmProc h lbl regs g)+      = do+        h' <- detRenameCmmTop h+        lbl' <- detRenameCLabel lbl+        regs' <- mapM detRenameGlobalRegUse regs+        g' <- detRenameCmmGraph g+        return (CmmProc h' lbl' regs' g')+    detRenameCmmDecl (CmmData sec d)+      = CmmData <$> detRenameSection sec <*> detRenameCmmStatics d++    detRenameCmmTop :: DCmmTopInfo -> DetRnM CmmTopInfo+    detRenameCmmTop (TopInfo (DWrap i) b)+      = TopInfo . mapFromList <$> mapM (detRenamePair detRenameLabel detRenameCmmInfoTable) i <*> pure b++    detRenameCmmGraph :: DCmmGraph -> DetRnM CmmGraph+    detRenameCmmGraph (CmmGraph entry bs)+      = CmmGraph <$> detRenameLabel entry <*> detRenameGraph bs++    detRenameGraph = \case+      GNil  -> pure GNil+      GUnit block -> GUnit <$> detRenameBlock block+      GMany m1 b m2 -> GMany <$> detRenameMaybeBlock m1 <*> detRenameBody b <*> detRenameMaybeBlock m2++    detRenameBody (DWrap b)+      = mapFromList <$> mapM (detRenamePair detRenameLabel detRenameBlock) b++    detRenameCmmStatics :: CmmStatics -> DetRnM CmmStatics+    detRenameCmmStatics+      (CmmStatics clbl info ccs lits1 lits2)+        = CmmStatics <$> detRenameCLabel clbl <*> detRenameCmmInfoTable info <*> pure ccs <*> mapM detRenameCmmLit lits1 <*> mapM detRenameCmmLit lits2+    detRenameCmmStatics+      (CmmStaticsRaw lbl sts)+        = CmmStaticsRaw <$> detRenameCLabel lbl <*> mapM detRenameCmmStatic sts++    detRenameCmmInfoTable :: CmmInfoTable -> DetRnM CmmInfoTable+    detRenameCmmInfoTable+      CmmInfoTable{cit_lbl, cit_rep, cit_prof, cit_srt, cit_clo}+        = CmmInfoTable <$> detRenameCLabel cit_lbl <*> pure cit_rep <*> pure cit_prof <*> detRenameMaybe detRenameCLabel cit_srt <*>+           (case cit_clo of+              Nothing -> pure Nothing+              Just (an_id, ccs) -> Just . (,ccs) <$> detRenameId an_id)++    detRenameCmmStatic :: CmmStatic -> DetRnM CmmStatic+    detRenameCmmStatic = \case+      CmmStaticLit l -> CmmStaticLit <$> detRenameCmmLit l+      CmmUninitialised x -> pure $ CmmUninitialised x+      CmmString x -> pure $ CmmString x+      CmmFileEmbed f i -> pure $ CmmFileEmbed f i++    detRenameCmmLit :: CmmLit -> DetRnM CmmLit+    detRenameCmmLit = \case+      CmmInt i w -> pure $ CmmInt i w+      CmmFloat r w -> pure $ CmmFloat r w+      CmmVec lits -> CmmVec <$> mapM detRenameCmmLit lits+      CmmLabel lbl -> CmmLabel <$> detRenameCLabel lbl+      CmmLabelOff lbl i -> CmmLabelOff <$> detRenameCLabel lbl <*> pure i+      CmmLabelDiffOff lbl1 lbl2 i w ->+        CmmLabelDiffOff <$> detRenameCLabel lbl1 <*> detRenameCLabel lbl2 <*> pure i <*> pure w+      CmmBlock bid -> CmmBlock <$> detRenameLabel bid+      CmmHighStackMark -> pure CmmHighStackMark++    detRenameMaybeBlock :: MaybeO n (Block CmmNode a b) -> DetRnM (MaybeO n (Block CmmNode a b))+    detRenameMaybeBlock (JustO x) = JustO <$> detRenameBlock x+    detRenameMaybeBlock NothingO = pure NothingO++    detRenameBlock :: Block CmmNode n m -> DetRnM (Block CmmNode n m)+    detRenameBlock = \case+      BlockCO n bn -> BlockCO <$> detRenameCmmNode n <*> detRenameBlock bn+      BlockCC n1 bn n2 -> BlockCC <$> detRenameCmmNode n1 <*> detRenameBlock bn <*> detRenameCmmNode n2+      BlockOC bn n -> BlockOC <$> detRenameBlock bn <*> detRenameCmmNode n+      BNil    -> pure BNil+      BMiddle n -> BMiddle <$> detRenameCmmNode n+      BCat    b1 b2 -> BCat <$> detRenameBlock b1 <*> detRenameBlock b2+      BSnoc   bn n -> BSnoc <$> detRenameBlock bn <*> detRenameCmmNode n+      BCons   n bn -> BCons <$> detRenameCmmNode n <*> detRenameBlock bn++    detRenameCmmNode :: CmmNode n m -> DetRnM (CmmNode n m)+    detRenameCmmNode = \case+      CmmEntry l t -> CmmEntry <$> detRenameLabel l <*> detRenameCmmTick t+      CmmComment fs -> pure $ CmmComment fs+      CmmTick tickish -> pure $ CmmTick tickish+      CmmUnwind xs -> CmmUnwind <$> mapM (detRenamePair detRenameGlobalReg (detRenameMaybe detRenameCmmExpr)) xs+      CmmAssign reg e -> CmmAssign <$> detRenameCmmReg reg <*> detRenameCmmExpr e+      CmmStore e1 e2 align -> CmmStore <$> detRenameCmmExpr e1 <*> detRenameCmmExpr e2 <*> pure align+      CmmUnsafeForeignCall ftgt cmmformal cmmactual ->+        CmmUnsafeForeignCall <$> detRenameForeignTarget ftgt <*> mapM detRenameLocalReg cmmformal <*> mapM detRenameCmmExpr cmmactual+      CmmBranch l -> CmmBranch <$> detRenameLabel l+      CmmCondBranch pred t f likely ->+        CmmCondBranch <$> detRenameCmmExpr pred <*> detRenameLabel t <*> detRenameLabel f <*> pure likely+      CmmSwitch e sts -> CmmSwitch <$> detRenameCmmExpr e <*> mapSwitchTargetsA detRenameLabel sts+      CmmCall tgt cont regs args retargs retoff ->+        CmmCall <$> detRenameCmmExpr tgt <*> detRenameMaybe detRenameLabel cont <*> mapM detRenameGlobalRegUse regs+                <*> pure args <*> pure retargs <*> pure retoff+      CmmForeignCall tgt res args succ retargs retoff intrbl ->+        CmmForeignCall <$> detRenameForeignTarget tgt <*> mapM detRenameLocalReg res <*> mapM detRenameCmmExpr args+                       <*> detRenameLabel succ <*> pure retargs <*> pure retoff <*> pure intrbl++    detRenameCmmExpr :: CmmExpr -> DetRnM CmmExpr+    detRenameCmmExpr = \case+      CmmLit l -> CmmLit <$> detRenameCmmLit l+      CmmLoad e t a -> CmmLoad <$> detRenameCmmExpr e <*> pure t <*> pure a+      CmmReg r -> CmmReg <$> detRenameCmmReg r+      CmmMachOp mop es -> CmmMachOp mop <$> mapM detRenameCmmExpr es+      CmmStackSlot a i -> CmmStackSlot <$> detRenameArea a <*> pure i+      CmmRegOff r i -> CmmRegOff <$> detRenameCmmReg r <*> pure i++    detRenameForeignTarget :: ForeignTarget -> DetRnM ForeignTarget+    detRenameForeignTarget = \case+        ForeignTarget e fc -> ForeignTarget <$> detRenameCmmExpr e <*> pure fc+        PrimTarget cmop -> pure $ PrimTarget cmop++    detRenameArea :: Area -> DetRnM Area+    detRenameArea Old = pure Old+    detRenameArea (Young l) = Young <$> detRenameLabel l++    detRenameLabel :: Label -> DetRnM Label+    detRenameLabel lbl+      = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)++    detRenameSection :: Section -> DetRnM Section+    detRenameSection (Section ty lbl)+      = Section ty <$> detRenameCLabel lbl++    detRenameCmmReg :: CmmReg -> DetRnM CmmReg+    detRenameCmmReg = \case+      CmmLocal l -> CmmLocal <$> detRenameLocalReg l+      CmmGlobal x -> pure $ CmmGlobal x++    detRenameLocalReg :: LocalReg -> DetRnM LocalReg+    detRenameLocalReg (LocalReg uq t)+      = LocalReg <$> renameDetUniq uq <*> pure t++    -- Global registers don't need to be renamed.+    detRenameGlobalReg :: GlobalReg -> DetRnM GlobalReg+    detRenameGlobalReg = pure+    detRenameGlobalRegUse :: GlobalRegUse -> DetRnM GlobalRegUse+    detRenameGlobalRegUse = pure++    -- todo: We may have to change this to get deterministic objects with ticks.+    detRenameCmmTick :: CmmTickScope -> DetRnM CmmTickScope+    detRenameCmmTick = pure++    detRenameMaybe _ Nothing = pure Nothing+    detRenameMaybe f (Just x) = Just <$> f x++    detRenamePair f g (a, b) = (,) <$> f a <*> g b++detRenameIPEMap :: DetUniqFM -> InfoTableProvMap -> (DetUniqFM, InfoTableProvMap)+detRenameIPEMap dufm InfoTableProvMap{ provDC, provClosure, provInfoTables } =+    (dufm2, InfoTableProvMap { provDC, provClosure = cm, provInfoTables })+  where+    (cm, dufm2) = runState (detRenameClosureMap provClosure) dufm++    detRenameClosureMap :: ClosureMap -> DetRnM ClosureMap+    detRenameClosureMap m =+      -- `eltsUDFM` preserves the deterministic order, but it doesn't matter+      -- since we will rename all uniques deterministically, thus the+      -- reconstructed map will necessarily be deterministic too.+      listToUDFM <$> mapM (\(n,r) -> do+        n' <- detRenameName n+        return (n', (n', r))+        ) (eltsUDFM m)
+ GHC/Cmm/Utils.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++-----------------------------------------------------------------------------+--+-- 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, globalRegsOverlap, regUsedIn, globalRegUsedIn,++        -- 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  ( NvUnaryType, SlotTy (..), typePrimRepU )++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 Data.Foldable (toList)+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Block++---------------------------------------------------+--+--      CmmTypes+--+---------------------------------------------------++primRepCmmType :: Platform -> PrimRep -> CmmType+primRepCmmType platform = \case+   BoxedRep _       -> 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 -> NvUnaryType -> CmmType+typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty)++primRepForeignHint :: PrimRep -> ForeignHint+primRepForeignHint (BoxedRep _) = 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 :: NvUnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRepU++---------------------------------------------------+--+--      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 (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _))+  = globalRegsOverlap platform g1 g2+regsOverlap _ reg reg' = reg == reg'++globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool+globalRegsOverlap platform g1 g2+  | Just real  <- globalRegMaybe platform g1+  , Just real' <- globalRegMaybe platform g2+  , real == real'+  = True+  | otherwise+  = g1 == g2++-- | 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++globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool+globalRegUsedIn platform = globalRegUsedIn_ where+  _   `globalRegUsedIn_` CmmLit _+    = False+  reg `globalRegUsedIn_` CmmLoad e _ _+    = reg `globalRegUsedIn_` e+  reg `globalRegUsedIn_` CmmReg reg'+    | CmmGlobal (GlobalRegUse reg' _) <- reg'+    = globalRegsOverlap platform reg reg'+    | otherwise+    = False+  reg `globalRegUsedIn_` CmmRegOff reg' _+    | CmmGlobal (GlobalRegUse reg' _) <- reg'+    = globalRegsOverlap platform reg reg'+    | otherwise+    = False+  reg `globalRegUsedIn_` CmmMachOp _ es+    = any (reg `globalRegUsedIn_`) es+  _   `globalRegUsedIn_` 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 = do+    entry_block <- toList $ mapLookup entry_id m+    entry_block : filter ((/= entry_id) . entryLabel) (mapElems m)+  where+    m = toBlockMap g+    entry_id = g_entry g++-- | 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 = dfs setEmpty $ toList $ mapLookup entry_id m+  where+    m = toBlockMap g+    entry_id = g_entry g++    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 :: Platform -> CmmExpr+baseExpr           p = CmmReg $ baseReg           p+spExpr             p = CmmReg $ spReg             p+spLimExpr          p = CmmReg $ spLimReg          p+hpExpr             p = CmmReg $ hpReg             p+hpLimExpr          p = CmmReg $ hpLimReg          p+currentTSOExpr     p = CmmReg $ currentTSOReg     p+currentNurseryExpr p = CmmReg $ currentNurseryReg p+cccsExpr           p = CmmReg $ cccsReg           p
+ GHC/CmmToAsm.hs view
@@ -0,0 +1,940 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+--+-- -----------------------------------------------------------------------------++-- | Note [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. (Which ideally would be folded into CmmOpt ...)+--+-- We convert to the machine-specific 'Instr' datatype with+-- 'cmmCodeGen', assuming an infinite supply of registers.  We then use+-- a (mostly) machine-independent register allocator to rejoin+-- reality.  Obviously, 'regAlloc' has machine-specific helper+-- functions (see the used register allocator for details).+--+-- 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 are generally contained under+--  GHC/CmmToAsm/<Arch>/* and generally breaks down as follows:+--+--   * "Regs": Everything about the target platform's machine+--     registers (and immediate operands, and addresses, which tend to+--     intermingle/interact with registers).+--+--   * "Instr":  Includes the 'Instr' datatype plus a miscellany of other things+--     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)+--+--   * "CodeGen":  is where 'Cmm' stuff turns into+--     machine instructions.+--+--   * "Ppr": 'pprInstr' turns an 'Instr' into text (well, really+--     a 'SDoc').+--+-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph+-- based register allocator. Both of which have their own notes describing them. They+-- are mostly platform independent but there are some platform specific files+-- encoding architecture details under Reg/<Allocator>/<Arch.hs>+--+-- -}+--+module GHC.CmmToAsm+   ( nativeCodeGen++   -- * Test-only exports: see #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 qualified GHC.CmmToAsm.RV64  as RV64+import qualified GHC.CmmToAsm.LA64 as LA64++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.Dataflow.Label+import GHC.Cmm.GenericOpt+import GHC.Cmm.CLabel++import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+import GHC.Driver.DynFlags+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.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (liftIO)+import qualified GHC.Data.Stream as Stream+import GHC.Settings++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 -> ToolSettings -> NCGConfig -> ModLocation -> Handle+              -> CgStream RawCmmGroup a+              -> UniqDSMT IO a+nativeCodeGen logger ts config modLoc h cmms+ = let platform = ncgPlatform config+       nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)+            => NcgImpl statics instr jumpDest -> UniqDSMT IO a+       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h 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   -> nCG' (RV64.ncgRV64 config)+      ArchLoongArch64 -> nCG' (LA64.ncgLA64 config)+      ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"+      ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"+      ArchWasm32    -> Wasm32.ncgWasm config logger platform ts 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+               -> CgStream RawCmmGroup a+               -> UniqDSMT IO a+nativeCodeGen' logger config modLoc ncgImpl h 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 <- liftIO $ newBufHandle h+        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty+        (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0+        _ <- finishNativeGen logger config modLoc bufh ngs+        return a++finishNativeGen :: Instruction instr+                => Logger+                -> NCGConfig+                -> ModLocation+                -> BufHandle+                -> NativeGenAcc statics instr+                -> UniqDSMT IO ()+finishNativeGen logger config modLoc bufh ngs+ = withTimingSilent logger (text "NCG") (`seq` ()) $ do+      -- Write debug data and finish+      if not (ncgDwarfEnabled config)+        then return ()+        else withDUS $ \us -> 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')+      liftIO $ do++        -- dump global NCG stats for graph coloring allocator+        let stats = concat (ngs_colorStats ngs)+            platform = ncgPlatform config+        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)+++          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 platform (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 ()+  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+              -> CgStream RawCmmGroup a+              -> NativeGenAcc statics instr+              -> UniqDSMT IO (NativeGenAcc statics instr, a)++cmmNativeGenStream logger config modLoc ncgImpl h cmm_stream ngs+ = loop (Stream.runStream cmm_stream) ngs+  where+    ncglabel = text "NCG"+    loop :: Stream.StreamS (UniqDSMT IO) RawCmmGroup a+         -> NativeGenAcc statics instr+         -> UniqDSMT IO (NativeGenAcc statics instr, a)+    loop 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+                      },+                  a)+        Stream.Effect m -> m >>= \cmm_stream' -> loop cmm_stream' ngs+        Stream.Yield cmms cmm_stream' -> do+          ngs'' <-+            withTimingSilent logger ncglabel (`seq` ()) $ do+              -- Generate debug information+              let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms+                         | otherwise              = []+                  dbgMap = debugToMap ndbgs++              -- Generate native code+              ngs' <- withDUS $ cmmNativeGens logger config ncgImpl h+                                  dbgMap 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) $ liftIO $+                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 ngs''++          loop 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+              -> [RawCmmDecl]+              -> NativeGenAcc statics instr+              -> Int+              -> DUniqSupply+              -> IO (NativeGenAcc statics instr, DUniqSupply)++cmmNativeGens logger config ncgImpl h dbgMap = go+  where+    go :: [RawCmmDecl]+       -> NativeGenAcc statics instr -> Int -> DUniqSupply+       -> IO (NativeGenAcc statics instr, DUniqSupply)++    go [] ngs !_ !us =+        return (ngs, us)++    go (cmm : cmms) ngs count us = do+        let fileIds = ngs_dwarfFiles ngs+        (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)+          <- {-# 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 is_valid_label isMetaInstr native else []+            is_valid_label+              -- filter dead labels: asm-shortcutting may remove some blocks+              -- (#22792)+              | Just cfg <- mcfg = hasNode cfg+              | otherwise        = const True++            !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 cmms ngs' (count + 1) us'+++-- 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+        -> DUniqSupply+        -> DwarfFiles+        -> LabelMap DebugBlock+        -> RawCmmDecl                                   -- ^ the cmm to generate code for+        -> Int                                          -- ^ sequence number of this top thing+        -> IO   ( DUniqSupply+                , 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+                , Maybe CFG                                 -- final CFG+                )++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" #-}+                runUniqueDSM 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" #-}+                runUniqueDSM 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" #-}+                          runUniqueDSM usLive+                          $ Color.regAlloc+                                config+                                alloc_regs+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])+                                (maxSpillSlots ncgImpl)+                                withLiveness+                                livenessCfg++                let ((alloced', stack_updt_blks), usAlloc')+                        = runUniqueDSM 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" #-}+                          runUniqueDSM 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+        -- sequenced :: [NatCmmDecl statics instr]+        let (sequenced, us_seq) =+                        {-# SCC "sequenceBlocks" #-}+                        runUniqueDSM usAlloc $ mapM (BlockLayout.sequenceTop+                                ncgImpl optimizedCFG)+                            shorted++        massert (checkLayout shorted sequenced)++        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  ( us_seq+                , fileIds'+                , branchOpt+                , lastMinuteImports ++ imports+                , ppr_raStatsColor+                , ppr_raStatsLinear+                , unwinds+                , optimizedCFG+                )++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]+            -> Bool+checkLayout procsUnsequenced procsSequenced =+        assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)+        True+  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++-- Note [No asm-shortcutting on Darwin]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Asm-shortcutting may produce relative references to symbols defined in+-- other compilation units. This is not something that MachO relocations+-- support (see #21972). For this reason we disable the optimisation on Darwin.+-- We do so in the backend without a warning since this flag is enabled by+-- `-O2`.+--+-- Another way to address this issue would be to rather implement a+-- PLT-relocatable jump-table strategy. However, this would only benefit Darwin+-- and does not seem worth the effort as this optimisation generally doesn't+-- offer terribly great benefits.++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+    -- See Note [No asm-shortcutting on Darwin]+  , not $ osMachOTarget $ platformOS $ ncgPlatform 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+        -> UniqDSM+                ( [NatCmmDecl statics instr]+                , [CLabel]+                , DwarfFiles+                , CFG+                )++genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg+  = UDSM $ \initial_us -> do+      { 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 DUniqResult+              (new_tops, final_imports+                , natm_fileid final_st, final_cfg) (natm_us final_st)+        else DUniqResult (pprPanic "genMachCode: nonzero final delta" (int final_delta)) undefined+      }
+ GHC/CmmToAsm/AArch64.hs view
@@ -0,0 +1,62 @@+{-# 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        = AArch64.makeFarBranches+       ,extractUnwindPoints       = const []+       ,invertCondBranches        = \_ _ blocks -> blocks+  }+    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+        canFallthroughTo        = AArch64.canFallthroughTo+        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
+ GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -0,0 +1,2577 @@+{-# language GADTs, LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module GHC.CmmToAsm.AArch64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+    , makeFarBranches+)++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, getNewLabelNat, getThisModuleNat+   )+-- 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.Label+import GHC.Cmm.Dataflow.Graph+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )+import GHC.Types.Unique.DSM++-- The rest:+import GHC.Data.OrdList+import GHC.Utils.Outputable++import Control.Monad    ( mapAndUnzipM )+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)+import GHC.Utils.Monad (mapAccumLM)++-- 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 (LexicalFastString name))+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col (unpackFS name)+    _ -> return nilOL+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs 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 may extract+  -- LDATAs here too (if they are implemented by AArch64 again - See+  -- PPC how to do that.)+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs++  return (BasicBlock id top : other_blocks, statics)++mkBlocks :: Instr+          -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+          -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+  = ([], BasicBlock id instrs : blocks, statics)+mkBlocks instr (instrs,blocks,statics)+  = (instr:instrs, 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 could 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++-- | Generate jump to jump table target+--+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the relative address to jump to (relative+-- to the jump table's first entry / the table's own label).+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  let fmt = II64+  targetReg <- getNewRegNat fmt+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg dynRef+  let code =+        toOL+          [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),+            COMMENT (text "dynRef" <+> (text . show) dynRef)+          ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [ COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (LSL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDR II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL ids (Just lbl) targetReg+            ]+  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++-- | Generate jump table data (if required)+--+-- The idea is to emit one table entry per case. The entry is the relative+-- address of the block to jump to (relative to the table's first entry /+-- table's own label.) The calculation itself is done by the linker.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+      sectionType = case platformOS (ncgPlatform config) of+        -- Aarch64 Windows platform requires LLVM 20 to support .rodata+        OSMinGW32 -> Text+        _         -> ReadOnlyData+   in Just (CmmData (Section sectionType lbl) (CmmStaticsRaw lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements+              -> NatM InstrBlock -- ^ Resulting instructions+stmtsToInstrs stmts =+    go stmts nilOL+  where+    go []        instrs = return instrs+    go (s:stmts) instrs = do+      instrs' <- stmtToInstrs s+      go stmts (instrs `appOL` instrs')++stmtToInstrs :: CmmNode e x -- ^ Cmm Statement+             -> NatM InstrBlock -- ^ Resulting Instructions+stmtToInstrs stmt = do+  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"+  --     ++ showSDocUnsafe (ppr stmt)+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args++    _ -> 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 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 true false arg++      CmmSwitch arg ids -> genSwitch config 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 reg@(GlobalRegUse mid _))+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)+        -- 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.++-- -----------------------------------------------------------------------------+-- 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)++{- Note [Aarch64 immediates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Aarch64 with it's fixed width instruction encoding uses leftover space for+immediates.+If you want the full rundown consult the arch reference document:+"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate"++The gist of it is that different instructions allow for different immediate encodings.+The ones we care about for better code generation are:++* Simple but potentially repeated bit-patterns for logic instructions.+* 16bit numbers shifted by multiples of 16.+* 12 bit numbers optionally shifted by 12 bits.++It might seem like the ISA allows for 64bit immediates but this isn't the case.+Rather there are some instruction aliases which allow for large unencoded immediates+which will then be transalted to one of the immediate encodings implicitly.++For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16+-}++-- | Move (wide immediate)+-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits.+-- Used with MOVZ,MOVN, MOVK+-- See Note [Aarch64 immediates]+getMovWideImm :: Integer -> Width -> Maybe Operand+getMovWideImm n w+  -- TODO: Handle sign extension/negatives+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  | sized_n < 2^(16 :: Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 0x0000 0000 xxxx 0000+  | trailing_zeros >= 16 && sized_n < 2^(32 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16++  -- 0x 0000 xxxx 0000 0000+  | trailing_zeros >= 32 && sized_n < 2^(48 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32++  -- 0x xxxx 0000 0000 0000+  | trailing_zeros >= 48+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48++  | otherwise+  = Nothing+  where+    truncated = narrowU w n+    sized_n = fromIntegral truncated :: Word64+    trailing_zeros = countTrailingZeros sized_n++-- | Arithmetic(immediate)+--  Allows for 12bit immediates which can be shifted by 0 or 12 bits.+-- Used with ADD, ADDS, SUB, SUBS, CMP+-- See Note [Aarch64 immediates]+getArithImm :: Integer -> Width -> Maybe Operand+getArithImm n w+  -- TODO: Handle sign extension+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  -- Fits in 12 bits+  | sized_n < 2^(12::Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 12 bits shifted by 12 places.+  | trailing_zeros >= 12 && sized_n < 2^(24::Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12++  | otherwise+  = Nothing+  where+    sized_n = fromIntegral truncated :: Word64+    truncated = narrowU w n+    trailing_zeros = countTrailingZeros sized_n++-- |  Logical (immediate)+-- Allows encoding of some repeated bitpatterns+-- Used with AND, EOR, ORR+-- and their aliases which includes at least MOV (bitmask immediate)+-- See Note [Aarch64 immediates]+getBitmaskImm :: Integer -> Width -> Maybe Operand+getBitmaskImm n w+  | isAArch64Bitmask (opRegWidth w) truncated = Just $ OpImm (ImmInteger truncated)+  | otherwise = Nothing+  where+    truncated = narrowU w n++-- | Load/store immediate.+-- Depends on the width of the store to some extent.+isOffsetImm :: Int -> Width -> Bool+isOffsetImm off w+  -- 8 bits + sign for unscaled offsets+  | -256 <= off, off <= 255 = True+  -- Offset using 12-bit positive immediate, scaled by width+  -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4+  -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8+  -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095+  | 0 <= off, off < 4096 * byte_width, off `mod` byte_width == 0 = True+  | otherwise = False+  where+    byte_width = widthInBytes w+++++-- TODO OPT: we might be able give getRegister+--          a hint, what kind of register we want.+getFloatReg :: HasDebugCallStack => 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 (GlobalRegUse PicBaseReg _))+      -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)+    CmmLit lit+      -> case lit of++        -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move.+        -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed.+        -- CmmInt 0 W32 -> do+        --   let format = intFormat W32+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))+        -- CmmInt 0 W64 -> do+        --   let format = intFormat W64+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))+        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 | i >= 0+                   , Just imm_op <- getMovWideImm i w -> do+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op)))++        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+          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 reg))+                       (getRegisterReg plat reg)+                       nilOL)+    CmmRegOff reg off ->+      -- If we got here we will load the address into a register either way. So we might as well just expand+      -- and re-use the existing code path to handle "reg + off".+      let !width = cmmRegWidth reg+      in getRegister' config plat (CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)])++    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)++    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_Round    from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)+        MO_FS_Truncate 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))+        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))++        -- Conversions+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        MO_Eq {} -> notUnary+        MO_Ne {} -> notUnary+        MO_Mul {} -> notUnary+        MO_S_MulMayOflo {} -> notUnary+        MO_S_Quot {} -> notUnary+        MO_S_Rem {} -> notUnary+        MO_U_Quot {} -> notUnary+        MO_U_Rem {} -> notUnary+        MO_S_Ge {} -> notUnary+        MO_S_Le {} -> notUnary+        MO_S_Gt {} -> notUnary+        MO_S_Lt {} -> notUnary+        MO_U_Ge {} -> notUnary+        MO_U_Le {} -> notUnary+        MO_U_Gt {} -> notUnary+        MO_U_Lt {} -> notUnary+        MO_F_Add {} -> notUnary+        MO_F_Sub {} -> notUnary+        MO_F_Mul {} -> notUnary+        MO_F_Quot {} -> notUnary+        MO_FMA {} -> notUnary+        MO_F_Eq {} -> notUnary+        MO_F_Ne {} -> notUnary+        MO_F_Ge {} -> notUnary+        MO_F_Le {} -> notUnary+        MO_F_Gt {} -> notUnary+        MO_F_Lt {} -> notUnary+        MO_And {} -> notUnary+        MO_Or {} -> notUnary+        MO_Xor {} -> notUnary+        MO_Shl {} -> notUnary+        MO_U_Shr {} -> notUnary+        MO_S_Shr {} -> notUnary+        MO_V_Insert {} -> notUnary+        MO_V_Extract {} -> notUnary+        MO_V_Add {} -> notUnary+        MO_V_Sub {} -> notUnary+        MO_V_Mul {} -> notUnary+        MO_VS_Neg {} -> notUnary+        MO_V_Shuffle {} -> notUnary+        MO_VF_Shuffle  {} -> notUnary+        MO_VF_Insert {} -> notUnary+        MO_VF_Extract {} -> notUnary+        MO_VF_Add {} -> notUnary+        MO_VF_Sub {} -> notUnary+        MO_VF_Mul {} -> notUnary+        MO_VF_Quot {} -> notUnary+        MO_Add {} -> notUnary+        MO_Sub {} -> notUnary++        MO_F_Min {} -> notUnary+        MO_F_Max {} -> notUnary+        MO_VU_Min {} -> notUnary+        MO_VU_Max {} -> notUnary+        MO_VS_Min {} -> notUnary+        MO_VS_Max {} -> notUnary+        MO_VF_Min {} -> notUnary+        MO_VF_Max {} -> notUnary++        MO_AlignmentCheck {} ->+          pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)++        MO_V_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Neg {} -> vectorsNeedLlvm+      where+        notUnary = pprPanic "getRegister' (non-unary CmmMachOp with 1 argument):" (pdoc plat expr)+        vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"+        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'+    -- Immediates are handled via `getArithImm` in the generic code path.++    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 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> 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))))+                                                 `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+    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)) `snocOL`+                                                                         (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]++    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))))+                                                 `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+    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)) `snocOL`+                                                                         (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]++    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> 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 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> 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 _)] | isAArch64Bitmask (opRegWidth w') (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 reg))+            r' = getRegisterReg plat reg++    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (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 reg))+            r' = getRegisterReg plat reg++    -- Generic binary 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.+          bitOpImm w op encode_imm = do+            -- compute x<m> <- x+            -- compute x<o> <- y+            -- <OP> x<n>, x<m>, x<o>+            (reg_x, format_x, code_x) <- getSomeReg x+            (op_y, format_y, code_y) <- case y of+              CmmLit (CmmInt n w)+                | Just imm_operand_y <- encode_imm n w+                -> return (imm_operand_y, intFormat w, nilOL)+              _ -> do+                  (reg_y, format_y, code_y) <- getSomeReg y+                  return (OpReg w reg_y, format_y, code_y)+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible"+            return $ Any (intFormat w) (\dst ->+                code_x `appOL`+                code_y `appOL`+                op (OpReg w dst) (OpReg w reg_x) op_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].+          intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)+          intOpImm {- is signed -} True  w op _encode_imm = intOp True w op+          intOpImm                 False w op  encode_imm = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (op_y, format_y, code_y) <- case y of+                CmmLit (CmmInt n w)+                  | Just imm_operand_y <- encode_imm n w+                  -> return (imm_operand_y, intFormat w, nilOL)+                _ -> do+                    (reg_y, format_y, code_y) <- getSomeReg y+                    return (OpReg w reg_y, format_y, code_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+              return $ Any (intFormat w) $ \dst ->+                  code_x `appOL`+                  code_y `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`+                  truncateReg w' w dst -- truncate back to the operand's original width++          -- 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 -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm+        -- TODO: Handle sub-word case+        MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm++        -- 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     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm+        MO_Ne w     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm++        -- 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     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm+        MO_U_Le w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm+        MO_U_Gt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm+        MO_U_Lt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm++        -- 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)+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ FMIN d x y)+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ FMAX 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 -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm+        MO_Or    w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm+        MO_Xor   w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm+        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)++        -- Non-dyadic MachOp with 2 arguments+        MO_S_Neg {} -> notDyadic+        MO_F_Neg {} -> notDyadic+        MO_FMA {} -> notDyadic+        MO_Not {} -> notDyadic+        MO_SF_Round {} -> notDyadic+        MO_FS_Truncate {} -> notDyadic+        MO_SS_Conv {} -> notDyadic+        MO_UU_Conv {} -> notDyadic+        MO_XX_Conv {} -> notDyadic+        MO_FF_Conv {} -> notDyadic+        MO_WF_Bitcast {} -> notDyadic+        MO_FW_Bitcast {} -> notDyadic+        MO_V_Broadcast {} -> notDyadic+        MO_VF_Broadcast {} -> notDyadic+        MO_V_Insert {} -> notDyadic+        MO_VF_Insert {} -> notDyadic+        MO_AlignmentCheck {} -> notDyadic+        MO_RelaxedRead {} -> notDyadic++        -- Vector operations: currently unsupported in the AArch64 NCG.+        MO_V_Extract {} -> vectorsNeedLlvm+        MO_V_Add {} -> vectorsNeedLlvm+        MO_V_Sub {} -> vectorsNeedLlvm+        MO_V_Mul {} -> vectorsNeedLlvm+        MO_VS_Neg {} -> vectorsNeedLlvm+        MO_VF_Extract {} -> vectorsNeedLlvm+        MO_VF_Add {} -> vectorsNeedLlvm+        MO_VF_Sub {} -> vectorsNeedLlvm+        MO_VF_Neg {} -> vectorsNeedLlvm+        MO_VF_Mul {} -> vectorsNeedLlvm+        MO_VF_Quot {} -> vectorsNeedLlvm+        MO_V_Shuffle {} -> vectorsNeedLlvm+        MO_VF_Shuffle {} -> vectorsNeedLlvm+        MO_VU_Min {} -> vectorsNeedLlvm+        MO_VU_Max {} -> vectorsNeedLlvm+        MO_VS_Min {} -> vectorsNeedLlvm+        MO_VS_Max {} -> vectorsNeedLlvm+        MO_VF_Min {} -> vectorsNeedLlvm+        MO_VF_Max {} -> vectorsNeedLlvm+        where+          notDyadic =+            pprPanic "getRegister' (non-dyadic CmmMachOp with 2 arguments): " $+              (pprMachOp op) <+> text "in" <+> (pdoc plat expr)+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->++      case op of++        -- Floating-point fused multiply-add operations++        -- x86 fmadd    x * y + z <=> AArch64 fmadd : d =   r1 * r2 + r3+        -- x86 fmsub    x * y - z <=> AArch64 fnmsub: d =   r1 * r2 - r3+        -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3+        -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3++        MO_FMA var l w+          | l == 1+          -> case var of+            FMAdd  -> float3Op w (\d n m a -> unitOL $ FMA FMAdd  d n m a)+            FMSub  -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> vectorsNeedLlvm++        MO_V_Insert {} -> vectorsNeedLlvm+        MO_VF_Insert {} -> vectorsNeedLlvm++        _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $+                (pprMachOp op) <+> text "in" <+> (pdoc plat expr)++      where+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"+          float3Op w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            (reg_fz, format_z, code_fz) <- getFloatReg z+            massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $+              text "float3Op: non-float"+            return $+              Any (floatFormat w) $ \ dst ->+                code_fx `appOL`+                code_fy `appOL`+                code_fz `appOL`+                op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)++    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    isNbitEncodeable :: Int -> Integer -> Bool+    isNbitEncodeable n_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++    -- N.B. MUL does not set the overflow flag.+    -- These implementations are based on output from GCC 11.+    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 W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL`+            ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL`+            CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL`+            CSET (OpReg W32 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+        tmp1 <- getNewRegNat II32+        tmp2 <- getNewRegNat II32+        let extend dst arg =+              case w of+                W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg)+                W8  -> SXTB (OpReg W32 dst) (OpReg W32 arg)+                _   -> panic "unreachable"+            cmp_ext_mode =+              case w of+                W16 -> EUXTH+                W8  -> EUXTB+                _   -> panic "unreachable"+            width = widthInBits w+            opInt = OpImm . ImmInt++        return $ Any (intFormat w) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            extend tmp1 reg_x `snocOL`+            extend tmp2 reg_y `snocOL`+            MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL`+            SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL`+            UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL`+            CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL`+            CSET (OpReg w dst) NE)++-- | Is a given number encodable as a bitmask immediate?+--+-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly+isAArch64Bitmask :: Width -> Integer -> Bool+-- N.B. zero and ~0 are not encodable as bitmask immediates+isAArch64Bitmask width n =+  assert (width `elem` [W32,W64]) $+  case n of+    0 -> False+    _ | n == bit (widthInBits width) - 1+      -> False -- 1111...1111+      | otherwise+      -> (width == W64 && check 64) || check 32 || check 16 || check 8+  where+    -- Check whether @n@ can be represented as a subpattern of the given+    -- width.+    check width+      | hasOneRun subpat =+          let n' = fromIntegral (mkPat width subpat)+          in n == n'+      | otherwise = False+      where+        subpat :: Word64+        subpat = fromIntegral (n .&. (bit width - 1))++    -- Construct a bit-pattern from a repeated subpatterns the given width.+    mkPat :: Int -> Word64 -> Word64+    mkPat width subpat =+        foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ]++    -- Does the given number's bit representation match the regular expression+    -- @0*1*0*@?+    hasOneRun :: Word64 -> Bool+    hasOneRun m =+        64 == popCount m + countLeadingZeros m + countTrailingZeros m++-- | 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:+getAmode platform w (CmmRegOff reg off)+  | isOffsetImm off w+  = 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 w (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral off) w+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform w (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral $ -off) w+  = 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)) = do+  cur_mod <- getThisModuleNat+  !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig+  let is_local = isLocalCLabel cur_mod lbl++  -- We prefer to generate a near jump using a simble `B` instruction+  -- with a range (+/-128MB). But if the target is outside the current module+  -- we might have to account for large code offsets. (#24648)+  if not useFarJumps || is_local+    then return $ unitOL (annExpr expr (J (TLabel lbl)))+    else do+      (target, _format, code) <- getSomeReg expr+      return (code `appOL` unitOL (annExpr expr (J (TReg target))))++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)++-- A conditional jump with at least +/-128M jump range+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock+genCondFarJump cond far_target = do+  skip_lbl_id <- newBlockId+  jmp_lbl_id <- newBlockId++  -- TODO: We can improve this by inverting the condition+  -- but it's not quite trivial since we don't know if we+  -- need to consider float orderings.+  -- So we take the hit of the additional jump in the false+  -- case for now.+  return $ toOL [ BCOND cond (TBlock jmp_lbl_id)+                , B (TBlock skip_lbl_id)+                , NEWBLOCK jmp_lbl_id+                , B far_target+                , NEWBLOCK skip_lbl_id]++genCondBranch :: 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)+    -> NatM InstrBlock+-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs = 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)+  platform <- getPlatform+  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++      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'++      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) -- branch and link.+            `appOL` readResultsCode           -- parse the results into registers+            `appOL` moveStackUp (stackSpace `div` 8)+      return code++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Fabs"+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Fabs"+    PrimTarget MO_F32_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Sqrt"+    PrimTarget MO_F64_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Sqrt"+++    PrimTarget (MO_S_Mul2 w)+          -- Life is easier when we're working with word sized operands,+          -- we can use SMULH to compute the high 64 bits, and dst_needed+          -- checks if the high half's bits are all the same as the low half's+          -- top bit.+          | w == W64+          , [src_a, src_b] <- arg_regs+          -- dst_needed = did the result fit into just the low half+          , [dst_needed, dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  nd = getRegisterReg platform (CmmLocal dst_needed)+              return $+                  code_x `appOL`+                  code_y `snocOL`+                  MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  -- Are all high bits equal to the sign bit of the low word?+                  -- nd = (hi == ASR(lo,width-1)) ? 1 : 0+                  CMP   (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`+                  CSET  (OpReg W64 nd) NE+            -- For sizes < platform width, we can just perform a multiply and shift+            -- using the normal 64 bit multiply. Calculating the dst_needed value is+            -- complicated a little by the need to be careful when truncation happens.+            -- Currently this case can't be generated since+            -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #)+            -- TODO: Should this be removed or would other primops be useful?+          | w < W64+          , [src_a, src_b] <- arg_regs+          , [dst_needed, dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a', _format_x, code_a) <- getSomeReg src_a+              (reg_b', _format_y, code_b) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  nd = getRegisterReg platform (CmmLocal dst_needed)+                  -- Do everything in a full 64 bit registers+                  w' = platformWordWidth platform++              (reg_a, code_a') <- signExtendReg w w' reg_a'+              (reg_b, code_b') <- signExtendReg w w' reg_b'++              return $+                  code_a  `appOL`+                  code_b  `appOL`+                  code_a' `appOL`+                  code_b' `snocOL`+                  -- the low 2w' of lo contains the full multiplication;+                  -- eg: int8 * int8 -> int16 result+                  -- so lo is in the last w of the register, and hi is in the second w.+                  SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+                  -- Make sure we hold onto the sign bits for dst_needed+                  ASR (OpReg w' hi) (OpReg w' lo)    (OpImm (ImmInt $ widthInBits w)) `appOL`+                  -- lo can now be truncated so we can get at it's top bit easily.+                  truncateReg w' w lo `snocOL`+                  -- Note the use of CMN (compare negative), not CMP: we want to+                  -- test if the top half is negative one and the top+                  -- bit of the bottom half is positive one. eg:+                  -- hi = 0b1111_1111  (actually 64 bits)+                  -- lo = 0b1010_1111  (-81, so the result didn't need the top half)+                  -- lo' = ASR(lo,7)   (second reg of SMN)+                  --     = 0b0000_0001 (theeshift gives us 1 for negative,+                  --                    and 0 for positive)+                  -- hi == -lo'?+                  -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow)+                  -- Another way to think of this is if hi + lo' == 0, which is what+                  -- CMN really is under the hood.+                  CMN   (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`+                  -- Set dst_needed to 1 if hi and lo' were (negatively) equal+                  CSET  (OpReg w' nd) EQ `appOL`+                  -- Finally truncate hi to drop any extraneous sign bits.+                  truncateReg w' w hi+          -- Can't handle > 64 bit operands+          | otherwise -> unsupported (MO_S_Mul2 w)+    PrimTarget (MO_U_Mul2  w)+          -- The unsigned case is much simpler than the signed, all we need to+          -- do is the multiplication straight into the destination registers.+          | w == W64+          , [src_a, src_b] <- arg_regs+          , [dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+              return (+                  code_x `appOL`+                  code_y `snocOL`+                  MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)+                  )+            -- For sizes < platform width, we can just perform a multiply and shift+            -- Need to be careful to truncate the low half, but the upper half should be+            -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.+            -- Currently this case can't be produced by the compiler since+            -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #)+            -- TODO: Remove? Or would the extra primop be useful for avoiding the extra+            -- steps needed to do this in userland?+          | w < W64+          , [src_a, src_b] <- arg_regs+          , [dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  w' = opRegWidth w+              return (+                  code_x `appOL`+                  code_y `snocOL`+                  -- UMULL: Xd = Wa * Wb with 64 bit result+                  -- W64 inputs should have been caught by case above+                  UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+                  -- Extract and truncate high result+                  -- hi[w:0] = lo[2w:w]+                  UBFX (OpReg W64 hi) (OpReg W64 lo)+                      (OpImm (ImmInt $ widthInBits w)) -- lsb+                      (OpImm (ImmInt $ widthInBits w)) -- width to extract+                      `appOL`+                  truncateReg W64 w lo+                  )+          | otherwise -> unsupported (MO_U_Mul2  w)+    PrimTarget (MO_Clz  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return (+                  code_x `snocOL`+                  CLZ   (OpReg w dst_reg) (OpReg w reg_a)+                  )+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(x << 16 | 0x0000_8000) -}+              return (+                  code_x `appOL` toOL+                    [ LSL (r dst') (r reg_a) (imm 16)+                    , ORR (r dst') (r dst')  (imm 0x00008000)+                    , CLZ (r dst') (r dst')+                    ]+                  )+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(x << 24 | 0x0080_0000) -}+              return $+                  code_x `appOL` toOL+                    [ LSL (r dst') (r reg_a) (imm 24)+                    , ORR (r dst') (r dst')  (imm 0x00800000)+                    , CLZ (r dst') (r dst')+                    ]+            | otherwise -> unsupported (MO_Clz  w)+    PrimTarget (MO_Ctz  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $+                  code_x `snocOL`+                  RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`+                  CLZ  (OpReg w dst_reg) (OpReg w dst_reg)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(reverseBits(x) | 0x0000_8000) -}+              return $+                  code_x `appOL` toOL+                    [ RBIT (r dst') (r reg_a)+                    , ORR  (r dst') (r dst') (imm 0x00008000)+                    , CLZ  (r dst') (r dst')+                    ]+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(reverseBits(x) | 0x0080_0000) -}+              return $+                  code_x `appOL` toOL+                    [ RBIT (r dst') (r reg_a)+                    , ORR (r dst')  (r dst') (imm 0x00800000)+                    , CLZ  (r dst')  (r dst')+                    ]+            | otherwise -> unsupported (MO_Ctz  w)+    PrimTarget (MO_BRev  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $+                  code_x `snocOL`+                  RBIT (OpReg w dst_reg) (OpReg w reg_a)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = reverseBits32(x << 16) -}+              return $+                  code_x `appOL` toOL+                    [ LSL  (r dst') (r reg_a) (imm 16)+                    , RBIT (r dst') (r dst')+                    ]+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = reverseBits32(x << 24) -}+              return $+                  code_x `appOL` toOL+                    [ LSL  (r dst') (r reg_a) (imm 24)+                    , RBIT (r dst') (r dst')+                    ]+            | otherwise -> unsupported (MO_BRev  w)+    PrimTarget (MO_BSwap  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $ code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+              -- Swaps the bytes in each 16bit word+              -- TODO: Expose the 32 & 64 bit version of this?+              return $ code_x `snocOL` REV16 (r dst') (r reg_a)+          | otherwise -> unsupported (MO_BSwap w)++    -- 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"++        -- 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"++        -- 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)++        -- Arithmetic+        -- These are not supported on X86, so I doubt they are used much.+        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++        -- Vector+        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {} -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {} -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop++        -- Memory Ordering+        -- Set flags according to their C pendants (stdatomic.h):+        -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld+        MO_AcquireFence     ->  return . unitOL $ DMBISH DmbLoad+        -- atomic_thread_fence(memory_order_release); // -> dmb ish+        MO_ReleaseFence     ->  return . unitOL $ DMBISH DmbLoadStore+        -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish+        MO_SeqCstFence      ->  return . unitOL $ DMBISH DmbLoadStore+        MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> return nilOL -- 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)++        -- -- Atomic read-modify-write.+        MO_AtomicRead w ord+          | [p_reg] <- arg_regs+          , [dst_reg] <- dest_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              platform <- getPlatform+              let instr = case ord of+                      MemOrderRelaxed -> LDR+                      _               -> LDAR+                  dst = getRegisterReg platform (CmmLocal dst_reg)+                  code =+                    code_p `snocOL`+                    instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)+              return code+          | otherwise -> panic "mal-formed AtomicRead"+        MO_AtomicWrite w ord+          | [p_reg, val_reg] <- arg_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              (val, fmt_val, code_val) <- getSomeReg val_reg+              let instr = case ord of+                      MemOrderRelaxed -> STR+                      _               -> STLR+                  code =+                    code_p `appOL`+                    code_val `snocOL`+                    instr fmt_val (OpReg w val) (OpAddr $ AddrReg p)+              return code+          | otherwise -> panic "mal-formed AtomicWrite"+        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        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+    mkCCall name = do+      config <- getConfig+      target <- cmmMakeDynamicReference config CallReference $+          mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    -- 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 (InstrBlock)+    readResults _ _ [] _ accumCode = return 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 (CmmLocal dst)+          format = cmmTypeFormat rep+          w   = cmmRegWidth (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++{- Note [AArch64 far jumps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+AArch conditional jump instructions can only encode an offset of +/-1MB+which is usually enough but can be exceeded in edge cases. In these cases+we will replace:++  b.cond <cond> foo++with the sequence:++  b.cond <cond> <lbl_true>+  b <lbl_false>+  <lbl_true>:+  b foo+  <lbl_false>:++Note the encoding of the `b` instruction still limits jumps to++/-128M offsets, but that seems like an acceptable limitation.++Since AArch64 instructions are all of equal length we can reasonably estimate jumps+in range by counting the instructions between a jump and its target label.++We make some simplifications in the name of performance which can result in overestimating+jump <-> label offsets:++* To avoid having to recalculate the label offsets once we replaced a jump we simply+  assume all jumps will be expanded to a three instruction far jump sequence.+* For labels associated with a info table we assume the info table is 64byte large.+  Most info tables are smaller than that but it means we don't have to distinguish+  between multiple types of info tables.++In terms of implementation we walk the instruction stream at least once calculating+label offsets, and if we determine during this that the functions body is big enough+to potentially contain out of range jumps we walk the instructions a second time, replacing+out of range jumps with the sequence of instructions described above.++-}++-- See Note [AArch64 far jumps]+data BlockInRange = InRange | NotInRange Target++-- See Note [AArch64 far jumps]+makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]+                -> UniqDSM [NatBasicBlock Instr]+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_jump_dist+    then pure basic_blocks+    else do+      (_,blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+      -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks++  where+    -- 2^18, 19 bit immediate with one bit is reserved for the sign+    max_jump_dist = 2^(18::Int) - 1 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size     = 16 :: Int+    long_bc_jump_size =  3 :: Int+    long_bz_jump_size =  4 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (idx,instr':instrs') ->+              pure (idx, ANN ann instr':instrs')+            (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)+        BCOND cond t+          -> case target_in_range m t pos of+              InRange -> pure (pos+long_bc_jump_size,[instr])+              NotInRange far_target -> do+                jmp_code <- genCondFarJump cond far_target+                pure (pos+long_bc_jump_size, fromOL jmp_code)+        CBZ op t -> long_zero_jump op t EQ+        CBNZ op t -> long_zero_jump op t NE+        instr+          | isMetaInstr instr -> pure (pos,[instr])+          | otherwise -> pure (pos+1, [instr])++      where+        -- cmp_op: EQ = CBZ, NEQ = CBNZ+        long_zero_jump op t cmp_op =+          case target_in_range m t pos of+              InRange -> pure (pos+long_bz_jump_size,[instr])+              NotInRange far_target -> do+                jmp_code <- genCondFarJump cmp_op far_target+                -- TODO: Fix zero reg so we can use it here+                pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)+++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg{}) -> InRange+        (TBlock bid) -> block_in_range m src bid+        (TLabel clbl)+          | Just bid <- maybeLocalBlockLabel clbl+          -> block_in_range m src bid+          | otherwise+          -- Maybe we should be pessimistic here, for now just fixing intra proc jumps+          -> InRange++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing       ->+          pprTrace "not in range" (ppr dest_lbl) $+            NotInRange (TBlock dest_lbl)+        Just dest_pos -> if abs (dest_pos - src_pos) < max_jump_dist+          then InRange+          else NotInRange (TBlock dest_lbl)++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs)+      = let !pos' = pos + infoTblSize_maybe lbl+        in foldl' instr_pos (pos',mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr =+      case instr of+        ANN _ann instr -> instr_pos (pos, m) instr+        NEWBLOCK _bid -> panic "mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK+                                                                     -- in the instruction stream+                                                                     -- (pos, mapInsert bid pos m)+        COMMENT{} -> (pos, m)+        instr+          | Just jump_size <- is_expandable_jump instr -> (pos+jump_size, m)+          | otherwise -> (pos+1, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing           -> 0 :: Int+        Just _info_static -> max_info_size++    -- These jumps have a 19bit immediate as offset which is quite+    -- limiting so we potentially have to expand them into+    -- multiple instructions.+    is_expandable_jump i = case i of+      CBZ{}   -> Just long_bz_jump_size+      CBNZ{}  -> Just long_bz_jump_size+      BCOND{} -> Just long_bc_jump_size+      _ -> Nothing
+ GHC/CmmToAsm/AArch64/Cond.hs view
@@ -0,0 +1,72 @@+module GHC.CmmToAsm.AArch64.Cond  where++import GHC.Prelude hiding (EQ)++-- 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+             -- I removed never. According to the ARM spec:+             -- >   The Condition code NV exists only to provide a valid disassembly of+             -- >   the 0b1111 encoding, otherwise its behavior is identical to AL.+             -- This can only lead to disaster. Better to not have it than someone+             -- using it assuming it actually means never.++    | VS     -- oVerflow set+    | VC     -- oVerflow clear+    deriving Eq
+ GHC/CmmToAsm/AArch64/Instr.hs view
@@ -0,0 +1,924 @@+{-# 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.CmmToAsm.Reg.Target (targetClassOfReg)+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Unified++import GHC.Platform.Regs+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Platform+import GHC.Types.Unique.DSM++import GHC.Utils.Panic++import Data.Maybe (fromMaybe, catMaybes)++import GHC.Stack++-- | LR and FP (8 byte each) are the prologue of each stack frame+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * 8++-- | 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.+    = ((ncgSpillPreallocSize config - stackFrameHeaderSize)+         `div` spillSlotSize) - 1++-- | Convert a spill slot number to a *byte* offset, with no sign.+spillSlotToOffset :: NCGConfig -> Int -> Int+spillSlotToOffset _ slot+   = stackFrameHeaderSize + 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+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])++  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  CMP l r                  -> usage (regOp l ++ regOp r, [])+  CMN 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)+  UMULH dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  UMULL 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)+  CLZ  dst src             -> usage (regOp src, regOp dst)+  RBIT dst src             -> usage (regOp src, regOp dst)+  REV   dst src            -> usage (regOp src, regOp dst)+  -- REV32 dst src            -> usage (regOp src, regOp dst)+  REV16 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)+  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)+  MOVZ 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)+  -- 4. Branch Instructions ----------------------------------------------------+  J t                      -> usage (regTarget t, [])+  J_TBL _ _ t              -> usage ([t], [])+  B t                      -> usage (regTarget t, [])+  BCOND _ t                -> usage (regTarget t, [])+  BL t ps                  -> 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, [])+  STLR _ src dst           -> usage (regOp src ++ regOp dst, [])+  LDR _ dst src            -> usage (regOp src, regOp dst)+  LDAR _ dst src           -> usage (regOp src, regOp dst)++  -- 8. Synchronization Instructions -------------------------------------------+  DMBISH _                 -> usage ([], [])++  -- 9. Floating Point Instructions --------------------------------------------+  FMOV dst src             -> usage (regOp src, regOp dst)+  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)+  FSQRT dst src            -> usage (regOp src, regOp dst)+  FMIN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAX dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMA _ dst src1 src2 src3 ->+    usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)++  LOCATION{} -> panic $ "regUsageOfInstr: " ++ instrCon instr+  NEWBLOCK{} -> panic $ "regUsageOfInstr: " ++ instrCon instr++  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 (map mkFmt $ filter (interesting platform) src)+                              (map mkFmt $ filter (interesting platform) dst)+          -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+          -- As the AArch64 NCG does not currently support SIMD registers,+          -- this simple logic is OK.+        mkFmt r = RegWithFormat r fmt+          where fmt = case targetClassOfReg platform r of+                        RcInteger -> II64+                        RcFloatOrVector -> FF64++        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 platform (RegReal (RealRegSingle i))    = freeReg platform i++-- Note [AArch64 Register assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 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 (See Note [Aarch64 Register x18 at Darwin and Windows]), FP: Frame pointer, LR: Link register, SP: Stack pointer+-- BR: Base, SL: SpLim+--+-- TODO: The zero register is currently mapped to -1 but should get it's own separate number.+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)+    COMMENT{}           -> instr+    MULTILINE_COMMENT{} -> instr+    PUSH_STACK_FRAME    -> instr+    POP_STACK_FRAME     -> instr+    DELTA{}             -> instr+    -- 1. Arithmetic Instructions ----------------------------------------------+    ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)+    CMP o1 o2      -> CMP (patchOp o1) (patchOp o2)+    CMN o1 o2      -> CMN (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)+    UMULH o1 o2 o3 -> UMULH (patchOp o1) (patchOp o2)  (patchOp o3)+    UMULL o1 o2 o3 -> UMULL (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)+    CLZ o1 o2        -> CLZ  (patchOp o1) (patchOp o2)+    RBIT o1 o2       -> RBIT (patchOp o1) (patchOp o2)+    REV   o1 o2      -> REV  (patchOp o1) (patchOp o2)+    -- REV32 o1 o2      -> REV32 (patchOp o1) (patchOp o2)+    REV16 o1 o2      -> REV16 (patchOp o1) (patchOp o2)+++    -- 3. Logical and Move Instructions ----------------------------------------+    AND o1 o2 o3   -> AND  (patchOp o1) (patchOp o2) (patchOp o3)+    ASR o1 o2 o3   -> ASR  (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)+    MOVZ o1 o2     -> MOVZ (patchOp o1) (patchOp o2)+    MVN o1 o2      -> MVN  (patchOp o1) (patchOp o2)+    ORR o1 o2 o3   -> ORR  (patchOp o1) (patchOp o2) (patchOp o3)++    -- 4. Branch Instructions --------------------------------------------------+    J t               -> J (patchTarget t)+    J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+    B t               -> B (patchTarget t)+    BL t rs           -> BL (patchTarget t) rs+    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)+    STLR f o1 o2   -> STLR f (patchOp o1) (patchOp o2)+    LDR f o1 o2    -> LDR f (patchOp o1) (patchOp o2)+    LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)++    -- 8. Synchronization Instructions -----------------------------------------+    DMBISH c       -> DMBISH c++    -- 9. Floating Point Instructions ------------------------------------------+    FMOV o1 o2     -> FMOV (patchOp o1) (patchOp o2)+    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)+    FSQRT o1 o2    -> FSQRT (patchOp o1) (patchOp o2)+    FMIN o1 o2 o3  -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)+    FMAX o1 o2 o3  -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)+    FMA s o1 o2 o3 o4 ->+      FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)++    NEWBLOCK{}     -> panic $ "patchRegsOfInstr: " ++ instrCon instr+    LOCATION{}     -> panic $ "patchRegsOfInstr: " ++ instrCon 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+    J_TBL{} -> 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 (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BL t _) = [ id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid+canFallthroughTo (J (TBlock target)) bid = bid == target+canFallthroughTo (J_TBL targets _ _) bid = all isTargetBid targets+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid+canFallthroughTo (B (TBlock target)) bid = bid == target+canFallthroughTo _ _ = False++-- | 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))+        J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+        B (TBlock bid) -> B (TBlock (patchF bid))+        BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps+        BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))+        _ -> panic $ "patchJumpInstr: " ++ instrCon 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+   -> RegWithFormat -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr config (RegWithFormat reg fmt) delta slot =+  case off - 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 register into" <+> int imm)+    where+        a .&~. b = a .&. (complement b)++        -- SIMD NCG TODO: emit the correct instructions to spill a vector register.+        -- You can take inspiration from the X86_64 backend.+        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+   -> RegWithFormat+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]+mkLoadInstr config (RegWithFormat reg fmt) delta slot =+  case off - 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 "mkLoadInstr" (text "Unable to load spilled register at" <+> int imm)+    where+        a .&~. b = a .&. (complement b)++        -- SIMD NCG TODO: emit the correct instructions to load a vector register.+        -- You can take inspiration from the X86_64 backend.+        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+    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 :: Format -> Reg -> Reg -> Instr+mkRegRegMoveInstr _fmt src dst+  = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)+  -- SIMD NCG TODO: incorrect for vector formats++-- | Take the source and destination registers from a move instruction of same+-- register class (`RegClass`).+--+-- The idea is to identify moves that can be eliminated by the register+-- allocator: If the source register serves no special purpose, one could+-- continue using it; saving one move instruction. For this, the register kinds+-- (classes) must be the same (no conversion involved.)+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+takeRegRegMoveInstr (MOV (OpReg _fmt dst) (OpReg _fmt' src))+  | classOfReg dst == classOfReg src = pure (src, dst)+  where+    classOfReg :: Reg -> RegClass+    classOfReg reg+      = case reg of+        RegVirtual vr -> classOfVirtualReg ArchAArch64 vr+        RegReal rr -> classOfRealReg rr+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+  -> UniqDSM (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++    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++    let+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where x = slots * spillSlotSize -- sp delta++      alloc   = mkStackAllocInstr   platform delta+      dealloc = mkStackDeallocInstr platform delta++      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++    -- 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 ...+    | CMP Operand Operand -- rd - op2+    | CMN 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 Operand Operand Operand -- Xd = (Xn × Xm)_127:64+    | UMULL Operand Operand Operand -- 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]+    | CLZ  Operand Operand -- rd = countLeadingZeros(rn)+    | RBIT Operand Operand -- rd = reverseBits(rn)+    | REV Operand Operand   -- rd = reverseBytes(rn): (for 32 & 64 bit operands)+                            -- 0xAABBCCDD -> 0xDDCCBBAA+    | REV16 Operand Operand -- rd = reverseBytes16(rn)+                            -- 0xAABB_CCDD -> xBBAA_DDCC+    -- | REV32 Operand Operand -- rd = reverseBytes32(rn) - 64bit operands only!+    --                         -- 0xAABBCCDD_EEFFGGHH -> 0XDDCCBBAA_HHGGFFEE++    -- 3. Logical and Move Instructions ----------------------------------------+    | AND Operand Operand Operand -- rd = rn & op2+    | ASR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits+    | 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+    | ORR Operand Operand Operand -- rd = 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+    | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr+    | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr+    | LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr++    -- 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.+    | J_TBL [Maybe BlockId] (Maybe CLabel) Reg -- A jump instruction with data for switch/jump tables+    | B Target            -- unconditional branching b/br. (To a blockid, label or register)+    | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch)+    | BCOND Cond Target   -- branch with condition. b.<cond>++    -- 8. Synchronization Instructions -----------------------------------------+    | DMBISH DMBISHFlags+    -- 9. Floating Point Instructions+    -- move to/from general purpose <-> floating, or floating to floating+    | FMOV Operand Operand+    -- 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+    -- Float minimum+    | FMIN Operand Operand Operand+    -- Float maximum+    | FMAX Operand Operand Operand+    -- Float SQuare RooT+    | FSQRT Operand Operand++    -- | Floating-point fused multiply-add instructions+    --+    -- - fmadd : d =   r1 * r2 + r3+    -- - fnmsub: d =   r1 * r2 - r3+    -- - fmsub : d = - r1 * r2 + r3+    -- - fnmadd: d = - r1 * r2 - r3+    | FMA FMASign Operand Operand Operand Operand++data DMBISHFlags = DmbLoad | DmbLoadStore+  deriving (Eq, Show)++instrCon :: Instr -> String+instrCon i =+    case i of+      COMMENT{} -> "COMMENT"+      MULTILINE_COMMENT{} -> "COMMENT"+      ANN{} -> "ANN"+      LOCATION{} -> "LOCATION"+      NEWBLOCK{} -> "NEWBLOCK"+      DELTA{} -> "DELTA"+      SXTB{} -> "SXTB"+      UXTB{} -> "UXTB"+      SXTH{} -> "SXTH"+      UXTH{} -> "UXTH"+      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+      POP_STACK_FRAME{} -> "POP_STACK_FRAME"+      ADD{} -> "ADD"+      CMP{} -> "CMP"+      CMN{} -> "CMN"+      MSUB{} -> "MSUB"+      MUL{} -> "MUL"+      NEG{} -> "NEG"+      SDIV{} -> "SDIV"+      SMULH{} -> "SMULH"+      SMULL{} -> "SMULL"+      UMULH{} -> "UMULH"+      UMULL{} -> "UMULL"+      SUB{} -> "SUB"+      UDIV{} -> "UDIV"+      SBFM{} -> "SBFM"+      UBFM{} -> "UBFM"+      SBFX{} -> "SBFX"+      UBFX{} -> "UBFX"+      CLZ{} -> "CLZ"+      RBIT{} -> "RBIT"+      REV{} -> "REV"+      REV16{} -> "REV16"+      -- REV32{} -> "REV32"+      AND{} -> "AND"+      ASR{} -> "ASR"+      EOR{} -> "EOR"+      LSL{} -> "LSL"+      LSR{} -> "LSR"+      MOV{} -> "MOV"+      MOVK{} -> "MOVK"+      MOVZ{} -> "MOVZ"+      MVN{} -> "MVN"+      ORR{} -> "ORR"+      STR{} -> "STR"+      STLR{} -> "STLR"+      LDR{} -> "LDR"+      LDAR{} -> "LDAR"+      CSET{} -> "CSET"+      CBZ{} -> "CBZ"+      CBNZ{} -> "CBNZ"+      J{} -> "J"+      J_TBL {} -> "J_TBL"+      B{} -> "B"+      BL{} -> "BL"+      BCOND{} -> "BCOND"+      DMBISH{} -> "DMBISH"+      FMOV{} -> "FMOV"+      FCVT{} -> "FCVT"+      SCVTF{} -> "SCVTF"+      FCVTZS{} -> "FCVTZS"+      FABS{} -> "FABS"+      FSQRT{} -> "FSQRT"+      FMIN {} -> "FMIN"+      FMAX {} -> "FMAX"+      FMA variant _ _ _ _ ->+        case variant of+          FMAdd  -> "FMADD"+          FMSub  -> "FMSUB"+          FNMAdd -> "FNMADD"+          FNMSub -> "FNMSUB"++data Target+    = TBlock BlockId+    | TLabel CLabel+    | TReg   Reg+    deriving (Eq, Ord)+++-- 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++sp, ip0 :: Operand+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" (ppr 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" (ppr w)
+ GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -0,0 +1,593 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) 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.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++pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc+pprNatCmmDecl config (CmmData section dats) =+  let platform = ncgPlatform config+  in+  pprSectionAlign config section $$ pprDatas platform dats++pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config+      with_dwarf = ncgDwarfEnabled config+  in+  case topInfoTable proc of+    Nothing ->+        -- special case for code without info table:+        pprSectionAlign config (Section Text lbl) $$+        -- do not+        -- pprProcAlignment config $$+        (if lbl /= blockLbl (blockId (head blocks)) -- blocks can have clashed names+          then pprLabel platform lbl -- blocks guaranteed not null, so label needed+          else empty) $$+        vcat (map (pprBasicBlock platform with_dwarf 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 platform with_dwarf 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 ':')++-- | 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 => Platform -> {- dwarf enabled -} Bool -> LabelMap RawCmmStatics -> NatBasicBlock Instr+              -> doc+pprBasicBlock platform with_dwarf info_env (BasicBlock blockid instrs)+  = maybe_infotable $+    pprLabel platform asmLbl $$+    vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$+    (if  with_dwarf+      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+    maybe_infotable c = case mapLookup blockid info_env of+       Nothing   -> c+       Just (CmmStaticsRaw info_lbl info) ->+          --  pprAlignForSection platform Text $$+           infoTableLoc $$+           vcat (map (pprData platform) info) $$+           pprLabel platform info_lbl $$+           c $$+           (if with_dwarf+             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 => 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 (CmmString str) = line (pprString str)+pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path)++pprData platform (CmmUninitialised bytes)+ = line $ if platformOS platform == OSDarwin+                then text ".space " <> int bytes+                else text ".skip "  <> int bytes++pprData platform (CmmStaticLit lit) = pprDataItem platform 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 => Platform -> CmmLit -> doc+pprDataItem platform lit+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+    where+        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 (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"++    -- See Note [AArch64 Register assignments]+    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)+         | i <= 63, w == W128= text "q" <> int (i-32)+         | otherwise = text "very naughty AArch64 register" <+> parens (text (show w) <+> int i)++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True+isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True+-- SIMD NCG TODO: what about VirtualVecV128? Could be floating-point or not?+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 blockid -> -- This is invalid assembly. But NEWBLOCK should never be contained+                      -- in the final instruction stream. But we still want to be able to+                      -- print it for debugging purposes.+                      line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid))++  -- 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+  CMP  o1 o2+    | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2+    | otherwise -> op2 (text "\tcmp") o1 o2+  CMN  o1 o2       -> op2 (text "\tcmn") 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+  UMULH o1 o2 o3 -> op3 (text "\tumulh") o1 o2 o3+  UMULL o1 o2 o3 -> op3 (text "\tumull") 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+  CLZ  o1 o2       -> op2 (text "\tclz")  o1 o2+  RBIT  o1 o2      -> op2 (text "\trbit")  o1 o2+  REV o1 o2        -> op2 (text "\trev")  o1 o2+  REV16 o1 o2      -> op2 (text "\trev16")  o1 o2+  -- REV32 o1 o2      -> op2 (text "\trev32")  o1 o2+  -- 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+  ASR o1 o2 o3  -> op3 (text "\tasr") 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+  MOVZ o1 o2    -> op2 (text "\tmovz") o1 o2+  MVN o1 o2     -> op2 (text "\tmvn") o1 o2+  ORR o1 o2 o3  -> op3 (text "\torr") o1 o2 o3++  -- 4. Branch Instructions ----------------------------------------------------+  J t            -> pprInstr platform (B t)+  J_TBL _ _ r    -> pprInstr platform (B (TReg r))+  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+  STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2++  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_ldr o1 (ldr') $$+    op_add o1 (check_off off)++  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    case platformOS platform of+      OSMinGW32 ->+        let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_add o1 add' $$+        op_add o1 (check_off off)+      _ ->+        let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_ldr o1 (ldr') $$+        op_add o1 (check_off off)++  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_add o1 (add') $$+    op_add o1 (check_off off)++  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+    op_adrp o1 (adrp') $$+    op_ldr o1 (ldr')++  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    case platformOS platform of+      OSMinGW32 ->+        let (adrp', add') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_add o1 add'+      _ ->+        let (adrp', ldr') = op_adrp_reloc_dynamic $ pprAsmLabel platform lbl in+        op_adrp o1 (adrp') $$+        op_ldr o1 (ldr')++  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    let (adrp', ldr') = op_adrp_reloc_local $ pprAsmLabel platform lbl in+    op_adrp o1 adrp' $$+    op_add o1 ldr'++  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+  LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2++  -- 8. Synchronization Instructions -------------------------------------------+  DMBISH DmbLoadStore -> line $ text "\tdmb ish"+  DMBISH DmbLoad -> line $ text "\tdmb ishld"++  -- 9. Floating Point Instructions --------------------------------------------+  FMOV o1 o2 -> op2 (text "\tfmov") o1 o2+  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+  FSQRT o1 o2 -> op2 (text "\tfsqrt") o1 o2+  FMIN o1 o2 o3 -> op3 (text "\tfmin") o1 o2 o3+  FMAX o1 o2 o3 -> op3 (text "\tfmax") o1 o2 o3+  FMA variant d r1 r2 r3 ->+    let fma = case variant of+                FMAdd  -> text "\tfmadd"+                FMSub  -> text "\tfmsub"+                FNMAdd -> text "\tfnmadd"+                FNMSub -> text "\tfnmsub"+    in op4 fma d r1 r2 r3+ 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++       op_adrp_reloc_dynamic asm_lbl = case platformOS platform of+          OSDarwin -> (asm_lbl <> text "@gotpage", asm_lbl <> text "@gotpageoff")+          OSLinux -> (text ":got:" <> asm_lbl, text ":got_lo12:" <> asm_lbl)+          OSMinGW32 -> (text "__imp_" <> asm_lbl, text ":lo12:__imp_" <> asm_lbl)+          os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_dynamic : " ++ show os' ++ " is unsuppported by relocations"++       op_adrp_reloc_local asm_lbl = case platformOS platform of+          OSDarwin -> (asm_lbl <> text "@page", asm_lbl <> text "@pageoff")+          OSLinux -> (asm_lbl, text ":lo12:" <> asm_lbl)+          OSMinGW32 -> (asm_lbl, text ":lo12:" <> asm_lbl)+          os' -> pgmError $ "GHC.CmmToAsm.AArch64.Ppr.op_adrp_reloc_local : " ++ show os' ++ " is unsuppported by relocations"++       check_off off = if off >= 0 && off <= 4095 then char '#' <> int off else+         pgmError $ "GHC.CmmToAsm.AArch64.Ppr.check_off : " ++ show off ++ " is out of 12 bit"++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"
+ GHC/CmmToAsm/AArch64/RegInfo.hs view
@@ -0,0 +1,29 @@+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++-- Implementations of the methods of 'NgcImpl'++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ GHC/CmmToAsm/AArch64/Regs.hs view
@@ -0,0 +1,153 @@+{-# 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.Unified+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++-- TODO: Should this include the zero register?+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.+                -- AK: We do call this with out of range values, however+                -- it just truncates as we would expect.+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++        RcFloatOrVector+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegV128{}        -> 1+                _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++        RcFloatOrVector+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1++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     = RcFloatOrVector++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloatOrVector -> text "red"
+ GHC/CmmToAsm/BlockLayout.hs view
@@ -0,0 +1,921 @@+{-# 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 qualified GHC.Prelude as Partial (head, 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.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.Misc++import Data.List (sortOn, sortBy, nub)+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+import GHC.Types.Unique.DSM (UniqDSM)++{-+  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 $ mapLookup from chains+            cTo = expectJust $ 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]++        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 $ 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+    , BasicBlock nextLbl _ : _ <- todo+    , canFallthroughTo (NE.last ins) nextLbl+    , not (mapMember nextLbl info)+    = 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+    -> UniqDSM (NatCmmDecl statics instr)++sequenceTop _       _           top@(CmmData _ _) = pure top+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do+    let config     = ncgConfig ncgImpl+        platform   = ncgPlatform config++        seq_blocks =+                  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++    far_blocks <- (ncgMakeFarBranches ncgImpl) platform info seq_blocks+    pure $ CmmProc info lbl live $ ListGraph far_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+
+ GHC/CmmToAsm/CFG.hs view
@@ -0,0 +1,1360 @@+{-# 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.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 GHC.Data.Word64Map.Strict (Word64Map)+import GHC.Data.Word64Set (Word64Set)+import Data.IntMap.Strict (IntMap)+import Data.IntSet (IntSet)++import qualified Data.IntMap.Strict as IM+import qualified GHC.Data.Word64Map.Strict as WM+import qualified Data.Map as M+import qualified Data.IntSet as IS+import qualified GHC.Data.Word64Set as WS+import qualified Data.Set as S+import Data.Tree+import Data.Bifunctor++import GHC.Utils.Outputable+import GHC.Utils.Panic+-- 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+import Data.Word++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 (mapLookup from cuts_map)+                              `union` expectJust (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 $ getEdgeInfo from to cfg++getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource+getTransitionSource from to cfg = transitionSource $ expectJust $ 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 -> GenCmmDecl d h CmmGraph -> 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+              , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set)+    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)]++    toWord64Set :: LabelSet -> Word64Set+    toWord64Set s = WS.fromList . map fromBlockId . setElems $ s+    toWord64Map :: LabelMap a -> Word64Map a+    toWord64Map m = WM.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 -> Word64+    fromBlockId = getKey . getUnique++    toBlockId :: Word64 -> 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 $ 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
+ GHC/CmmToAsm/CFG/Dominators.hs view
@@ -0,0 +1,585 @@+{-# 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 CGraphs for Procedures in Static Single/+      /Information Form are Interval CGraphs/, 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,asCGraph+  ,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)+import GHC.Data.Word64Set (Word64Set)+import qualified GHC.Data.Word64Set as WS+import GHC.Data.Word64Map (Word64Map)+import qualified GHC.Data.Word64Map as WM+import Data.Word++-----------------------------------------------------------------------------++-- Compacted nodes; these can be stored in contiguous arrays+type CNode       = Int+type CGraph      = IntMap IntSet++type Node     = Word64+type Path     = [Node]+type Edge     = (Node, Node)+type Graph    = Word64Map Word64Set+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 predGW 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    = Word64Set+type NodeMap a  = Word64Map a+data Env s = Env+  {succE      :: !CGraph+  ,predE      :: !CGraph+  ,bucketE    :: !CGraph+  ,dfsE       :: {-# UNPACK #-}!Int+  ,zeroE      :: {-# UNPACK #-}!CNode+  ,rootE      :: {-# UNPACK #-}!CNode+  ,labelE     :: {-# UNPACK #-}!(Arr s CNode)+  ,parentE    :: {-# UNPACK #-}!(Arr s CNode)+  ,ancestorE  :: {-# UNPACK #-}!(Arr s CNode)+  ,childE     :: {-# UNPACK #-}!(Arr s CNode)+  ,ndfsE      :: {-# UNPACK #-}!(Arr s CNode)+  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)+  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)+  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)+  ,domE       :: {-# UNPACK #-}!(Arr s CNode)+  ,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 :: CNode -> Dom s CNode+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 :: CNode -> 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 :: CNode -> CNode -> 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 :: CNode -> 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+  -- CGraph renumbered to indices from 1 to |V|+  let (g,rnmap) = renum 1 g0+      pred      = predG g -- reverse graph+      root      = rnmap WM.! r0 -- renamed root+      n         = IM.size g+      ns        = [0..n]+      m         = n+1++  let bucket = IM.fromList+        (zip ns (repeat mempty))++  rna <- newW m+  writes rna (fmap swap+        (WM.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 CNode+zeroM = gets zeroE+domM :: CNode -> Dom s CNode+domM = fetch domE+rootM :: Dom s CNode+rootM = gets rootE+succsM :: CNode -> Dom s [CNode]+succsM i = gets (IS.toList . (! i) . succE)+predsM :: CNode -> Dom s [CNode]+predsM i = gets (IS.toList . (! i) . predE)+bucketM :: CNode -> Dom s [CNode]+bucketM i = gets (IS.toList . (! i) . bucketE)+sizeM :: CNode -> Dom s Int+sizeM = fetch sizeE+sdnoM :: CNode -> Dom s Int+sdnoM = fetch sdnoE+-- dfnM :: CNode -> Dom s Int+-- dfnM = fetch dfnE+ndfsM :: Int -> Dom s CNode+ndfsM = fetch ndfsE+childM :: CNode -> Dom s CNode+childM = fetch childE+ancestorM :: CNode -> Dom s CNode+ancestorM = fetch ancestorE+parentM :: CNode -> Dom s CNode+parentM = fetch parentE+labelM :: CNode -> Dom s CNode+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++newW :: Int -> ST s (Arr s Node)+newW = 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 = WM.fromList . fmap (second WS.fromList)++fromEdges :: [Edge] -> Graph+fromEdges = collectW WS.union fst (WS.singleton . snd)++toAdj :: Graph -> [(Node, [Node])]+toAdj = fmap (second WS.toList) . WM.toList++toEdges :: Graph -> [Edge]+toEdges = concatMap (uncurry (fmap . (,))) . toAdj++predG :: CGraph -> CGraph+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))++predGW :: Graph -> Graph+predGW g = WM.unionWith WS.union (go g) g0+  where g0 = fmap (const mempty) g+        go = flip WM.foldrWithKey mempty (\i a m ->+                foldl' (\m p -> WM.insertWith mappend p+                                      (WS.singleton i) m)+                        m+                       (WS.toList a))++pruneReach :: Rooted -> Rooted+pruneReach (r,g) = (r,g2)+  where is = reachable+              (maybe mempty id+                . flip WM.lookup g) $ r+        g2 = WM.fromList+            . fmap (second (WS.filter (`WS.member`is)))+            . filter ((`WS.member`is) . fst)+            . WM.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)++asCGraph :: Tree Node -> Rooted+asCGraph 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 ((WS.toList . f) a))+                   f = (g !)+            in go r+  where (!) g n = maybe mempty id (WM.lookup n g)+++reachable :: (Node -> NodeSet) -> (Node -> NodeSet)+reachable f a = go (WS.singleton a) a+  where go seen a = let s = f a+                        as = WS.toList (s `WS.difference` seen)+                    in foldl' go (s `WS.union` seen) as++collectW :: (c -> c -> c)+        -> (a -> Node) -> (a -> c) -> [a] -> Word64Map c+collectW (<>) f g+  = foldl' (\m a -> WM.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 -> (CGraph, NodeMap CNode)+renum from = (\(_,m,g)->(g,m))+  . WM.foldrWithKey+      (\i ss (!n,!env,!new)->+          let (j,n2,env2) = go n env i+              (n3,env3,ss2) = WS.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 CNode+           -> Node+           -> (CNode,Int,NodeMap CNode)+        go !n !env i =+          case WM.lookup i env of+            Just j -> (j,n,env)+            Nothing -> (n,n+1,WM.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)
+ GHC/CmmToAsm/CFG/Weight.hs view
@@ -0,0 +1,78 @@+module GHC.CmmToAsm.CFG.Weight+   ( Weights (..)+   , defaultWeights+   , parseWeights+   )+where++import GHC.Prelude+import GHC.Utils.Panic++-- | Edge weights to use when generating a CFG from CMM+data Weights = Weights+   { uncondWeight       :: Int+   , condBranchWeight   :: Int+   , switchWeight       :: Int+   , callWeight         :: Int+   , likelyCondWeight   :: Int+   , unlikelyCondWeight :: Int+   , infoTablePenalty   :: Int+   , backEdgeBonus      :: Int+   }++-- | Default edge weights+defaultWeights :: Weights+defaultWeights = Weights+   { uncondWeight       = 1000+   , condBranchWeight   = 800+   , switchWeight       = 1+   , callWeight         = -10+   , likelyCondWeight   = 900+   , unlikelyCondWeight = 300+   , infoTablePenalty   = 300+   , backEdgeBonus      = 400+   }++parseWeights :: String -> Weights -> Weights+parseWeights s oldWeights =+        foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments+    where+        assignments = map assignment $ settings s+        update "uncondWeight" n w =+            w {uncondWeight = n}+        update "condBranchWeight" n w =+            w {condBranchWeight = n}+        update "switchWeight" n w =+            w {switchWeight = n}+        update "callWeight" n w =+            w {callWeight = n}+        update "likelyCondWeight" n w =+            w {likelyCondWeight = n}+        update "unlikelyCondWeight" n w =+            w {unlikelyCondWeight = n}+        update "infoTablePenalty" n w =+            w {infoTablePenalty = n}+        update "backEdgeBonus" n w =+            w {backEdgeBonus = n}+        update other _ _+            = panic $ other +++                      " is not a CFG weight parameter. " +++                      exampleString+        settings s+            | (s1,rest) <- break (== ',') s+            , null rest+            = [s1]+            | (s1,rest) <- break (== ',') s+            = s1 : settings (drop 1 rest)++        assignment as+            | (name, _:val) <- break (== '=') as+            = (name,read val)+            | otherwise+            = panic $ "Invalid CFG weight parameters." ++ exampleString++        exampleString = "Example parameters: uncondWeight=1000," +++            "condBranchWeight=800,switchWeight=0,callWeight=300" +++            ",likelyCondWeight=900,unlikelyCondWeight=300" +++            ",infoTablePenalty=300,backEdgeBonus=400"+
+ GHC/CmmToAsm/CPrim.hs view
@@ -0,0 +1,160 @@+{-# 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)
+ GHC/CmmToAsm/Config.hs view
@@ -0,0 +1,67 @@+-- | 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+   , ncgAvxEnabled            :: !Bool+   , ncgAvx2Enabled           :: !Bool+   , ncgAvx512fEnabled        :: !Bool+   , 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)+   , ncgEnableInterModuleFarJumps:: !Bool            -- ^ Use far-jumps for cross-module jumps.+   , 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
+ GHC/CmmToAsm/Dwarf.hs view
@@ -0,0 +1,271 @@+module GHC.CmmToAsm.Dwarf (+  dwarfGen+  ) where++import GHC.Prelude++import GHC.Cmm.CLabel+import GHC.Cmm.Expr+import GHC.Data.FastString+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.DSM++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++-- | Generate DWARF/debug information+dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (doc, DUniqSupply)+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') = takeUniqueFromDSupply 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'') = takeUniqueFromDSupply us'+      frameSct = dwarfFrameSection platform $$+                 line (dwarfFrameLabel <> colon) $$+                 pprDwarfFrame platform (debugFrame platform 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 -> DUniqSupply -> [DebugBlock] -> (SDoc, DUniqSupply) #-}+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> DUniqSupply -> [DebugBlock] -> (HDoc, DUniqSupply) #-} -- 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{} -> case sourceName s of+                            LexicalFastString s -> unpackFS 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 :: Platform -> Unique -> [DebugBlock] -> DwarfFrame+debugFrame p u procs+  = DwarfFrame { dwCieLabel = mkAsmTempLabel u+               , dwCieInit  = initUws+               , dwCieProcs = map (procToFrame initUws) procs+               }+  where+    initUws :: UnwindTable+    initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 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+    ]
+ GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -0,0 +1,260 @@+-- | 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+  ArchRISCV64  -> fromIntegral $ toRegNo r+  ArchLoongArch64  -> 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+    ArchRISCV64 -> 1 -- ra (return address)+    ArchLoongArch64 -> 1 -- ra (return address)+    _other     -> error "dwarfReturnRegNo: Unsupported platform!"
+ GHC/CmmToAsm/Dwarf/Types.hs view
@@ -0,0 +1,656 @@+{-# 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+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 {dwChildren = kids} -> hasChildren kids+      DwarfSubprogram  {dwChildren = kids} -> hasChildren kids+      DwarfBlock       {dwChildren = kids} -> hasChildren kids+      DwarfSrcNote {}                      -> noChildren+  where+    hasChildren kids =+        pprDwarfInfoOpen platform haveSrc d $$+        vcat (map (pprDwarfInfo platform haveSrc) kids) $$+        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 (GlobalRegUse 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 (GlobalRegUse 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 (GlobalRegUse 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 r@(GlobalRegUse Sp _) i)+          | spIsCFA+                              = if i == 0+                                then pprByte dW_OP_call_frame_cfa+                                else pprE (UwPlus (UwReg r 0) (UwConst i))+        pprE (UwReg (GlobalRegUse 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
+ GHC/CmmToAsm/Format.hs view
@@ -0,0 +1,292 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}++-- | 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(.., IntegerFormat),+    ScalarFormat(..),+    intFormat,+    floatFormat,+    isIntFormat,+    isIntScalarFormat,+    intScalarFormat,+    isFloatFormat,+    vecFormat,+    isVecFormat,+    cmmTypeFormat,+    formatToWidth,+    scalarWidth,+    formatInBytes,+    isFloatScalarFormat,+    isFloatOrFloatVecFormat,+    floatScalarFormat,+    scalarFormatFormat,+    VirtualRegWithFormat(..),+    RegWithFormat(..),+    takeVirtualRegs,+    takeRealRegs,+)++where++import GHC.Prelude++import GHC.Cmm+import GHC.Platform.Reg ( Reg(..), RealReg, VirtualReg )+import GHC.Types.Unique ( Uniquable(..) )+import GHC.Types.Unique.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic++{- Note [GHC's data format representations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has severals types that represent various aspects of data format.+These include:++ * 'CmmType.CmmType': The data classification used throughout the C--+   pipeline. This is a pair of a CmmCat and a Width.++ * 'CmmType.CmmCat': What the bits in a C-- value mean (e.g. a pointer, integer, or floating-point value)++ * 'CmmType.Width': The width of a C-- value.++ * 'CmmType.Length': The width (measured in number of scalars) of a vector value.++ * 'Format.Format': The data format representation used by much of the backend.++ * 'Format.ScalarFormat': The format of a 'Format.VecFormat'\'s scalar.++ * 'RegClass.RegClass': Whether a register is an integer or a floating point/vector register.+-}++-- 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+        | VecFormat !Length       -- ^ number of elements (always at least 2)+                    !ScalarFormat -- ^ format of each element+        deriving (Show, Eq, Ord)++pattern IntegerFormat :: Format+pattern IntegerFormat <- ( isIntegerFormat -> True )+{-# COMPLETE IntegerFormat, FF32, FF64, VecFormat #-}++isIntegerFormat :: Format -> Bool+isIntegerFormat = \case+  II8  -> True+  II16 -> True+  II32 -> True+  II64 -> True+  _    -> False+++instance Outputable Format where+  ppr fmt = text (show fmt)++data ScalarFormat+  = FmtInt8+  | FmtInt16+  | FmtInt32+  | FmtInt64+  | FmtFloat+  | FmtDouble+  deriving (Show, Eq, Ord)++scalarFormatFormat :: ScalarFormat -> Format+scalarFormatFormat = \case+  FmtInt8 -> II8+  FmtInt16 -> II16+  FmtInt32 -> II32+  FmtInt64 -> II64+  FmtFloat -> FF32+  FmtDouble -> FF64++isFloatScalarFormat :: ScalarFormat -> Bool+isFloatScalarFormat = \case+  FmtFloat -> True+  FmtDouble -> True+  _ -> False++isFloatOrFloatVecFormat :: Format -> Bool+isFloatOrFloatVecFormat = \case+  VecFormat _ sFmt -> isFloatScalarFormat sFmt+  fmt -> isFloatFormat fmt++floatScalarFormat :: Width -> ScalarFormat+floatScalarFormat W32 = FmtFloat+floatScalarFormat W64 = FmtDouble+floatScalarFormat w = pprPanic "floatScalarFormat" (ppr w)++isIntScalarFormat :: ScalarFormat -> Bool+isIntScalarFormat = not . isFloatScalarFormat++intScalarFormat :: Width -> ScalarFormat+intScalarFormat = \case+  W8  -> FmtInt8+  W16 -> FmtInt16+  W32 -> FmtInt32+  W64 -> FmtInt64+  w   -> pprPanic "intScalarFormat" (ppr w)++-- | 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"++-- | Check if a format represent an integer value.+isIntFormat :: Format -> Bool+isIntFormat format =+  case format of+    II8  -> True+    II16 -> True+    II32 -> True+    II64 -> True+    _    -> False++-- | Get the float format of this width.+floatFormat :: Width -> Format+floatFormat width+ = case width of+        W32     -> FF32+        W64     -> FF64+        other   -> pprPanic "Format.floatFormat" (ppr other)++-- | Check if a format represents a floating point value.+isFloatFormat :: Format -> Bool+isFloatFormat format+ = case format of+        FF32    -> True+        FF64    -> True+        _       -> False++vecFormat :: CmmType -> Format+vecFormat ty =+  let l      = vecLength ty+      elemTy = vecElemType ty+   in if isFloatType elemTy+      then case typeWidth elemTy of+             W32 -> VecFormat l FmtFloat+             W64 -> VecFormat l FmtDouble+             _   -> pprPanic "Incorrect vector element width" (ppr elemTy)+      else case typeWidth elemTy of+             W8  -> VecFormat l FmtInt8+             W16 -> VecFormat l FmtInt16+             W32 -> VecFormat l FmtInt32+             W64 -> VecFormat l FmtInt64+             _   -> pprPanic "Incorrect vector element width" (ppr elemTy)++-- | Check if a format represents a vector+isVecFormat :: Format -> Bool+isVecFormat (VecFormat {}) = True+isVecFormat _              = False+++-- | Convert a Cmm type to a Format.+cmmTypeFormat :: CmmType -> Format+cmmTypeFormat ty+        | isFloatType ty        = floatFormat (typeWidth ty)+        | isVecType ty          = vecFormat 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+        VecFormat l s ->+          widthFromBytes (l * widthInBytes (scalarWidth s))++scalarWidth :: ScalarFormat -> Width+scalarWidth = \case+  FmtInt8   -> W8+  FmtInt16  -> W16+  FmtInt32  -> W32+  FmtInt64  -> W64+  FmtFloat  -> W32+  FmtDouble -> W64++formatInBytes :: Format -> Int+formatInBytes = widthInBytes . formatToWidth++--------------------------------------------------------------------------------++-- | A typed virtual register: a virtual register, together with the specific+-- format we are using it at.+data VirtualRegWithFormat+    = VirtualRegWithFormat+    { virtualRegWithFormat_reg :: {-# UNPACK #-} !VirtualReg+    , virtualRegWithFormat_format :: !Format+    }++-- | A typed register: a register, together with the specific format we+-- are using it at.+data RegWithFormat+    = RegWithFormat+    { regWithFormat_reg :: {-# UNPACK #-} !Reg+    , regWithFormat_format :: !Format+    }++instance Show RegWithFormat where+  show (RegWithFormat reg fmt) = show reg ++ "::" ++ show fmt++instance Uniquable RegWithFormat where+  getUnique = getUnique . regWithFormat_reg++instance Outputable VirtualRegWithFormat where+  ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++instance Outputable RegWithFormat where+  ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++-- | Take all the virtual registers from this set.+takeVirtualRegs :: UniqSet RegWithFormat -> UniqSet VirtualReg+takeVirtualRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegVirtual vr } -> Just vr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]++-- | Take all the real registers from this set.+takeRealRegs :: UniqSet RegWithFormat -> UniqSet RealReg+takeRealRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegReal rr } -> Just rr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]
+ GHC/CmmToAsm/Instr.hs view
@@ -0,0 +1,180 @@++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+import GHC.CmmToAsm.Format++import GHC.Utils.Misc (HasDebugCallStack)++-- | 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 :: [RegWithFormat],+                writes :: [RegWithFormat]+                }+        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+                :: HasDebugCallStack+                => Platform+                -> 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 *local block* destinations of this jump instruction.+        --      Must be defined for all jumpish instructions.+        jumpDestsOfInstr+                :: instr -> [BlockId]++        -- | Check if the instr always transfers control flow+        -- to the given block. Used by code layout to eliminate+        -- jumps that can be replaced by fall through.+        canFallthroughTo+                :: instr -> BlockId -> Bool+++        -- | 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+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ the reg to spill+                -> Int          -- ^ the current stack delta+                -> Int          -- ^ spill slots to use+                -> [instr]      -- ^ instructions+++        -- | An instruction to reload a register from a spill slot.+        mkLoadInstr+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ 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+                :: HasDebugCallStack+                => NCGConfig+                -> Format+                -> 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+                :: Platform+                -> 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]
+ GHC/CmmToAsm/LA64.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for LoongArch64 architectures+module GHC.CmmToAsm.LA64 ( ncgLA64 ) where++import GHC.Prelude++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Types+import GHC.Utils.Outputable (ftext)++import qualified GHC.CmmToAsm.LA64.CodeGen  as LA64+import qualified GHC.CmmToAsm.LA64.Instr    as LA64+import qualified GHC.CmmToAsm.LA64.Ppr      as LA64+import qualified GHC.CmmToAsm.LA64.RegInfo  as LA64+import qualified GHC.CmmToAsm.LA64.Regs     as LA64++ncgLA64 :: NCGConfig -> NcgImpl RawCmmStatics LA64.Instr LA64.JumpDest+ncgLA64 config =+  NcgImpl+    { ncgConfig                 = config,+      cmmTopCodeGen             = LA64.cmmTopCodeGen,+      generateJumpTableForInstr = LA64.generateJumpTableForInstr config,+      getJumpDestBlockId        = LA64.getJumpDestBlockId,+      canShortcut               = LA64.canShortcut,+      shortcutStatics           = LA64.shortcutStatics,+      shortcutJump              = LA64.shortcutJump,+      pprNatCmmDeclS            = LA64.pprNatCmmDecl config,+      pprNatCmmDeclH            = LA64.pprNatCmmDecl config,+      maxSpillSlots             = LA64.maxSpillSlots config,+      allocatableRegs           = LA64.allocatableRegs platform,+      ncgAllocMoreStack         = LA64.allocMoreStack platform,+      ncgMakeFarBranches        = LA64.makeFarBranches,+      extractUnwindPoints       = const [],+      invertCondBranches        = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for LA64+instance Instruction LA64.Instr where+  regUsageOfInstr       = LA64.regUsageOfInstr+  patchRegsOfInstr _    = LA64.patchRegsOfInstr+  isJumpishInstr        = LA64.isJumpishInstr+  canFallthroughTo      = LA64.canFallthroughTo+  jumpDestsOfInstr      = LA64.jumpDestsOfInstr+  patchJumpInstr        = LA64.patchJumpInstr+  mkSpillInstr          = LA64.mkSpillInstr+  mkLoadInstr           = LA64.mkLoadInstr+  takeDeltaInstr        = LA64.takeDeltaInstr+  isMetaInstr           = LA64.isMetaInstr+  mkRegRegMoveInstr _ _ = LA64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = LA64.takeRegRegMoveInstr+  mkJumpInstr           = LA64.mkJumpInstr+  mkStackAllocInstr     = LA64.mkStackAllocInstr+  mkStackDeallocInstr   = LA64.mkStackDeallocInstr+  mkComment             = pure . LA64.COMMENT . ftext+  pprInstr              = LA64.pprInstr
+ GHC/CmmToAsm/LA64/CodeGen.hs view
@@ -0,0 +1,2236 @@+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+module GHC.CmmToAsm.LA64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+    , makeFarBranches+)++where++import Data.Maybe+import Data.Word+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.DebugBlock+import GHC.Cmm.Switch+import GHC.Cmm.Utils+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Monad+  ( NatM,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.Types+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Float+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)+import GHC.Types.Tickish (GenTickish (..))+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Monad+import Control.Monad+import GHC.Cmm.Dataflow.Label+import GHC.Types.Unique.DSM++-- [General layout of an NCG]+cmmTopCodeGen ::+  RawCmmDecl ->+  NatM [NatCmmDecl RawCmmStatics Instr]+-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  picBaseMb <- getPicBaseMaybeNat+  when (isJust picBaseMb) $ panic "LA64.cmmTopCodeGen: Unexpected PIC base register"++  let blocks = toBlockListEntryFirst graph+  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  pure tops++-- ... or CmmData.+cmmTopCodeGen (CmmData sec dat) = pure [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+  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 `.loc` (DWARF debug location info)+  loc_instrs <- genLocInstrs++  -- Generate other instructions+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail++  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs++      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to+      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs+      -- work fine without it.++      -- 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.+      (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs++  return (BasicBlock id top : other_blocks, statics)+  where+    genLocInstrs :: NatM (OrdList Instr)+    genLocInstrs = do+      dbg <- getDebugBlock (entryLabel block)+      case dblSourceTick =<< dbg of+        Just (SourceNote span name) ->+          do+            fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            pure $ unitOL $ LOCATION fileId line col name+        _ -> pure nilOL++mkBlocks ::+  Instr ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+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)++-- -----------------------------------------------------------------------------+-- | Utilities++-- | Annotate an `Instr` with a `SDoc` comment+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc 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 {- debugIsOn -} = ANN (text . show $ e)+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the address to jump to.+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  targetReg <- getNewRegNat II64+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg $ dynRef+  let code =+        toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr)+             , COMMENT (text "dynRef" <+> (text . show) dynRef)+             ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [+              COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (SLL (OpReg W64 reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg W64 reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL bids (Just lbl) targetReg+            ]+  return code+  where+    platform = ncgPlatform config+    expr_w = cmmExprWidth platform expr+    indexExpr0 = cmmOffset platform expr offset+    -- Widen to a native-width register(addressing modes)+    indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    (offset, bids) = switchTargetsToTable targets+++-- Generate jump table data (if required)+--+-- Relies on PIC relocations. The idea is to emit one table entry per case. The+-- entry is the label of the block to jump to. This will be relocated to be the+-- address of the jump target.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel 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++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector+stmtsToInstrs ::+  -- | Cmm Statements+  [CmmNode O O] ->+  -- | Resulting instruction+  NatM InstrBlock+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts++stmtToInstrs ::+  CmmNode e x ->+  -- | Resulting instructions+  NatM InstrBlock++stmtToInstrs stmt = do+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+      -> genCCall target result_regs args++    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 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 true false arg++    CmmSwitch arg ids -> genSwitch config arg ids++    CmmCall { cml_target = arg } -> genJump arg++    CmmUnwind _regs -> pure 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 a `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 (globalRegUse_reg mid) of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)++-- General things for putting together code sequences++-- | Compute an expression into any register+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)++-- | Compute an expression into any floating-point register++-- | Compute an expression into floating point register+--  If the initial expression is not a floating-point expression, finally move+--  the result into a floating-point register.+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)++-- | Map `CmmLit` to `OpImm`+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- Handling PIC on LA64+-- Commonly, `PIC` means of `position independent code`, that to say, the execution+-- of code does not be influenced by Load_address. Through PC-Relative addressing+-- or GOT addressing, both can be used to implement `PIC`.+--+-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default+-- without condition. The command option `-fPIC` dicates to generate code for+-- shared-library. If not just specified for shared-library, another option `-fPIE`+-- was be created.+--+-- Like RV64, LA64 does not have a special PIC register, the general approach is to+-- simply do PC-relative addressing or go through the GOT. There is assembly support+-- for both.+--+-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows+-- loading a symbols's address into a register. These instructions is desugared into+-- different addressing modes. See following:+--+-- la        rd, label + addend  -> Load global symbol+-- la.global rd, label + addend  -> Same as `la`+-- la.local  rd, label + addend  -> Load local symbol+-- la.pcrel  rd, label + addend+-- la.got    rd, label+-- la.abs    rd, label + addend+--+-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`.+--+-- PC-relative addressing:+--   pcalau12i $a0, %pc_hi20(a)+--   addi.d    $a0, $a0, %pc_lo12(a)+--+-- GOT addressing:+--   pcalau12i $a0, %got_pc_hi20(global_a)+--   ld.d      $a0, $a0, %got_pc_lo12(global_a)+--+-- PIC can be enabled/disabled through:+--  .option pic+--+-- 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 LA64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.++-- Compute a `CmmExpr` into a `Register`+getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- Signed arithmetic on LoongArch64+--+-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky+-- as Cmm's type system does not capture signedness. While 32- and 64-bit+-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions+-- with responding register, 8- and 16-bit values require quite some care.+--+-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit.+-- However, it is best to use EXT instruction only if the input and+-- output data widths are fully determined.+--+-- We handle 16-and 8-bit values by using the following two steps:+--  1. Sign- or Zero-extending operands.+--  2. 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.++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register++-- OPTIMIZATION WARNING: CmmExpr rewrites++-- Generic case.+getRegister' config plat expr =+  case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->+      pprPanic "getRegisterReg-memory" (ppr PicBaseReg)++    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w -> do+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))++        CmmFloat 0 w -> do+          let op = litToImm' lit+          pure (Any (floatFormat w) (\dst -> unitOL $ 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+          tmp <- getNewRegNat (intFormat W32)+          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)+                                                      ]))+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          tmp <- getNewRegNat (intFormat W64)+          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)+                                                      ]))++        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)++        CmmLabel lbl -> do+          let op = OpImm (ImmCLbl lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ annExpr expr (LD format (OpReg (formatToWidth format) dst) op)))++        CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          let op = OpImm (ImmIndex lbl off)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ LD format (OpReg (formatToWidth format) dst) op))++        CmmLabelOff lbl off -> do+          let op = litToImm' (CmmLabel lbl)+              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 -> off_code `snocOL`+                                                LD format (OpReg (formatToWidth format) dst) op `snocOL`+                                                ADD (OpReg W64 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+      let format = cmmTypeFormat rep+          width = typeWidth rep+      Amode addr addr_code <- getAmode plat width mem+      case width of+        w | w `elem` [W8, W16, W32, W64] ->+            -- Load without sign-extension.+            pure (Any format (\dst ->+              addr_code `snocOL`+              LDU format (OpReg width dst) (OpAddr addr))+                              )+        _ -> pprPanic ("Unknown width to load: " ++ show width) (pdoc plat expr)++    CmmStackSlot _ _  -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)++    CmmReg reg -> return (Fixed (cmmTypeFormat (cmmRegType 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 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 W64 dst) (OpReg width reg) (OpReg width off_r)+                                     )+      where+        width = typeWidth (cmmRegType reg)++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)++    -- 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 ->+          code `appOL`+          -- pseudo instruction `not dst rd` is `nor dst, r0, rd`+          truncateReg (formatToWidth format) W64 reg `snocOL`+          -- At this point an 8- or 16-bit value would be zero-extended+          -- to 64-bits. Truncate back down the final width.+          ann (text "not") (NOR (OpReg W64 dst) (OpReg W64 reg) zero) `appOL`+          truncateReg W64 w dst++        MO_S_Neg w -> negate code w reg+        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FNEG (OpReg w dst) (OpReg w reg))++        -- Floating convertion oprations+        -- Float -> Float+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))++        -- Signed int -> Float+        MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))++        -- Float -> Signed int+        MO_FS_Truncate from to | from == W32 -> do+            tmp <- getNewRegNat FF32+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        MO_FS_Truncate from to | from == W64-> do+            tmp <- getNewRegNat FF64+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        -- unsigned int -> unsigned int+        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst ->+          code `snocOL` BSTRPICK II64 (OpReg W64 dst) (OpReg W64 reg) (OpImm (ImmInt (widthToInt (min from to) - 1))) (OpImm (ImmInt 0))+                                                          )++        -- Signed int -> Signed int+        MO_SS_Conv from to -> ss_conv from to reg code++        -- int -> int+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))++        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits+        negate code w reg+          | w `elem` [W8, W16] = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 reg) (OpReg w reg) `snocOL`+                NEG (OpReg W64 dst) (OpReg W64 reg) `appOL`+                truncateReg W64 w dst+          | otherwise = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                NEG (OpReg W64 dst) (OpReg w reg)++        ss_conv from to reg code+          | from `elem` [W8, W16] || to `elem` [W8, W16] = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL`+                -- At this point an 8- or 16-bit value would be sign-extended+                -- to 64-bits. Truncate back down the final width.+                truncateReg W64 to dst+          | from == W32 && to == W64 = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0))+          | from == to = do+            return $ Any (intFormat from) $ \dst ->+                 code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          | otherwise = do+            return $ Any (intFormat to) $ \dst ->+                code `appOL`+                signExtend from W64 reg dst `appOL`+                truncateReg W64 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'++    CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Quot w) [x, y]+      | w `elem` [W8, 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 `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    -- 2. Shifts.+    CmmMachOp (MO_Shl w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, 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 (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> 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 (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_S_Shr: signed-shift-right+    CmmMachOp (MO_S_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w)  (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                      )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, 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 (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> 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 (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_U_Shr: unsigned-shift-right+    CmmMachOp (MO_U_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, 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 `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )+        _ -> 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 (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- 3. Logic &&, ||+    -- andi Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_And w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> 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 `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> 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 (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- ori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Or w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> 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 `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> 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 (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- xori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Xor w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> 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 `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> 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 (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++    -- CSET commands register operand being W64.+    CmmMachOp (MO_Eq w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+       | otherwise -> 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 (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_Ne w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      signExtend w W64 reg_x reg_x `snocOL`+                                      annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      truncateReg w W64 reg_x `snocOL`+                                      annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger  n))))++    CmmMachOp (MO_S_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> 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 `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> 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 (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let+          -- A (potentially signed) integer operation.+          -- In the case of 8-, 16- and 32-bit signed arithmetic we must first+          -- sign-extend all arguments to 64-bits.+          -- TODO: can be simplified.+          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"+              let w' = W64+              -- This is the width of the registers on which the operation+              -- should be performed.+              if not is_signed+                then return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- zero-extend both operands+                      truncateReg (formatToWidth format_x) w' reg_x `appOL`+                      truncateReg (formatToWidth format_y) w' reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                      truncateReg w' w dst -- truncate back to the operand's original width+                else return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- sign-extend both operands+                      signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                      signExtend (formatToWidth format_x) W64 reg_y reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `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 ->  annExpr expr (ADD d x y))+        MO_Sub w -> intOp False w (\d x y ->  annExpr expr (SUB d x y))++        -- Signed multiply/divide/remain+        MO_Mul w          -> intOp True w (\d x y -> annExpr expr (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 -> annExpr expr (DIV d x y))+        MO_S_Rem w   -> intOp True w (\d x y -> annExpr expr (MOD d x y))++        -- Unsigned divide/remain+        MO_U_Quot w  -> intOp False w (\d x y -> annExpr expr (DIVU d x y))+        MO_U_Rem w   -> intOp False w (\d x y -> annExpr expr (MODU d x y))++        -- Floating point arithmetic+        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y))+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y))++        -- Floating point comparison+        MO_F_Eq w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET EQ d x y))+        MO_F_Ne w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET NE d x y))+        MO_F_Ge w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGE d x y))+        MO_F_Le w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLE d x y))+        MO_F_Gt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y))+        MO_F_Lt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y))++        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->+      case op of++        -- Floating-point fused multiply-add operations+        MO_FMA var l w+          | l == 1+          -> case var of+            FMAdd  -> float3Op w (\d n m a -> unitOL $ FMA FMAdd  d n m a)+            FMSub  -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> sorry "The RISCV64 backend does not (yet) support vectors."++        _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)++      where+          float3Op w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            (reg_fz, format_z, code_fz) <- getFloatReg z+            massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $+              text "float3Op: non-float"+            pure $+              Any (floatFormat w) $ \ dst ->+                code_fx `appOL`+                code_fy `appOL`+                code_fz `appOL`+                op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)++    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    -- N.B. MUL does not set the overflow flag.+    -- Return 0 when the operation cannot overflow, /= 0 otherwise+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo 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 W64) (\dst ->+        code_x `appOL`+        code_y `snocOL`+        MULH (OpReg W64 hi) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        MUL  (OpReg W64 lo) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        SRA  (OpReg W64 lo) (OpReg W64 lo)     (OpImm (ImmInt 63)) `snocOL`+        CSET NE (OpReg W64 dst) (OpReg W64 hi)  (OpReg W64 lo)+                                 )++    do_mul_may_oflo W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+            ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL`+            CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                     )++    -- General case+    do_mul_may_oflo w x y = do+      -- Assert: 8bit * 8bit cannot overflow 16bit, and so on.+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      tmp1 <- getNewRegNat II64+      tmp2 <- getNewRegNat II64+      let width_x = formatToWidth format_x+          width_y = formatToWidth format_y+          extend dst src =+            case w of+              W8  -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              W16 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"+          extract width dst src =+            case width of+              W8  -> EXT (OpReg W64 dst) (OpReg W8 src)+              W16 -> EXT (OpReg W64 dst) (OpReg W16 src)+              W32 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"++      case w of+        w | (width_x < w) && (width_y < w) ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 0)))+                                     )+        w | w <= W32 && width_x <= W32 && width_y <= W32 ->+            return $ Any (intFormat W32) (\dst ->+                code_x `appOL`+                code_y `appOL`+                -- signExtend [W8, W16] register to W64 and then SLL+                -- nil for W32+                signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                extend reg_x reg_x `snocOL`+                extend reg_y reg_y `snocOL`+                -- 64-bits MUL+                MUL (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+                -- extract valid result via result's width+                -- slli.w for W32, otherwise ext.w.[b, h]+                extract w tmp2 tmp1 `snocOL`+                CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                        )++        -- Should it be happened?+        _ ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 1))))++-- Sign-extend the value in the given register from width @w@+-- up to width @w'@.+-- TODO: Is there room for optimization?+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' r r'+  | w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+  | w > W64 || w' > W64  = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == W64 && w' == W64 && r == r' = nilOL+  | w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0))+  -- Sign-extend W8 and W16 to W64.+  | w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r)+  | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r)+  | otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'++-- | 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+  | w > W64 || w' > W64  = pprPanic "Tructate Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == w' = nilOL+  | w /= w' = toOL+    [+      ann+        (text "truncateReg: " <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (BSTRPICK II64 (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) (OpImm (ImmInt 0)))+    ]+  | otherwise = pprPanic "truncateReg: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'+  where+    shift = (min (widthInBits w) (widthInBits w')) - 1++--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++-- | Provide the value of a `CmmExpr` with an `Amode`+--  N.B. this function should be used to provide operands to load and store+--  instructions with signed 12bit wide immediates (S & I types). For other+--  immediate sizes and formats (e.g. B type uses multiples of 2) this function+--  would need to be adjusted.+getAmode :: Platform+         -> Width     -- ^ width of loaded value+         -> CmmExpr+         -> NatM Amode++-- LD/ST: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64, fitsInNbits 12 (fromIntegral off)+  = 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')])+  | fitsInNbits 12 (fromIntegral off)+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | fitsInNbits 12 (fromIntegral (-off))+  = 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`  ST 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 = do+  case expr of+    (CmmLit (CmmLabel lbl)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl)))+    (CmmLit (CmmBlock bid)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid)))+    _ -> do+      (target, _format, code) <- getSomeReg expr+      -- I'd like to do more.+      return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL`+        (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 W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $+          code_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)+      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)++      -- Optimized /= 0 case.+      CmmMachOp (MO_Ne W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL` (annExpr expr (BNEZ (OpReg W64 reg_x) (TBlock bid)))+      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BNEZ (OpReg W64 reg_x) (TBlock bid)++      -- Generic case.+      CmmMachOp mop [x, y] -> do+        let ubcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                    code_x `appOL`+                    truncateReg (formatToWidth format_x) W64 reg_x  `appOL`+                    code_y `appOL`+                    truncateReg (formatToWidth format_y) W64 reg_y  `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                    code_x `appOL`+                    code_y `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            sbcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                  code_x `appOL`+                  signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                  code_y `appOL`+                  signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                  code_x `appOL`+                  code_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            fbcond w cmp = do+              (reg_fx, _format_fx, code_fx) <- getFloatReg x+              (reg_fy, _format_fy, code_fy) <- getFloatReg y+              rst <- OpReg W64 <$> getNewRegNat II64+              oneReg <- OpReg W64 <$> getNewRegNat II64+              return $+                code_fx `appOL`+                code_fy `snocOL`+                CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL`+                MOV oneReg (OpImm (ImmInt 1)) `snocOL`+                BCOND1 EQ rst oneReg (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 FGT+          MO_F_Ge w -> fbcond w FGE+          MO_F_Lt w -> fbcond w FLT+          MO_F_Le w -> fbcond w FLE+          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 "LA64.genCondJump:case mop: " (text $ show expr)++      _ -> pprPanic "LA64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+-- This is basically an "if with else" statement.+genCondBranch ::+  BlockId ->+  BlockId ->+  CmmExpr ->+  NatM InstrBlock+genCondBranch true false expr = do+  b1 <- genCondJump true expr+  b2 <- genBranch false+  return (b1 `appOL` b2)++-- -----------------------------------------------------------------------------+{-+Generating C calls++Generate a call to a C function:++GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for+integral values.+FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used+for returning values.++An argument is passed using the stack only when no appropriate argument register+is available.++Subroutines should ensure that the initial values of the general-purpose registers+$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call.++At the entry of a procedure call, the return address of the call site is stored+in $ra. A branch jump to this address should be the last instruction executed in+the called procedure.++The on-stack part of the structure and scalar arguments are aligned to the greater+of the type alignment and GRLEN bits, except when this alignment is larger than+ the 16-byte stack alignment. In this case, the part of the argument should be+16-byte-aligned.++In a procedure call, GARs / FARs are generally only used for passing non-floating+-point / floating-point argument data, respectively. However, the floating-point+member of a structure or union argument, or a vector/floating-point argument+wider than FRLEN may be passed in a GAR.+-}++genCCall+    :: ForeignTarget      -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs = do+  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.+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)+        -- if it's not a label, let's compute the expression into a+        -- register and jump to that.+        _ -> 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++      (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++      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 (spMachReg)) (OpReg W64 (spMachReg)) (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 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))+                               , POP_STACK_FRAME+                               , DELTA 0+                               ]++      let code =+            call_target_code -- compute the label (possibly into a register)+              `appOL` moveStackDown (stackSpaceWords)+              `appOL` passArgumentsCode -- put the arguments into x0, ...+              `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)+              `appOL` readResultsCode -- parse the results into registers+              `appOL` moveStackUp (stackSpaceWords)+      return code++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Fabs"+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Fabs"++    PrimTarget MO_F32_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Sqrt"+    PrimTarget MO_F64_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Sqrt"++    PrimTarget (MO_Clz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CLZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+        platform <- getPlatform+        (reg_x, _format_x, code_x) <- getSomeReg arg_reg+        let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+        return ( code_x `appOL` toOL+                 [+                  MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                  SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),+                  SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),+                  OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                  CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)+                 ]+               )+      | otherwise -> unsupported (MO_Clz w)+      where+        shift = widthToInt w++    PrimTarget (MO_Ctz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CTZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `appOL` toOL+               [+                MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),+                BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),+                OR  (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)+               ]+             )+      | otherwise -> unsupported (MO_Ctz w)+      where+        shift = (widthToInt w)++    -- 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"++        -- 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"++        -- 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)++        -- Optional MachOps+        -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config+        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++        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {}  -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {}  -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop++        -- Memory Ordering+        -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.+        -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;+        -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.++        MO_AcquireFence -> pure (unitOL (DBAR Hint0))+        MO_ReleaseFence -> pure (unitOL (DBAR Hint0))+        MO_SeqCstFence  -> pure (unitOL (DBAR Hint0))++        MO_Touch        -> pure nilOL -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> pure nilOL -- 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_BSwap w          -> mkCCall (bSwapLabel w)+        MO_BRev w           -> mkCCall (bRevLabel w)++    -- or a possibly side-effecting machine operation+        mo@(MO_AtomicRead w ord)+          | [p_reg] <- arg_regs+          , [dst_reg] <- dest_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              platform <- getPlatform+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))++                      MemOrderAcquire -> toOL [+                                                ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                                                DBAR Hint0+                                              ]+                      MemOrderSeqCst -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+                  dst = getRegisterReg platform (CmmLocal dst_reg)+                  moDescr = (text . show) mo+                  code = code_p `appOL` instrs+              pure code+          | otherwise -> panic "mal-formed AtomicRead"++        mo@(MO_AtomicWrite w ord)+          | [p_reg, val_reg] <- arg_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              (val, fmt_val, code_val) <- getSomeReg val_reg+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                      MemOrderRelease -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                                              ]+                      MemOrderSeqCst  -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ ->  panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo+                  moDescr = (text . show) mo+                  code =+                    code_p `appOL`+                    code_val `appOL`+                    instrs+              pure code+          | otherwise -> panic "mal-formed AtomicWrite"++        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)+        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+    mkCCall name = do+      config <- getConfig+      target <-+        cmmMakeDynamicReference config CallReference+          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    -- Implementiation of the LoongArch ABI calling convention.+    -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)++    -- 1. Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)++    -- 2. Still have GP regs, and we want to pass an GP argument.+    passArguments (gpReg : gpRegs) fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          ext+            -- Specifically, LoongArch64's ABI requires that the caller+            -- sign-extend arguments which are smaller than 64-bits.+            | w `elem` [W8, W16, W32]+            = case w of+              W8  -> EXT (OpReg W64 gpReg) (OpReg w r)+              W16 -> EXT (OpReg W64 gpReg) (OpReg w r)+              W32 -> SLL (OpReg W64 gpReg) (OpReg w r) (OpImm (ImmInt 0))+              _ -> panic "Unexpected width(Here w < W64)!"+            | otherwise+            = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                          code_r `snocOL`+                          ann (text "Pass gp argument: " <> ppr r) ext++      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- 3. Still have FP regs, and we want to pass an FP argument.+    passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords 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 gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'++    -- 4. No mor regs left to pass. Must pass on stack.+    passArguments [] [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` (MOV (OpReg w tmpReg) (OpReg w r))+              `appOL` truncateReg w W64 tmpReg+              `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str++      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str++      passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++   -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.+    passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument in gpReg: " <> ppr r) mov++      passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'+++    passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock+    readResults _ _ [] _ accumCode = return 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 (CmmLocal dst)+          format = cmmTypeFormat rep+          w = cmmRegWidth (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)+            `appOL`+            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations+            truncateReg W64 w r_dst++    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)+      pure code++data BlockInRange = InRange | NotInRange BlockId++genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target)+                $ BCOND cond op1 op2 (TBlock far_target)+                ]++makeFarBranches ::+  Platform ->+  LabelMap RawCmmStatics ->+  [NatBasicBlock Instr] ->+  UniqDSM [NatBasicBlock Instr]++makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_cond_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_dist = 2 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs')+            (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)++        BCOND1 cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + 1, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + long_bc_jump_dist, fromOL jmp_code)++        _ -> pure (pos + instr_size instr, [instr])++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg{}) -> InRange+        (TBlock bid) -> block_in_range m src bid+        (TLabel clbl)+          | Just bid <- maybeLocalBlockLabel clbl+          -> block_in_range m src bid+          | otherwise+          -> InRange++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing ->+          pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl+        Just dest_pos ->+          if abs (dest_pos - src_pos) < max_cond_jump_dist+            then InRange+          else NotInRange dest_lbl++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =+      let !pos' = pos + infoTblSize_maybe lbl+       in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr = (pos + instr_size instr, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing -> 0 :: Int+        Just _info_static -> max_info_size++    instr_size :: Instr -> Int+    instr_size i = case i of+      COMMENT {} -> 0+      MULTILINE_COMMENT {} -> 0+      ANN _ instr -> instr_size instr+      LOCATION {} -> 0+      DELTA {} -> 0+      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)+      NEWBLOCK {} -> panic "mkFarBranched - Unexpected"+      LDATA {} -> panic "mkFarBranched - Unexpected"+      PUSH_STACK_FRAME -> 4+      POP_STACK_FRAME -> 4+      CSET {} -> 2+      LD _ _ (OpImm (ImmIndex _ _)) -> 3+      LD _ _ (OpImm (ImmCLbl _)) -> 2+      SCVTF {} -> 2+      FCVTZS {} -> 4+      BCOND {} -> long_bc_jump_dist+      CALL (TReg _) _ -> 1+      CALL {} -> 2+      CALL36 {} -> 2+      TAIL36 {} -> 2+      _ -> 1
+ GHC/CmmToAsm/LA64/Cond.hs view
@@ -0,0 +1,33 @@+module GHC.CmmToAsm.LA64.Cond where++import GHC.Prelude hiding (EQ)++-- | Condition codes.+-- Used in conditional branches and bit setters. According to the available+-- instruction set, some conditions are encoded as their negated opposites. I.e.+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.+-- TODO: Maybe need to simplify or expand?+data Cond+-- ISA condition+  = EQ  -- beq+  | NE  -- bne+  | LT  -- blt+  | GE  -- bge+  | LTU  -- bltu+  | GEU  -- bgeu+  | EQZ  -- beqz+  | NEZ  -- bnez+-- Extra Logical condition+  | SLT -- LT+  | SLE+  | SGE -- GE+  | SGT+  | ULT -- LTU+  | ULE+  | UGE -- GEU+  | UGT+  | FLT+  | FLE+  | FGE+  | FGT+  deriving (Eq, Show)
+ GHC/CmmToAsm/LA64/Instr.hs view
@@ -0,0 +1,1012 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.LA64.Instr where++import GHC.Prelude++import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.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.Platform.Reg.Class.Separate+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Platform+import GHC.Types.Unique.DSM++import GHC.Utils.Panic+import Data.Maybe+import GHC.Stack+import GHC.Data.FastString (LexicalFastString)++-- | Stack frame header size+-- Each stack frame contains ra and fp -- prologue.+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * spillSlotSize++-- | 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+    = (+        (ncgSpillPreallocSize config - stackFrameHeaderSize)+         `div`+         spillSlotSize+      ) - 1++-- | Convert a spill slot number to a *byte* offset.+spillSlotToOffset :: Int -> Int+spillSlotToOffset slot+   = stackFrameHeaderSize + spillSlotSize * slot++instance Outputable RegUsage where+    ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++-- | 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>]+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  -- Pseudo Instructions+  ANN _ i                  -> regUsageOfInstr platform i+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])+  LOCATION{}               -> usage ([], [])++  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ALSL dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  ALSLU dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  LU12I dst src1           -> usage (regOp src1, regOp dst)+  LU32I dst src1           -> usage (regOp src1, regOp dst)+  LU52I dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLT dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLTU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  PCADDI dst src1          -> usage (regOp src1, regOp dst)+  PCADDU12I dst src1       -> usage (regOp src1, regOp dst)+  PCADDU18I dst src1       -> usage (regOp src1, regOp dst)+  PCALAU12I dst src1       -> usage (regOp src1, regOp dst)+  AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  NOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ANDN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  ORN dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULW dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULWU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULH dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULHU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MODU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 2. Bit-shift Instructions ------------------------------------------+  SLL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ROTR dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 3. Bit Manipulation Instructions ------------------------------------------+  EXT dst src1             -> usage (regOp src1, regOp dst)+  CLO dst src1             -> usage (regOp src1, regOp dst)+  CLZ dst src1             -> usage (regOp src1, regOp dst)+  CTO dst src1             -> usage (regOp src1, regOp dst)+  CTZ dst src1             -> usage (regOp src1, regOp dst)+  BYTEPICK dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  REVB2H dst src1          -> usage (regOp src1, regOp dst)+  REVB4H dst src1          -> usage (regOp src1, regOp dst)+  REVB2W dst src1          -> usage (regOp src1, regOp dst)+  REVBD  dst src1          -> usage (regOp src1, regOp dst)+  REVH2W dst src1          -> usage (regOp src1, regOp dst)+  REVHD  dst src1          -> usage (regOp src1, regOp dst)+  BITREV4B dst src1        -> usage (regOp src1, regOp dst)+  BITREV8B dst src1        -> usage (regOp src1, regOp dst)+  BITREVW dst src1         -> usage (regOp src1, regOp dst)+  BITREVD dst src1         -> usage (regOp src1, regOp dst)+  BSTRINS _ dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  BSTRPICK _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  MASKEQZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  MASKNEZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  --+  -- Pseudo instructions+  NOP                      -> usage ([], [])+  MOV dst src              -> usage (regOp src, regOp dst)+  NEG dst src              -> usage (regOp src, regOp dst)+  CSET _cond dst src1 src2  -> usage (regOp src1 ++ regOp src2 , regOp dst)+  -- 4. Branch Instructions ----------------------------------------------------+  J t                      -> usage (regTarget t, [])+  J_TBL _ _ t              -> usage ([t], [])+  B t                      -> usage (regTarget t, [])+  BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL t ps                -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL36 t                 -> usage (regTarget t, [])+  TAIL36 r t               -> usage (regTarget t, regOp r)+  -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want+  -- to distinguish between two kinds of conditional jumps with different jump+  -- ranges, corresponding to 2 and 1 instruction implementations respectively.+  --+  -- BCOND1 is selected by default.+  BCOND1 _ j d t           -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BCOND _ j d t            -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BEQZ j t                 -> usage (regTarget t ++ regOp j, [])+  BNEZ j t                 -> usage (regTarget t ++ regOp j, [])+  -- 5. Common Memory Access Instructions --------------------------------------+  LD _ dst src             -> usage (regOp src, regOp dst)+  LDU _ dst src            -> usage (regOp src, regOp dst)+  ST _ dst src             -> usage (regOp src ++ regOp dst, [])+  LDX _ dst src            -> usage (regOp src, regOp dst)+  LDXU _ dst src           -> usage (regOp src, regOp dst)+  STX _ dst src            -> usage (regOp src ++ regOp dst, [])+  LDPTR _ dst src          -> usage (regOp src, regOp dst)+  STPTR _ dst src          -> usage (regOp src ++ regOp dst, [])+  PRELD _hint src          -> usage (regOp src, [])+  -- 6. Bound Check Memory Access Instructions ---------------------------------+  -- LDCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- STCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 7. Atomic Memory Access Instructions --------------------------------------+  -- 8. Barrier Instructions ---------------------------------------------------+  DBAR _hint               -> usage ([], [])+  IBAR _hint               -> usage ([], [])+  -- 11. Floating Point Instructions -------------------------------------------+  FMAX dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMIN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAXA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMINA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FNEG dst src1            -> usage (regOp src1, regOp dst)++  FCVT dst src             -> usage (regOp src, regOp dst)+  -- SCVTF dst src            -> usage (regOp src, regOp src ++ regOp dst)+  SCVTF dst src            -> usage (regOp src, regOp dst)+  FCVTZS dst src1 src2     -> usage (regOp src2, regOp src1 ++ regOp dst)+  FABS dst src             -> usage (regOp src, regOp dst)+  FSQRT dst src            -> usage (regOp src, regOp dst)+  FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)++  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr++  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 :: ([Reg], [Reg]) -> RegUsage+        usage (srcRegs, dstRegs) =+          RU+            (map mkFmt $ filter (interesting platform) srcRegs)+            (map mkFmt $ filter (interesting platform) dstRegs)++        mkFmt r = RegWithFormat r fmt+          where+            fmt = case cls of+              RcInteger -> II64+              RcFloat   -> FF64+              RcVector  -> sorry "The LoongArch64 NCG does not (yet) support vectors; please use -fllvm."+            cls = case r of+              RegVirtual vr -> classOfVirtualReg (platformArch platform) vr+              RegReal rr -> classOfRealReg rr++        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 (OpAddr a)    = regAddr a+        regOp (OpImm _)     = []++        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 platform (RegReal (RealRegSingle i))    = freeReg platform i++-- | Caller-saved registers (according to calling convention)+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |  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 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |zero| ra | tp | sp | a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | Rv | fp | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | s8 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- | 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 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+--f| a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | t9 | t10| t11| t12| t13| t14| t15| s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+callerSavedRegisters :: [Reg]+callerSavedRegisters =+    -- TODO: Not sure.+    [regSingle 1]                 -- ra+    ++ map regSingle [4 .. 11]    -- a0 - a7+    ++ map regSingle [12 .. 20]   -- t0 - t8+    ++ map regSingle [32 .. 39]   -- fa0 - fa7+    ++ map regSingle [40 .. 55]   -- ft0 - ft15++-- | 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)+    COMMENT{}           -> instr+    MULTILINE_COMMENT{} -> instr+    PUSH_STACK_FRAME    -> instr+    POP_STACK_FRAME     -> instr+    DELTA{}             -> instr+    LOCATION{}          -> instr+    -- 1. Arithmetic Instructions ------------------------------------------------+    ADD o1 o2 o3        -> ADD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SUB o1 o2 o3        -> SUB  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ALSL o1 o2 o3 o4    -> ALSL  (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    ALSLU o1 o2 o3 o4   -> ALSLU (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    LU12I o1 o2         -> LU12I  (patchOp o1)  (patchOp o2)+    LU32I o1 o2         -> LU32I  (patchOp o1)  (patchOp o2)+    LU52I o1 o2 o3      -> LU52I  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLT o1 o2 o3       -> SSLT  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLTU o1 o2 o3      -> SSLTU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    PCADDI o1 o2        -> PCADDI  (patchOp o1)  (patchOp o2)+    PCADDU12I o1 o2     -> PCADDU12I  (patchOp o1)  (patchOp o2)+    PCADDU18I o1 o2     -> PCADDU18I  (patchOp o1)  (patchOp o2)+    PCALAU12I o1 o2     -> PCALAU12I  (patchOp o1)  (patchOp o2)+    AND o1 o2 o3        -> AND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    OR o1 o2 o3         -> OR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    XOR o1 o2 o3        -> XOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    NOR o1 o2 o3        -> NOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ANDN o1 o2 o3       -> ANDN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ORN o1 o2 o3        -> ORN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MUL o1 o2 o3        -> MUL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULW o1 o2 o3       -> MULW  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULWU o1 o2 o3      -> MULWU (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULH o1 o2 o3       -> MULH  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULHU o1 o2 o3      -> MULHU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIV o1 o2 o3        -> DIV  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MOD o1 o2 o3        -> MOD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIVU o1 o2 o3       -> DIVU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MODU o1 o2 o3       -> MODU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 2. Bit-shift Instructions ------------------------------------------+    SLL o1 o2 o3        -> SLL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRL o1 o2 o3        -> SRL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRA o1 o2 o3        -> SRA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ROTR o1 o2 o3       -> ROTR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 3. Bit Manipulation Instructions ------------------------------------------+    EXT o1 o2             -> EXT  (patchOp o1)  (patchOp o2)+    CLO o1 o2             -> CLO  (patchOp o1)  (patchOp o2)+    CLZ o1 o2             -> CLZ  (patchOp o1)  (patchOp o2)+    CTO o1 o2             -> CTO  (patchOp o1)  (patchOp o2)+    CTZ o1 o2             -> CTZ  (patchOp o1)  (patchOp o2)+    BYTEPICK o1 o2 o3 o4  -> BYTEPICK  (patchOp o1)  (patchOp o2) (patchOp o3) (patchOp o4)+    REVB2H o1 o2          -> REVB2H  (patchOp o1)  (patchOp o2)+    REVB4H o1 o2          -> REVB4H  (patchOp o1)  (patchOp o2)+    REVB2W o1 o2          -> REVB2W  (patchOp o1)  (patchOp o2)+    REVBD  o1 o2          -> REVBD  (patchOp o1)  (patchOp o2)+    REVH2W o1 o2          -> REVH2W  (patchOp o1)  (patchOp o2)+    REVHD  o1 o2          -> REVHD  (patchOp o1)  (patchOp o2)+    BITREV4B o1 o2         -> BITREV4B  (patchOp o1)  (patchOp o2)+    BITREV8B o1 o2         -> BITREV8B  (patchOp o1)  (patchOp o2)+    BITREVW o1 o2          -> BITREVW  (patchOp o1)  (patchOp o2)+    BITREVD o1 o2          -> BITREVD  (patchOp o1)  (patchOp o2)+    BSTRINS f o1 o2 o3 o4  -> BSTRINS f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    BSTRPICK f o1 o2 o3 o4 -> BSTRPICK f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    MASKEQZ o1 o2 o3       -> MASKEQZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MASKNEZ o1 o2 o3       -> MASKNEZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    --+    -- Pseudo instrcutions+    NOP                 -> NOP+    MOV o1 o2           -> MOV  (patchOp o1)  (patchOp o2)+    NEG o1 o2           -> NEG  (patchOp o1)  (patchOp o2)+    CSET cond o1 o2 o3  -> CSET cond (patchOp o1) (patchOp o2) (patchOp o3)+    -- 4. Branch Instructions ----------------------------------------------------+    -- TODO:+    J t            -> J (patchTarget t)+    J_TBL ids mbLbl t  -> J_TBL ids mbLbl (env t)+    B t            -> B (patchTarget t)+    BL t ps        -> BL (patchTarget t) ps+    CALL t ps      -> CALL (patchTarget t) ps+    CALL36 t       -> CALL36 (patchTarget t)+    TAIL36 r t     -> TAIL36 (patchOp r) (patchTarget t)+    BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t)+    BCOND c j d t  -> BCOND c (patchOp j) (patchOp d) (patchTarget t)+    BEQZ j t       -> BEQZ (patchOp j) (patchTarget t)+    BNEZ j t       -> BNEZ (patchOp j) (patchTarget t)+    -- 5. Common Memory Access Instructions --------------------------------------+    -- TODO:+    LD f o1 o2         -> LD f (patchOp o1)  (patchOp o2)+    LDU f o1 o2        -> LDU f (patchOp o1)  (patchOp o2)+    ST f o1 o2         -> ST f (patchOp o1)  (patchOp o2)+    LDX f o1 o2        -> LDX f (patchOp o1)  (patchOp o2)+    LDXU f o1 o2       -> LDXU f (patchOp o1)  (patchOp o2)+    STX f o1 o2        -> STX f (patchOp o1)  (patchOp o2)+    LDPTR f o1 o2      -> LDPTR f (patchOp o1)  (patchOp o2)+    STPTR f o1 o2      -> STPTR f (patchOp o1)  (patchOp o2)+    PRELD o1 o2         -> PRELD (patchOp o1) (patchOp o2)+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LDCOND o1 o2 o3       -> LDCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- STCOND o1 o2 o3       -> STCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    -- TODO: need fix+    DBAR o1             -> DBAR o1+    IBAR o1             -> IBAR o1+    -- 11. Floating Point Instructions -------------------------------------------+    FCVT o1 o2          -> FCVT  (patchOp o1)  (patchOp o2)+    SCVTF o1 o2         -> SCVTF  (patchOp o1)  (patchOp o2)+    FCVTZS o1 o2 o3     -> FCVTZS  (patchOp o1)  (patchOp o2) (patchOp o3)+    FMIN o1 o2 o3       -> FMIN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAX o1 o2 o3       -> FMAX  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMINA o1 o2 o3      -> FMINA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAXA o1 o2 o3      -> FMAXA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FNEG o1 o2          -> FNEG  (patchOp o1)  (patchOp o2)+    FABS o1 o2          -> FABS  (patchOp o1)  (patchOp o2)+    FSQRT o1 o2         -> FSQRT  (patchOp o1)  (patchOp o2)+    FMA s o1 o2 o3 o4   -> FMA s (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)++    _                   -> panic $ "patchRegsOfInstr: " ++ instrCon instr+    where+        -- TODO:+        patchOp :: Operand -> Operand+        patchOp (OpReg w r) = OpReg w (env r)+        patchOp (OpAddr a) = OpAddr (patchAddr a)+        patchOp opImm = opImm++        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 imm) = AddrRegImm (env r1) imm+        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+  J {} -> True+  J_TBL {} -> True+  B {} -> True+  BL {} -> True+  CALL {} -> True+  CALL36 {} -> True+  TAIL36 {} -> True+  BCOND1 {} -> True+  BCOND {} -> True+  BEQZ {} -> True+  BNEZ {} -> True+  _ -> False++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this (potential) 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)+    J (TBlock bid) -> J (TBlock (patchF bid))+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    B (TBlock bid) -> B (TBlock (patchF bid))+    BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps+    CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps+    CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid))+    TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid))+    BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid))+    BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- | Make a spill instruction, spill a register into spill slot.+mkSpillInstr+   :: HasCallStack+   => NCGConfig+   -> RegWithFormat -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkStrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkStrSpImm imm = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Spill: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Spill: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset slot++-- | Make a reload instruction, reload from spill slot to a register.+mkLoadInstr+   :: NCGConfig+   -> RegWithFormat+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkLdrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkLdrSpImm imm = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Reload: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Reload: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset 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+    NEWBLOCK {} -> True+    DELTA {} -> True+    LDATA {} -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    J (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    B (TBlock target) -> bid == target+    TAIL36 _ (TBlock target) -> bid == target+    BCOND1 _ _ _ (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Copy the value in a register to another one.+-- Must work for all register classes.+mkRegRegMoveInstr :: Reg -> Reg -> Instr+mkRegRegMoveInstr src dst = ANN desc instr+  where+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst+    instr = MOV (OpReg W64 dst) (OpReg W64 src)++-- | Take the source and destination from this (potential) reg -> reg move instruction+-- We have to be a bit careful here: A `MOV` can also mean an implicit+-- conversion. This case is filtered out.+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr id = [TAIL36 (OpReg W64 tmpReg) (TBlock (id))]++-- | Decrement @sp@ to allocate stack space.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Alloc stack") $ SUB sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Alloc more stack") (MOV tmp (OpImm (ImmInt n))),+         SUB sp sp tmp+     ]+mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n)++-- | Increment SP to deallocate stack space.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform  n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Dealloc stack") $ ADD sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Dealloc more stack") (MOV tmp (OpImm (ImmInt n))),+         ADD sp sp tmp+     ]+mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)++allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr, [(BlockId,BlockId)])++allocMoreStack _ _ top@(CmmData _ _) = return (top, [])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+  let entries = entryBlocks proc++  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++  let+    delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+      where x = slots * spillSlotSize -- sp delta++    alloc   = mkStackAllocInstr   platform delta+    dealloc = mkStackDeallocInstr platform delta++    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 _ e -> insert_dealloc e 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+  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.++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 LexicalFastString++    -- 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.+    -- This carries a BlockId so it can be used in unwinding information.+    | DELTA   Int++    -- | Static data spat out during code generation.+    | LDATA Section RawCmmStatics++    | PUSH_STACK_FRAME+    | POP_STACK_FRAME+    -- Basic Integer Instructions ------------------------------------------------+    -- 1. Arithmetic Instructions ------------------------------------------------+    | ADD Operand Operand Operand+    | SUB Operand Operand Operand+    | ALSL Operand Operand Operand Operand+    | ALSLU Operand Operand Operand Operand+    | LU12I Operand Operand+    | LU32I Operand Operand+    | LU52I Operand Operand Operand+    | SSLT Operand Operand Operand+    | SSLTU Operand Operand Operand+    | PCADDI Operand Operand+    | PCADDU12I Operand Operand+    | PCADDU18I Operand Operand+    | PCALAU12I Operand Operand+    | AND Operand Operand Operand+    | OR Operand Operand Operand+    | XOR Operand Operand Operand+    | NOR Operand Operand Operand+    | ANDN Operand Operand Operand+    | ORN Operand Operand Operand+    | MUL Operand Operand Operand+    | MULW Operand Operand Operand+    | MULWU Operand Operand Operand+    | MULH Operand Operand Operand+    | MULHU Operand Operand Operand+    | DIV Operand Operand Operand+    | DIVU Operand Operand Operand+    | MOD Operand Operand Operand+    | MODU Operand Operand Operand+    -- 2. Bit-shift Instuctions --------------------------------------------------+    | SLL Operand Operand Operand+    | SRL Operand Operand Operand+    | SRA Operand Operand Operand+    | ROTR Operand Operand Operand+    -- 3. Bit-manupulation Instructions ------------------------------------------+    | EXT Operand Operand+    | CLO Operand Operand+    | CTO Operand Operand+    | CLZ Operand Operand+    | CTZ Operand Operand+    | BYTEPICK Operand Operand Operand Operand+    | REVB2H Operand Operand+    | REVB4H Operand Operand+    | REVB2W Operand Operand+    | REVBD Operand Operand+    | REVH2W Operand Operand+    | REVHD Operand Operand+    | BITREV4B Operand Operand+    | BITREV8B Operand Operand+    | BITREVW Operand Operand+    | BITREVD Operand Operand+    | BSTRINS Format Operand Operand Operand Operand+    | BSTRPICK Format Operand Operand Operand Operand+    | MASKEQZ Operand Operand Operand+    | MASKNEZ Operand Operand Operand+    -- Pseudo instructions+    | NOP+    | MOV Operand Operand+    | NEG Operand Operand+    | CSET Cond Operand Operand Operand+    -- 4. Branch Instructions ----------------------------------------------------+    | J Target+    | J_TBL [Maybe BlockId] (Maybe CLabel) Reg+    | B Target+    | BL Target [Reg]+    | CALL Target [Reg]+    | CALL36 Target+    | TAIL36 Operand Target+    | BCOND1 Cond Operand Operand Target+    | BCOND Cond Operand Operand Target+    | BEQZ Operand Target+    | BNEZ Operand Target+    -- 5. Common Memory Access Instructions --------------------------------------+    | LD Format Operand Operand+    | LDU Format Operand Operand+    | ST Format Operand Operand+    | LDX Format Operand Operand+    | LDXU Format Operand Operand+    | STX Format Operand Operand+    | LDPTR Format Operand Operand+    | STPTR Format Operand Operand+    | PRELD Operand Operand+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    | DBAR BarrierType+    | IBAR BarrierType+    -- Basic Floating Point Instructions -----------------------------------------+    | FCVT    Operand Operand+    | SCVTF   Operand Operand+    | FCVTZS  Operand Operand Operand+    | FMAX Operand Operand Operand+    | FMIN Operand Operand Operand+    | FMAXA Operand Operand Operand+    | FMINA Operand Operand Operand+    | FNEG Operand Operand+    | FABS Operand Operand+    | FSQRT Operand Operand+    -- Floating-point fused multiply-add instructions+    --  fmadd : d =   r1 * r2 + r3+    --  fnmsub: d =   r1 * r2 - r3+    --  fmsub : d = - r1 * r2 + r3+    --  fnmadd: d = - r1 * r2 - r3+    | FMA FMASign Operand Operand Operand Operand++-- TODO: Not complete.+data BarrierType = Hint0++instrCon :: Instr -> String+instrCon i =+    case i of+      COMMENT{} -> "COMMENT"+      MULTILINE_COMMENT{} -> "COMMENT"+      ANN{} -> "ANN"+      LOCATION{} -> "LOCATION"+      NEWBLOCK{} -> "NEWBLOCK"+      DELTA{} -> "DELTA"+      LDATA {} -> "LDATA"+      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+      POP_STACK_FRAME{} -> "POP_STACK_FRAME"++      ADD{} -> "ADD"+      SUB{} -> "SUB"+      ALSL{} -> "ALSL"+      ALSLU{} -> "ALSLU"+      LU12I{} -> "LU12I"+      LU32I{} -> "LU32I"+      LU52I{} -> "LU52I"+      SSLT{} -> "SSLT"+      SSLTU{} -> "SSLTU"+      PCADDI{} -> "PCADDI"+      PCADDU12I{} -> "PCADDU12I"+      PCADDU18I{} -> "PCADDU18I"+      PCALAU12I{} -> "PCALAU12I"+      AND{} -> "AND"+      OR{} -> "OR"+      XOR{} -> "XOR"+      NOR{} -> "NOR"+      ANDN{} -> "ANDN"+      ORN{} -> "ORN"+      MUL{} -> "MUL"+      MULW{} -> "MULW"+      MULWU{} -> "MULWU"+      MULH{} -> "MULH"+      MULHU{} -> "MULHU"+      DIV{} -> "DIV"+      MOD{} -> "MOD"+      DIVU{} -> "DIVU"+      MODU{} -> "MODU"+      SLL{} -> "SLL"+      SRL{} -> "SRL"+      SRA{} -> "SRA"+      ROTR{} -> "ROTR"+      EXT{} -> "EXT"+      CLO{} -> "CLO"+      CLZ{} -> "CLZ"+      CTO{} -> "CTO"+      CTZ{} -> "CTZ"+      BYTEPICK{} -> "BYTEPICK"+      REVB2H{} -> "REVB2H"+      REVB4H{} -> "REVB4H"+      REVB2W{} -> "REVB2W"+      REVBD{} -> "REVBD"+      REVH2W{} -> "REVH2W"+      REVHD{} -> "REVHD"+      BITREV4B{} -> "BITREV4B"+      BITREV8B{} -> "BITREV8B"+      BITREVW{} -> "BITREVW"+      BITREVD{} -> "BITREVD"+      BSTRINS{} -> "BSTRINS"+      BSTRPICK{} -> "BSTRPICK"+      MASKEQZ{} -> "MASKEQZ"+      MASKNEZ{} -> "MASKNEZ"+      NOP{} -> "NOP"+      MOV{} -> "MOV"+      NEG{} -> "NEG"+      CSET{} -> "CSET"+      J{} -> "J"+      J_TBL{} -> "J_TBL"+      B{} -> "B"+      BL{} -> "BL"+      CALL{} -> "CALL"+      CALL36{} -> "CALL36"+      TAIL36{} -> "TAIL36"+      BCOND1{} -> "BCOND1"+      BCOND{} -> "BCOND"+      BEQZ{} -> "BEQZ"+      BNEZ{} -> "BNEZ"+      LD{} -> "LD"+      LDU{} -> "LDU"+      ST{} -> "ST"+      LDX{} -> "LDX"+      LDXU{} -> "LDXU"+      STX{} -> "STX"+      LDPTR{} -> "LDPTR"+      STPTR{} -> "STPTR"+      PRELD{} -> "PRELD"+      DBAR{} -> "DBAR"+      IBAR{} -> "IBAR"+      FCVT{} -> "FCVT"+      SCVTF{} -> "SCVTF"+      FCVTZS{} -> "FCVTZS"+      FMAX{} -> "FMAX"+      FMIN{} -> "FMIN"+      FMAXA{} -> "FMAXA"+      FMINA{} -> "FMINA"+      FNEG{} -> "FNEG"+      FABS{} -> "FABS"+      FSQRT{} -> "FSQRT"+      FMA variant _ _ _ _ ->+        case variant of+          FMAdd  -> "FMADD"+          FMSub  -> "FMSUB"+          FNMAdd -> "FNMADD"+          FNMSub -> "FNMSUB"++data Target+    = TBlock BlockId+    | TLabel CLabel+    | TReg   Reg++data Operand+  = OpReg Width Reg -- register+  | OpImm Imm       -- immediate+  | OpAddr AddrMode -- address+  deriving (Eq, Show)++opReg :: Reg -> Operand+opReg = OpReg W64++opRegNo :: RegNo -> Operand+opRegNo = opReg . regSingle++-- LoongArch64 has no ip register in ABI. Here ip register is for spilling/+-- reloading register to/from slots. So make t8(r20) non-free for ip.+zero, ra, tp, sp, fp, tmp :: Operand+zero = opReg zeroReg+ra   = opReg raReg+sp   = opReg spMachReg+tp   = opReg tpMachReg+fp   = opReg fpMachReg+tmp  = opReg tmpReg++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  = opRegNo  0+x1  = opRegNo  1+x2  = opRegNo  2+x3  = opRegNo  3+x4  = opRegNo  4+x5  = opRegNo  5+x6  = opRegNo  6+x7  = opRegNo  7+x8  = opRegNo  8+x9  = opRegNo  9+x10 = opRegNo 10+x11 = opRegNo 11+x12 = opRegNo 12+x13 = opRegNo 13+x14 = opRegNo 14+x15 = opRegNo 15+x16 = opRegNo 16+x17 = opRegNo 17+x18 = opRegNo 18+x19 = opRegNo 19+x20 = opRegNo 20+x21 = opRegNo 21+x22 = opRegNo 22+x23 = opRegNo 23+x24 = opRegNo 24+x25 = opRegNo 25+x26 = opRegNo 26+x27 = opRegNo 27+x28 = opRegNo 18+x29 = opRegNo 29+x30 = opRegNo 30+x31 = opRegNo 31++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  = opRegNo 32+d1  = opRegNo 33+d2  = opRegNo 34+d3  = opRegNo 35+d4  = opRegNo 36+d5  = opRegNo 37+d6  = opRegNo 38+d7  = opRegNo 39+d8  = opRegNo 40+d9  = opRegNo 41+d10 = opRegNo 42+d11 = opRegNo 43+d12 = opRegNo 44+d13 = opRegNo 45+d14 = opRegNo 46+d15 = opRegNo 47+d16 = opRegNo 48+d17 = opRegNo 49+d18 = opRegNo 50+d19 = opRegNo 51+d20 = opRegNo 52+d21 = opRegNo 53+d22 = opRegNo 54+d23 = opRegNo 55+d24 = opRegNo 56+d25 = opRegNo 57+d26 = opRegNo 58+d27 = opRegNo 59+d28 = opRegNo 60+d29 = opRegNo 61+d30 = opRegNo 62+d31 = opRegNo 63++fitsInNbits :: Int -> Int -> Bool+fitsInNbits n i = (-1 `shiftL` (n - 1)) <= i && i <= (1 `shiftL` (n - 1) - 1)++isUnsignOp :: Int -> Bool+isUnsignOp i = (i >= 0)++isNbitEncodeable :: Int -> Integer -> Bool+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++isEncodeableInWidth :: Width -> Integer -> Bool+isEncodeableInWidth = isNbitEncodeable . widthInBits++isIntOp :: Operand -> Bool+isIntOp = not . isFloatOp++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ reg) | isFloatReg reg = True+isFloatOp _ = False++isFloatReg :: Reg -> Bool+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True+isFloatReg (RegVirtual (VirtualRegD _)) = True+isFloatReg _ = False++widthToInt :: Width -> Int+widthToInt W8   = 8+widthToInt W16  = 16+widthToInt W32  = 32+widthToInt W64  = 64+widthToInt _ = 64++widthFromOpReg :: Operand -> Width+widthFromOpReg (OpReg W8 _)  = W8+widthFromOpReg (OpReg W16 _) = W16+widthFromOpReg (OpReg W32 _) = W32+widthFromOpReg (OpReg W64 _) = W64+widthFromOpReg _ = W64++ldFormat :: Format -> Format+ldFormat f+  | f `elem` [II8, II16, II32, II64] = II64+  | f `elem` [FF32, FF64] = FF64+  | otherwise = pprPanic "unsupported ldFormat: " (text $ show f)
+ GHC/CmmToAsm/LA64/Ppr.hs view
@@ -0,0 +1,1149 @@+module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Prelude hiding (EQ)++import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.Platform+import GHC.Platform.Reg+import GHC.Types.Unique ( pprUniqueAlways, getUnique )+import GHC.Utils.Outputable+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Utils.Panic++pprNatCmmDecl :: forall doc. (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++      pprProcAlignment :: doc+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)+   in pprProcAlignment+        $$ case topInfoTable proc of+          Nothing ->+            -- special case for code without info table:+            pprSectionAlign config (Section Text lbl)+              $$+              -- do not+              -- pprProcAlignment config $$+              pprLabel platform lbl+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed+              $$ 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 $$+              ( if platformHasSubsectionsViaSymbols platform+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')+                  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 RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure+                -> 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++pprLabel :: IsDoc doc => Platform -> CLabel -> doc+pprLabel platform lbl =+   pprGloblDecl platform lbl+   $$ pprTypeDecl platform lbl+   $$ line (pprAsmLabel platform lbl <> char ':')++pprAlign :: (IsDoc doc) => Alignment -> doc+pprAlign alignment =+  -- .balign is stable, whereas .align is platform dependent.+  line $ text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+--+-- Currently, this always aligns to a full machine word (8 byte.) A future+-- improvement could be to really do this per section type (though, it's+-- probably not a big gain.)+pprAlignForSection :: (IsDoc doc) => SectionType -> doc+pprAlignForSection _seg = pprAlign . mkAlignment $ 8++-- Print section header and appropriate alignment for that section.+-- This will e.g. emit a header like:+--+--     .section .text+--     .balign 8+--+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc+pprSectionAlign _config (Section (OtherSection _) _) =+  panic "LA64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+    line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++-- | Output the ELF .size directive+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl+pprSizeDecl _ _ = 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)) $$+    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+    -- 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 $$+           ppWhen (ncgDwarfEnabled config)+              (line (pprBlockEndLabel platform info_lbl))+    -- 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)++-- 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"  <> pprDataImm platform imm]+        ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]+        ppr_item II32 _ = [text "\t.long\t"  <> pprDataImm platform imm]+        ppr_item II64 _ = [text "\t.quad\t"  <> pprDataImm 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)++-- | Pretty print an immediate value in the @data@ section+-- This does not include any checks. We rely on the Assembler to check for+-- errors. Use `pprOpImm` for immediates in instructions (operands.)+pprDataImm :: IsLine doc => Platform -> Imm -> doc+pprDataImm _ (ImmInt i)     = int i+pprDataImm _ (ImmInteger i) = integer i+pprDataImm p (ImmCLbl l)    = pprAsmLabel p l+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i+pprDataImm _ (ImmLit s)     = ftext s+pprDataImm _ (ImmFloat f) = float (fromRational f)+pprDataImm _ (ImmDouble d) = double (fromRational d)++pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b+pprDataImm p (ImmConstantDiff a b) = pprDataImm p a <> char '-'+                   <> lparen <> pprDataImm p b <> rparen++asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c =  text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform imm = case imm of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  ImmFloat f -> float (fromRational f)+  ImmDouble d -> double (fromRational d)+  _ -> pprPanic "LA64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands:" <+> (text . show) imm)++negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "LA64.negOp" (text $ show op)++pprOp :: IsLine doc => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r                 -> pprReg w r+  OpImm imm                 -> pprOpImm plat imm+  OpAddr (AddrRegReg r1 r2) -> pprReg W64 r1 <> comma <+> pprReg W64 r2+  OpAddr (AddrRegImm r imm) -> pprReg W64 r <> comma <+> pprOpImm plat imm+  OpAddr (AddrReg r)        -> pprReg W64 r <+> text ", 0"++pprReg :: forall doc. IsLine doc => Width -> Reg -> doc+pprReg w r = case r of+  RegReal    (RealRegSingle i) -> ppr_reg_no 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 "LA64.pprReg" (text (show r) <+> ppr w)++  where+    ppr_reg_no :: Int -> doc+    -- LoongArch's registers must be started from `$[fr]`+    -- General Purpose Registers+    ppr_reg_no 0  = text "$zero"+    ppr_reg_no 1  = text "$ra"+    ppr_reg_no 2  = text "$tp"+    ppr_reg_no 3  = text "$sp"+    ppr_reg_no 4  = text "$a0"+    ppr_reg_no 5  = text "$a1"+    ppr_reg_no 6  = text "$a2"+    ppr_reg_no 7  = text "$a3"+    ppr_reg_no 8  = text "$a4"+    ppr_reg_no 9  = text "$a5"+    ppr_reg_no 10 = text "$a6"+    ppr_reg_no 11 = text "$a7"+    ppr_reg_no 12 = text "$t0"+    ppr_reg_no 13 = text "$t1"+    ppr_reg_no 14 = text "$t2"+    ppr_reg_no 15 = text "$t3"+    ppr_reg_no 16 = text "$t4"+    ppr_reg_no 17 = text "$t5"+    ppr_reg_no 18 = text "$t6"+    ppr_reg_no 19 = text "$t7"+    ppr_reg_no 20 = text "$t8"+    ppr_reg_no 21 = text "$u0"  -- Reserverd+    ppr_reg_no 22 = text "$fp"+    ppr_reg_no 23 = text "$s0"+    ppr_reg_no 24 = text "$s1"+    ppr_reg_no 25 = text "$s2"+    ppr_reg_no 26 = text "$s3"+    ppr_reg_no 27 = text "$s4"+    ppr_reg_no 28 = text "$s5"+    ppr_reg_no 29 = text "$s6"+    ppr_reg_no 30 = text "$s7"+    ppr_reg_no 31 = text "$s8"++    -- Floating Point Registers+    ppr_reg_no 32 = text "$fa0"+    ppr_reg_no 33 = text "$fa1"+    ppr_reg_no 34 = text "$fa2"+    ppr_reg_no 35 = text "$fa3"+    ppr_reg_no 36 = text "$fa4"+    ppr_reg_no 37 = text "$fa5"+    ppr_reg_no 38 = text "$fa6"+    ppr_reg_no 39 = text "$fa7"+    ppr_reg_no 40 = text "$ft0"+    ppr_reg_no 41 = text "$ft1"+    ppr_reg_no 42 = text "$ft2"+    ppr_reg_no 43 = text "$ft3"+    ppr_reg_no 44 = text "$ft4"+    ppr_reg_no 45 = text "$ft5"+    ppr_reg_no 46 = text "$ft6"+    ppr_reg_no 47 = text "$ft7"+    ppr_reg_no 48 = text "$ft8"+    ppr_reg_no 49 = text "$ft9"+    ppr_reg_no 50 = text "$ft10"+    ppr_reg_no 51 = text "$ft11"+    ppr_reg_no 52 = text "$ft12"+    ppr_reg_no 53 = text "$ft13"+    ppr_reg_no 54 = text "$ft14"+    ppr_reg_no 55 = text "$ft15"+    ppr_reg_no 56 = text "$fs0"+    ppr_reg_no 57 = text "$fs1"+    ppr_reg_no 58 = text "$fs2"+    ppr_reg_no 59 = text "$fs3"+    ppr_reg_no 60 = text "$fs4"+    ppr_reg_no 61 = text "$fs5"+    ppr_reg_no 62 = text "$fs6"+    ppr_reg_no 63 = text "$fs7"++    ppr_reg_no i+         | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)+         | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)+         -- no support for widths > W64.+         | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)++-- | Single precission `Operand` (floating-point)+isSingleOp :: Operand -> Bool+isSingleOp (OpReg W32 _) = True+isSingleOp _ = False++-- | Double precission `Operand` (floating-point)+isDoubleOp :: Operand -> Bool+isDoubleOp (OpReg W64 _) = True+isDoubleOp _ = False++-- | `Operand` is an immediate value+isImmOp :: Operand -> Bool+isImmOp (OpImm _) = True+isImmOp _ = False++-- | `Operand` is an immediate @0@ value+isImmZero :: Operand -> Bool+isImmZero (OpImm (ImmFloat 0)) = True+isImmZero (OpImm (ImmDouble 0)) = True+isImmZero (OpImm (ImmInt 0)) = True+isImmZero _ = 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+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _ -> panic "PprInstr: NEWBLOCK"++  -- Pseudo Instructions -------------------------------------------------------++  PUSH_STACK_FRAME -> lines_ [ text "\taddi.d $sp, $sp, -16"+                             , text "\tst.d   $ra, $sp, 8"+                             , text "\tst.d   $fp, $sp, 0"+                             , text "\taddi.d $fp, $sp, 16"+                             ]++  POP_STACK_FRAME -> lines_  [ text "\tld.d   $fp, $sp, 0"+                             , text "\tld.d   $ra, $sp, 8"+                             , text "\taddi.d $sp, $sp, 16"+                             ]+++  -- ===========================================================================+  -- LoongArch64 Instruction Set+  -- Basic Integer Instructions ------------------------------------------------+  -- 1. Arithmetic Instructions ------------------------------------------------+    -- ADD.{W/D}, SUB.{W/D}+    -- ADDI.{W/D}, ADDU16I.D+  ADD  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- TODO: Not complete.+    -- Here we should add addu16i.d for optimizations of accelerating GOT accession+    -- with ldptr.w/d, stptr.w/d+  SUB  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3)+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3)+    | otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- ALSL.{W[U]/D}+  ALSL  o1 o2 o3 o4+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ALSLU  o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4+    -- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them.+    -- li.w rd, s32+    -- li.w rd, u32+    -- li.d rd, s64+    -- li.d rd, u64+    --+    -- # Load with one instruction+    -- ori dst, $zero, imm[11:0]+    --+    -- # Load with two instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    --+    -- # Load with four instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    -- lu32i.d dst, imm[51:32]+    -- lu52i.d dst, dst, imm[63:52]++  --  -- LU12I.W, LU32I.D, LU52I.D+  LU12I  o1 o2 -> op2 (text "\tlu12i.w") o1 o2+  LU32I  o1 o2 -> op2 (text "\tlu32i.d") o1 o2+  LU52I  o1 o2 o3 -> op3 (text "\tlu52i.d") o1 o2 o3+    -- SSLT[U]+    -- SSLT[U]I+  SSLT  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3  -> op3 (text "\tslt") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SSLTU  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- PCADDI, PCADDU121, PCADDU18l, PCALAU12I+  PCADDI  o1 o2     -> op2 (text "\tpcaddi") o1 o2+  PCADDU12I  o1 o2  -> op2 (text "\tpcaddu12i") o1 o2+  PCADDU18I  o1 (OpImm (ImmCLbl lbl))  ->+    lines_ [+      text "\tpcaddu18i" <+> pprOp platform o1 <> comma <+> text "%call36(" <+> pprAsmLabel platform lbl <+> text ")"+           ]+  PCALAU12I  o1 o2  -> op2 (text "\tpcalau12i") o1 o2+    -- AND, OR, NOR, XOR, ANDN, ORN+    -- ANDI, ORI, XORI: zero-extention+  AND  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  OR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  XOR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  NOR  o1 o2 o3   -> op3 (text "\tnor") o1 o2 o3+  ANDN  o1 o2 o3  -> op3 (text "\tandn") o1 o2 o3+  ORN  o1 o2 o3   -> op3 (text "\torn") o1 o2 o3++  -----------------------------------------------------------------------------+  -- Pseudo instructions+  -- NOP, alias for "andi r0, r0, r0"+  NOP -> line $ text "\tnop"+  -- NEG o1 o2, alias for "sub o1, r0, o2"+  NEG o1 o2+    | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+    | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+    | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2+    | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2+    | otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+  -- Here we can do more simplitcations.+  -- To be honest, floating point instructions are too scarce, so maybe+  -- we should reimplement some pseudo instructions with others.+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfmov.s") o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfmov.d") o1 o2+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2+    | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2+    | OpReg _ _ <- o2  ->+      lines_ [+        text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0"+             ]+    -- TODO: Maybe we can do more.+    -- Let the assembler do these concret things.+    | isImmOp o2 ->+      lines_ [text "\tli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> pprPanic "LA64.ppr: MOV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++  -- CSET pesudo instrcutions implementation+  CSET cond dst o1 o2 -> case cond of+    -- SEQ dst, rd, rs -> [SUB rd, rd, rs;  sltui dst, rd, 1]+    EQ | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltui" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.seq.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.seq.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    -- SNE rd, rs -> [SUB rd, rd, rs;   sltu rd, zero, rs]+    NE | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltu" <+> pprOp platform dst <> comma <+> text "$r0" <+> comma <+> pprOp platform dst+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.cune.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.cune.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    SLT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    -- SLE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SLE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SGE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGT rd, rs -> [SLT rd, rs]+    SGT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    ULT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    ULE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- UGE rd, rs -> [SLTU rd, rs;  xori rd, rs, 1]+    UGE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGTU rd, rs -> [SLTU rd, rs]+    UGT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    -- TODO:+    -- LoongArch's floating point instrcutions don't write the compared result to an interger register, instead of cc.+    -- Fcond dst o1 o2 -> [fcmp.cond.[s/d] fcc0 o1 o2;  movcf2gr dst, fcc0]+    FLT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    FLT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    _ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    where+      subFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2  =+                        text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2)+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 =+                        text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2+                    | otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tslti"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt"+                    | otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tsltui"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu"+                    | otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    -- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit.+    -- MULW.D.W[U]+  MUL  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULW   o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULWU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULH  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULHU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]}+  DIV  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  DIVU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MOD  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MODU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 2. Bit-shift Instuctions --------------------------------------------------+    -- SLL.W, SRL.W, SRA.W, ROTR.W+    -- SLL.D, SRL.D, SRA.D, ROTR.D+    -- SLLI.W, SRLI.W, SRAI.W, ROTRI.W+    -- SLLI.D, SRLI.D, SRAI.D, ROTRI.D+  SLL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRA  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ROTR  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 3. Bit-manupulation Instructions ------------------------------------------+    -- EXT.W{B/H}+  EXT o1 o2+    | OpReg W8 _ <- o2  -> op2 (text "\text.w.b") o1 o2+    | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2+    | otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+    -- CL{O/Z}.{W/D}, CT{O/Z}.{W/D}+  CLO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclo.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclo.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLO error" (pprOp platform o1 <+> pprOp platform o2)+  CLZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLZ error" (pprOp platform o1 <+> pprOp platform o2)+  CTO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tcto.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tcto.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTO error" (pprOp platform o1 <+> pprOp platform o2)+  CTZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tctz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tctz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2)+    -- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3+  BYTEPICK o1 o2 o3 o4+    | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4)+    -- REVB.{2H/4H/2W/D}+  REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2+  REVB4H o1 o2 -> op2 (text "\trevb.4h") o1 o2+  REVB2W o1 o2 -> op2 (text "\trevb.2w") o1 o2+  REVBD  o1 o2 -> op2 (text "\trevb.d") o1 o2+    -- REVH.{2W/D}+  REVH2W o1 o2 -> op2 (text "\trevh.2w") o1 o2+  REVHD o1 o2 -> op2 (text "\trevh.d") o1 o2+    -- BITREV.{4B/8B}+    -- BITREV.{W/D}+  BITREV4B o1 o2 -> op2 (text "\tbitrev.4b") o1 o2+  BITREV8B o1 o2 -> op2 (text "\tbitrev.8b") o1 o2+  BITREVW o1 o2 -> op2 (text "\tbitrev.w") o1 o2+  BITREVD o1 o2 -> op2 (text "\tbitrev.d") o1 o2+    -- BSTRINS.{W/D}+  BSTRINS II64 o1 o2 o3 o4 -> op4 (text "\tbstrins.d") o1 o2 o3 o4+  BSTRINS II32 o1 o2 o3 o4 -> op4 (text "\tbstrins.w") o1 o2 o3 o4+    -- BSTRPICK.{W/D}+  BSTRPICK II64 o1 o2 o3 o4 -> op4 (text "\tbstrpick.d") o1 o2 o3 o4+  BSTRPICK II32 o1 o2 o3 o4 -> op4 (text "\tbstrpick.w") o1 o2 o3 o4+    -- MASKEQZ rd, rj, rk:  if rk == 0 ? rd = 0 : rd = rj+  MASKEQZ o1 o2 o3 -> op3 (text "\tmaskeqz") o1 o2 o3+    -- MASKNEZ:  if rk == 0 ? rd = 0 : rd = rj+  MASKNEZ o1 o2 o3 -> op3 (text "\tmasknez") o1 o2 o3+  -- 4. Branch Instructions ----------------------------------------------------+    -- BEQ, BNE, BLT[U], BGE[U]   rj, rd, off16+    -- BEQZ, BNEZ   rj, off21+    -- B+    -- BL+    -- JIRL+    -- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return.+  J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0"+  J_TBL _ _ r    -> pprInstr platform (B (TReg r))++  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 "\tjr" <+> 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 "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!"+  TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl+  TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!"++  BCOND1 c j d (TBlock bid) -> case c of+    SLE ->+      line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    SGT ->+      line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    ULE ->+      line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    UGT ->+      line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))++  BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!"++  BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!"++  -- Reuse t8(IP) register+  BCOND c j d (TBlock bid) -> case c of+    SLE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    EQ ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    NE ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SLT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    _ -> panic "LA64.ppr: BCOND: Unsupported cond!"++  BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!"++  BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!"++  BEQZ j (TBlock bid) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BEQZ j (TLabel lbl) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BEQZ _ (TReg _)     -> panic "LA64.ppr: BEQZ: No conditional branching to registers!"++  BNEZ j (TBlock bid) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BNEZ j (TLabel lbl) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BNEZ _ (TReg _)     -> panic "LA64.ppr: BNEZ: No conditional branching to registers!"++  -- 5. Common Memory Access Instructions --------------------------------------+    -- LD.{B[U]/H[U]/W[U]/D}, ST.{B/H/W/D}: AddrRegImm+    -- LD: load, ST: store, x: offset in register, u: load unsigned imm.+    -- LD format dst src: 'src' means final address, not single register or immdiate.+  -- Load symbol's address+  LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]++  LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]++  LD II8  o1 o2 -> op2 (text "\tld.b") o1 o2+  LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2+  LD II32 o1 o2 -> op2 (text "\tld.w") o1 o2+  LD II64 o1 o2 -> op2 (text "\tld.d") o1 o2+  LD FF32 o1 o2 -> op2 (text "\tfld.s") o1 o2+  LD FF64 o1 o2 -> op2 (text "\tfld.d") o1 o2++  LDU II8  o1 o2 -> op2 (text "\tld.bu") o1 o2+  LDU II16 o1 o2 -> op2 (text "\tld.hu") o1 o2+  LDU II32 o1 o2 -> op2 (text "\tld.wu") o1 o2+  LDU II64 o1 o2 -> op2 (text "\tld.d") o1 o2   -- double words (64bit) cannot be sign extended by definition+  LDU FF32 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.s") o1 o2+  LDU FF32 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.s") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.d") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.d") o1 o2+  LDU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text.show) f <+> pprOp platform o1 <+> pprOp platform o2)++  ST II8  o1 o2 -> op2 (text "\tst.b") o1 o2+  ST II16 o1 o2 -> op2 (text "\tst.h") o1 o2+  ST II32 o1 o2 -> op2 (text "\tst.w") o1 o2+  ST II64 o1 o2 -> op2 (text "\tst.d") o1 o2+  ST FF32 o1 o2 -> op2 (text "\tfst.s") o1 o2+  ST FF64 o1 o2 -> op2 (text "\tfst.d") o1 o2++    -- LDPTR.{W/D}, STPTR.{W/D}: AddrRegImm: AddrRegImm+  LDPTR II32 o1 o2 -> op2 (text "\tldptr.w") o1 o2+  LDPTR II64 o1 o2 -> op2 (text "\tldptr.d") o1 o2+  STPTR II32 o1 o2 -> op2 (text "\tstptr.w") o1 o2+  STPTR II64 o1 o2 -> op2 (text "\tstptr.d") o1 o2++    -- LDX.{B[U]/H[U]/W[U]/D}, STX.{B/H/W/D}: AddrRegReg+  LDX II8   o1 o2 -> op2 (text "\tldx.b")  o1 o2+  LDX II16  o1 o2 -> op2 (text "\tldx.h")  o1 o2+  LDX II32  o1 o2 -> op2 (text "\tldx.w")  o1 o2+  LDX II64  o1 o2 -> op2 (text "\tldx.d")  o1 o2+  LDX FF32  o1 o2 -> op2 (text "\tfldx.s") o1 o2+  LDX FF64  o1 o2 -> op2 (text "\tfldx.d") o1 o2+  LDXU II8  o1 o2 -> op2 (text "\tldx.bu") o1 o2+  LDXU II16 o1 o2 -> op2 (text "\tldx.hu") o1 o2+  LDXU II32 o1 o2 -> op2 (text "\tldx.wu") o1 o2+  LDXU II64 o1 o2 -> op2 (text "\tldx.d")  o1 o2+  STX II8   o1 o2 -> op2 (text "\tstx.b")  o1 o2+  STX II16  o1 o2 -> op2 (text "\tstx.h")  o1 o2+  STX II32  o1 o2 -> op2 (text "\tstx.w")  o1 o2+  STX II64  o1 o2 -> op2 (text "\tstx.d")  o1 o2+  STX FF32  o1 o2 -> op2 (text "\tfstx.s") o1 o2+  STX FF64  o1 o2 -> op2 (text "\tfstx.d") o1 o2++  PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1+  -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}+  -- 7. Atomic Memory Access Instructions --------------------------------------+    -- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU}+    -- AM.{SWAP/ADD}[_DB].{B/H}+    -- AMCAS[_DB].{B/H/W/D}+    -- LL.{W/D}, SC.{W/D}+    -- SC.Q+    -- LL.ACQ.{W/D}, SC.REL.{W/D}+  -- 8. Barrier Instructions ---------------------------------------------------+    -- DBAR, IBAR+  DBAR h -> line $ text "\tdbar" <+> pprBarrierType h+  IBAR h -> line $ text "\tibar" <+> pprBarrierType h++    -- Floating-point convert precision+  FCVT o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT o1 o2 -> pprPanic "LA64.pprInstr - impossible float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)+    -- Signed fixed-point convert to floating-point+    -- For LoongArch, ffint.* instructions's second operand must be float-pointing register,+    -- so we need one more operation.+    -- Also to tfint.*.+  SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1 o2 -> pprPanic "LA64.pprInstr - impossible integer to float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)++    -- Floating-point convert to signed integer, rounding toward zero+    -- TODO: FCVTZS will destroy src-floating register if the previous opertion+    -- includes this reg. So I'm just stupidly saving and restoring by adding+    -- an extra register.+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.d" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1 o2 o3 -> pprPanic "LA64.pprInstr - impossible float to integer conversion" $+                   line (pprOp platform o3 <> text "->" <+> pprOp platform o1 <+> text "tmpReg:" <+> pprOp platform o2)++  FMIN o1 o2 o3  -> op3 (text "fmin." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMINA o1 o2 o3 -> op3 (text "fmina." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAX o1 o2 o3  -> op3 (text "fmax." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FMA variant d o1 o2 o3 ->+    let fma = case variant of+                FMAdd   -> text "\tfmadd." <+> floatPrecission d+                FMSub   -> text "\tfmsub." <+> floatPrecission d+                FNMAdd  -> text "\tfnmadd." <+> floatPrecission d+                FNMSub  -> text "\tfnmsub." <+> floatPrecission d+    in op4 fma d o1 o2 o3++  instr -> panic $ "LA64.pprInstr - Unknown instruction: " ++ (instrCon instr)+  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+{-+    -- TODO: Support dbar with different hints.+    On LoongArch uses "dbar 0" (full completion barrier) for everything.+    But the full completion barrier has no performance to tell, so+    Loongson-3A6000 and newer processors have made finer granularity hints+    available:++    Bit4: ordering or completion (0: completion, 1: ordering)+    Bit3: barrier for previous read (0: true, 1: false)+    Bit2: barrier for previous write (0: true, 1: false)+    Bit1: barrier for succeeding read (0: true, 1: false)+    Bit0: barrier for succeeding write (0: true, 1: false)+-}+        pprBarrierType Hint0 = text "0x0"+        floatPrecission o | isSingleOp o = text "s"+                          | isDoubleOp o = text "d"+                          | otherwise  = pprPanic "Impossible floating point precission: " (pprOp platform o)++-- LoongArch64 Conditional Branch Instructions+pprBcond :: IsLine doc => Cond -> doc+pprBcond c = text "b" <> pprCond c++pprCond :: IsLine doc => Cond -> doc+pprCond c = case c of+      EQ -> text "eq"     -- beq  rj, rd, off16+      NE -> text "ne"     -- bne  rj, rd, off16+      SLT -> text "lt"    -- blt  rj, rd, off16+      SGE -> text "ge"    -- bge  rj, rd, off16+      ULT -> text "ltu"   -- bltu rj, rd, off16+      UGE -> text "geu"   -- bgeu rj, rd, off16+      -- Following not real instructions, just mark it.+      SLE    -> text "sle->ge"   -- ble  rj, rd, off16 -> bge  rd, rj, off16+      SGT    -> text "sgt->lt"   -- bgt  rj, rd, off16 -> blt  rd, rj, off16+      ULE    -> text "ule->geu"  -- bleu rj, rd, off16 -> bgeu rd, rj, off16+      UGT    -> text "ugt->ltu"  -- bgtu rj, rd, off16 -> bltu rd, rj, off16+      _ -> panic $ "LA64.ppr: non-implemented branch condition: " ++ show c
+ GHC/CmmToAsm/LA64/RegInfo.hs view
@@ -0,0 +1,25 @@+-- Here maybe have something to be optimized in future?+module GHC.CmmToAsm.LA64.RegInfo where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.LA64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++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++shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ GHC/CmmToAsm/LA64/Regs.hs view
@@ -0,0 +1,155 @@+module GHC.CmmToAsm.LA64.Regs where++import GHC.Prelude+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.CmmToAsm.Format+import GHC.Data.FastString+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Platform.Regs+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Unique++-- All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = [0..31] ++ [32..63]++zeroReg, raReg, tpMachReg, fpMachReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle 0+raReg = regSingle 1+tpMachReg = regSingle 2+-- Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 3+fpMachReg = regSingle 22+-- Use t8(r20) for LA64 IP register.+tmpReg = regSingle 20++-- Registers available to the register allocator.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform =+  let isFree = freeReg platform+   in map RealRegSingle $ filter isFree allMachRegNos++-- Integer argument registers according to the calling convention+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [4..11]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [32..39]++-- 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)++-- Map CmmLit to Imm+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 l = panic $ "LA64.Regs.litToImm: no match for " ++ show l++-- == 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+    RcFloat ->+      case vr of+        VirtualRegD {} -> 1+        _other -> 0+    RcVector ->+      case vr of+        VirtualRegV128 {} -> 1+        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr =+  case cls of+    RcInteger ->+      case rr of+        RealRegSingle regNo+          | regNo < 32+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < 32+          || regNo > 63+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > 63+          -> 1+          | otherwise+          -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   | not (isFloatFormat format) = VirtualRegI u+   | otherwise+   = case format of+        FF32    -> VirtualRegD u+        FF64    -> VirtualRegD u+        _       -> panic "LA64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+   | i < 32 = RcInteger+   | i > 63 = RcVector+   | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        RcVector        -> text "green"
+ GHC/CmmToAsm/Monad.hs view
@@ -0,0 +1,368 @@+{-# 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.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.DSM+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++-- | A Native Code Generator implementation is parametrised over+-- * The type of static data (typically related to 'CmmStatics')+-- * The type of instructions+-- * The type of jump destinations+data NcgImpl statics instr jumpDest = NcgImpl {+    ncgConfig                 :: !NCGConfig,+    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),+    -- | Given a jump destination, if it refers to a block, return the block id of the destination.+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,+    -- | Does this jump always jump to a single destination and is shortcutable?+    --+    -- We use this to determine whether the given instruction is a shortcutable+    -- jump to some destination - See Note [supporting shortcutting]+    -- Note that if we return a destination here we *most* support the relevant shortcutting in+    -- shortcutStatics for jump tables and shortcutJump for the instructions itself.+    canShortcut               :: instr -> Maybe jumpDest,+    -- | Replace references to blockIds with other destinations - used to update jump tables.+    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,+    -- | Change the jump destination(s) of an instruction.+    --+    -- Rewrites the destination of a jump instruction to another+    -- destination, if the given function returns a new jump destination for+    -- the 'BlockId' of the original destination.+    --+    -- For instance, for a mapping @block_a -> dest_b@ and a instruction @goto block_a@ we would+    -- rewrite the instruction to @goto dest_b@+    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+                              -> UniqDSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),+    -- ^ The list of block ids records the redirected jumps to allow us to update+    -- the CFG.+    ncgMakeFarBranches        :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock instr]+                              -> UniqDSM [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 [supporting shortcutting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the concept of shortcutting see Note [What is shortcutting].++In order to support shortcutting across multiple backends uniformly we+use canShortcut, shortcutStatics and shortcutJump.++canShortcut tells us if the backend support shortcutting of a instruction+and if so what destination we should retarget instruction to instead.++shortcutStatics exists to allow us to update jump destinations in jump tables.++shortcutJump updates the instructions itself.++A backend can opt out of those by always returning Nothing for canShortcut+and implementing shortcutStatics/shortcutJump as \_ x -> x++-}++{- 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          :: DUniqSupply,+                natm_delta       :: Int, -- ^ Stack offset for unwinding information+                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 :: DUniqSupply -> 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 MonadGetUnique NatM where+  getUniqueM = NatM $ \st ->+      case takeUniqueFromDSupply (natm_us st) of+        (uniq, us') -> (uniq, st {natm_us = us'})++getUniqueNat :: NatM Unique+getUniqueNat = getUniqueM++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)
+ GHC/CmmToAsm/PIC.hs view
@@ -0,0 +1,826 @@+{-+  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.Label+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 | ArchRISCV64 <- platformArch platform -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ cmmMakePicReference config symbolPtr++        AccessViaSymbolPtr | ArchLoongArch64 <- 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)++        -- On wasm, always preserve the original CLabel, the backends+        -- will handle dynamic references properly+        AccessDirectly | ArchWasm32 <- platformArch platform ->+              pure $ CmmLit $ CmmLabel lbl++        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++  -- as on AArch64, there's no pic base register.+  | ArchRISCV64 <- platformArch platform+  = CmmLit $ CmmLabel lbl++  | ArchLoongArch64 <- platformArch platform+  = CmmLit $ CmmLabel lbl++  | OSAIX <- platformOS platform+  = CmmMachOp (MO_Add W32)+          [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))+          , 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 $ GlobalRegUse PicBaseReg (bWord platform))+          , CmmLit $ picRelative (wordWidth platform)+                          (platformArch platform)+                          (platformOS   platform)+                          lbl ]++  | (ncgPIC config || ncgExternalDynamicRefs config)+      && absoluteLabel lbl+  = CmmMachOp (MO_Add (wordWidth platform))+          [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))+          , 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 _ 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:+        | ncgLabelDynamic config lbl+        = AccessViaSymbolPtr+++howToAccessLabel _ _ OSDarwin _ _+        = 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++-- On wasm, always keep the original CLabel and let the backend decide+-- how to handle dynamic references+howToAccessLabel _ ArchWasm32 _ _ _+        = 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")+                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+   (_, 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+   (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++--------------------------------------------------------------------------------+-- 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+        :: OS -> Reg+        -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]+        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]++initializePicBase_x86 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 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"
+ GHC/CmmToAsm/PPC.hs view
@@ -0,0 +1,61 @@+{-# 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+   canFallthroughTo    = PPC.canFallthroughTo+   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
+ GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -0,0 +1,2669 @@+{-# 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.Unified+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 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 (LexicalFastString name))+      -> do fileid <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col =srcSpanStartCol span+            return $ unitOL $ LOCATION fileid line col (unpackFS 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 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 -> [GlobalRegUse] -> [RegWithFormat]+jumpRegs platform gregs =+  [ RegWithFormat (RegReal r) (cmmTypeFormat ty)+  | GlobalRegUse gr ty <- gregs+  , Just r <- [globalRegMaybe platform gr] ]++--------------------------------------------------------------------------------+-- | '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 (globalRegUse_reg 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 :: CmmExpr -> CmmExpr+mangleIndexTree (CmmRegOff reg off)+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType 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)++data MinOrMax = Min | Max++getRegister :: CmmExpr -> NatM Register+getRegister e = do config <- getConfig+                   getRegister' config (ncgPlatform config) e++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register++getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse 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 reg))+                  (getRegisterReg platform reg) nilOL)++getRegister' config platform tree@(CmmRegOff _ _)+  = getRegister' config platform (mangleIndexTree 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 format = cmmTypeFormat pk+        let code dst = assert ((targetClassOfReg platform dst == RcFloatOrVector) == 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)++ | otherwise = do -- 32-bit arch & 64-bit load+        (hi_addr, lo_addr, addr_code) <- getI64Amodes mem+        let code dst = addr_code+                        `snocOL` LD II32 dst lo_addr+                        `snocOL` LD II32 (getHiVRegFromLo dst) hi_addr+        return (Any II64 code)++-- 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 (MO_RelaxedRead w) [e]) =+      getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned)++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_Truncate from to -> coerceFP2Int from to x+      MO_SF_Round    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++      MO_V_Broadcast {} -> vectorsNeedLlvm+      MO_VF_Broadcast {} -> vectorsNeedLlvm+      MO_VF_Neg {} -> vectorsNeedLlvm++      _ -> panic "PPC.CodeGen.getRegister: no match"++    where+        vectorsNeedLlvm =+            sorry "SIMD operations on PowerPC currently require the LLVM backend"+        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++      MO_F_Min w -> minmax_float Min w x y+      MO_F_Max w -> minmax_float Max w x y++         -- 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++      MO_V_Extract {} -> vectorsNeedLlvm+      MO_V_Add {} -> vectorsNeedLlvm+      MO_V_Sub {} -> vectorsNeedLlvm+      MO_V_Mul {} -> vectorsNeedLlvm+      MO_VS_Neg {} -> vectorsNeedLlvm+      MO_VF_Extract {} -> vectorsNeedLlvm+      MO_VF_Add {} -> vectorsNeedLlvm+      MO_VF_Sub {} -> vectorsNeedLlvm+      MO_VF_Neg {} -> vectorsNeedLlvm+      MO_VF_Mul {} -> vectorsNeedLlvm+      MO_VF_Quot {} -> vectorsNeedLlvm+      MO_V_Shuffle {} -> vectorsNeedLlvm+      MO_VF_Shuffle {} -> vectorsNeedLlvm+      MO_VU_Min {} -> vectorsNeedLlvm+      MO_VU_Max {} -> vectorsNeedLlvm+      MO_VS_Min {} -> vectorsNeedLlvm+      MO_VS_Max {} -> vectorsNeedLlvm+      MO_VF_Min {} -> vectorsNeedLlvm+      MO_VF_Max {} -> vectorsNeedLlvm++      _ -> panic "PPC.CodeGen.getRegister: no match"++  where+    vectorsNeedLlvm =+      sorry "SIMD operations on PowerPC currently require the LLVM backend"++    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)++    minmax_float :: MinOrMax -> Width -> CmmExpr -> CmmExpr -> NatM Register+    minmax_float m w x y =+      do+        (src1, src1Code) <- getSomeReg x+        (src2, src2Code) <- getSomeReg y+        l1 <- getBlockIdNat+        l2 <- getBlockIdNat+        end <- getBlockIdNat+        let cond = case m of+                     Min -> LTT+                     Max -> GTT+        let code dst = src1Code `appOL` src2Code `appOL`+                       toOL [ FCMP src1 src2+                            , BCC cond l1 Nothing+                            , BCC ALWAYS l2 Nothing+                            , NEWBLOCK l2+                            , MR dst src2+                            , BCC ALWAYS end Nothing+                            , NEWBLOCK l1+                            , MR dst src1+                            , BCC ALWAYS end Nothing+                            , NEWBLOCK end+                            ]+        return (Any (floatFormat w) code)++getRegister' _ _ (CmmMachOp mop [x, y, z]) -- ternary PrimOps+  = case mop of++      -- x86 fmadd    x * y + z <> PPC fmadd  rt =   ra * rc + rb+      -- x86 fmsub    x * y - z <> PPC fmsub  rt =   ra * rc - rb+      -- x86 fnmadd - x * y + z ~~ PPC fnmsub rt = -(ra * rc - rb)+      -- x86 fnmsub - x * y - z ~~ PPC fnmadd rt = -(ra * rc + rb)++      MO_FMA variant l w | l == 1 ->+        case variant of+          FMAdd  -> fma_code w (FMADD FMAdd) x y z+          FMSub  -> fma_code w (FMADD FMSub) x y z+          FNMAdd -> fma_code w (FMADD FNMAdd) x y z+          FNMSub -> fma_code w (FMADD FNMSub) x y z+        | otherwise+        -> vectorsNeedLlvm++      MO_V_Insert {} -> vectorsNeedLlvm+      MO_VF_Insert {} -> vectorsNeedLlvm++      _ -> panic "PPC.CodeGen.getRegister: no match"+  where+    vectorsNeedLlvm =+      sorry "SIMD operations on PowerPC currently require the LLVM backend"++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 _ _)+  = getAmode inf (mangleIndexTree 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-} -> [RegWithFormat] -> 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 -> [RegWithFormat] -> 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_AcquireFence) _ _+ = return $ unitOL LWSYNC+genCCall (PrimTarget MO_ReleaseFence) _ _+ = return $ unitOL LWSYNC+genCCall (PrimTarget MO_SeqCstFence) _ _+ = return $ unitOL HWSYNC++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+                         -- ELF v2 ABI Revision 1.5 Section 2.2.3.3. requires+                         -- a single-precision floating-point value+                         -- to be mapped to the least-significant+                         -- word in a single doubleword.+                         GCP64ELF 2 -> case platformByteOrder platform of+                                       BigEndian    -> stackOffset' + 4+                                       LittleEndian -> stackOffset'+                         _          -> 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"+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"++                      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"+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"++                      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)+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"++        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 (CmmLocal dest)+                          r_dest = getLocalRegReg dest+                _ -> panic "genCCall' moveResult: Bad dest_regs"++        outOfLineMachOp mop =+            do+                mopExpr <- cmmMakeDynamicReference config CallReference $+                              mkForeignLabel functionName 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_VS_Quot {}    -> unsupported+                    MO_VS_Rem {}     -> unsupported+                    MO_VU_Quot {}    -> unsupported+                    MO_VU_Rem {}     -> unsupported+                    MO_I64X2_Min     -> unsupported+                    MO_I64X2_Max     -> unsupported+                    MO_W64X2_Min     -> unsupported+                    MO_W64X2_Max     -> unsupported+                    MO_AcquireFence  -> unsupported+                    MO_ReleaseFence  -> unsupported+                    MO_SeqCstFence   -> 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')++-- | Generate code for a 4-register FMA instruction,+-- e.g. @fmadd rt ra rc rb := rt <- ra * rc + rb@.+fma_code :: Width+         -> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)+         -> CmmExpr+         -> CmmExpr+         -> CmmExpr+         -> NatM Register+fma_code w instr ra rc rb = do+    let rep = floatFormat w+    (src1, code1) <- getSomeReg ra+    (src2, code2) <- getSomeReg rc+    (src3, code3) <- getSomeReg rb+    let instrCode rt =+          code1 `appOL`+          code2 `appOL`+          code3 `snocOL` instr rep rt src1 src2 src3+    return $ Any rep instrCode++-- 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
+ GHC/CmmToAsm/PPC/Cond.hs view
@@ -0,0 +1,47 @@+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
+ GHC/CmmToAsm/PPC/Instr.hs view
@@ -0,0 +1,731 @@+-----------------------------------------------------------------------------+--+-- 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+   , canFallthroughTo+   , 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.Unified+import GHC.Platform.Reg++import GHC.Platform.Regs+import GHC.Cmm.BlockId+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.DSM++import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NE+import GHC.Data.FastString (FastString)+import GHC.Data.Maybe (expectJust, 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+  -> UniqDSM (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++    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++    let+        delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+            where x = slots * spillSlotSize -- sp delta++        alloc   = mkStackAllocInstr   platform delta+        dealloc = mkStackDeallocInstr platform delta++        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 [RegWithFormat]    -- same as branch,+                                    -- but with CLabel instead of block ID+                                    -- and live global registers+    | MTCTR   Reg+    | BCTR    [Maybe BlockId] (Maybe CLabel) [RegWithFormat]+                                    -- 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.++    -- | Fused multiply-add instructions.+    --+    --   - FMADD:  @rd =  (ra * rb) + rd@+    --   - FMSUB:  @rd =   ra * rb  - rd@+    --   - FNMADD: @rd = -(ra * rb + rd)@+    --   - FNMSUB: @rd = -(ra * rb - rd)@+    | FMADD FMASign Format Reg Reg Reg Reg++    | 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 (map regWithFormat_reg regs, [])+    MTCTR   reg              -> usage ([reg],[])+    BCTR    _ _ regs         -> usage (map regWithFormat_reg 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])+    FMADD _ _ rt ra rc rb   -> usage ([ra, rc, rb], [rt])+    _                       -> noUsage+  where+    usage (src, dst) = RU (map mkFmt $ filter (interesting platform) src)+                          (map mkFmt $ filter (interesting platform) dst)+      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+      -- As the PowerPC NCG does not currently support SIMD registers,+      -- this simple logic is OK.+    mkFmt r = RegWithFormat r fmt+      where fmt = case targetClassOfReg platform r of+                    RcInteger -> archWordFormat (target32Bit platform)+                    RcFloatOrVector -> FF64+    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)+    FMADD   sgn fmt r1 r2 r3 r4+                            -> FMADD sgn fmt (env r1) (env r2) (env r3) (env r4)+    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++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo instr bid+ = case instr of+        BCC _ target _      -> target == bid+        BCCFAR _ target _   -> target == bid+        _                   -> 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+   -> RegWithFormat -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr config (RegWithFormat reg _fmt) 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+                RcFloatOrVector  -> FF64+        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+   -> RegWithFormat -- register to load+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkLoadInstr config (RegWithFormat reg _fmt) 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+                RcFloatOrVector  -> FF64+        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+    :: Format+    -> Reg+    -> Reg+    -> Instr++mkRegRegMoveInstr _fmt src dst+    = MR dst src+    -- SIMD NCG TODO: handle vector format+++-- | 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+        :: Platform+        -> LabelMap RawCmmStatics+        -> [NatBasicBlock Instr]+        -> UniqDSM [NatBasicBlock Instr]+makeFarBranches _platform info_env blocks+    | NE.last blockAddresses < nearLimit = return blocks+    | otherwise = return $ 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 targetAddr = expectJust $ 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
+ GHC/CmmToAsm/PPC/Ppr.hs view
@@ -0,0 +1,1128 @@+{-# 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.Unified+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.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 (VirtualRegD    u) -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> 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"+                VecFormat {} -> panic "PPC pprFormat: VecFormat"++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"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"+               ),+           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"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"+               ),+           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"+            RcFloatOrVector -> 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 _+     | OSAIX <- platformOS platform ->+       line $ hcat [ -- an alias for b that takes a CLabel+           text "\tb.\t", -- add the ".", cf Note [AIX function descriptors and entry-code addresses]+           pprAsmLabel platform lbl+       ]++     | 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 ->+             -- Note [AIX function descriptors and entry-code addresses]+             -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+             -- 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++   FMADD signs fmt dst ra rc rb+     -> pprTernaryF (pprFMASign signs) fmt dst ra rc rb++   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+    ]++pprTernaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> Reg -> doc+pprTernaryF op fmt rt ra rc rb = line $ hcat [+        char '\t',+        op,+        pprFFormat fmt,+        char '\t',+        pprReg rt,+        text ", ",+        pprReg ra,+        text ", ",+        pprReg rc,+        text ", ",+        pprReg rb+    ]++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
+ GHC/CmmToAsm/PPC/RegInfo.hs view
@@ -0,0 +1,77 @@++-----------------------------------------------------------------------------+--+-- 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
+ GHC/CmmToAsm/PPC/Regs.hs view
@@ -0,0 +1,316 @@+-- -----------------------------------------------------------------------------+--+-- (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,+        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.Unified+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++        RcFloatOrVector+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegV128{}        -> 1+                _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+++        RcFloatOrVector+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1+++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"+        RcFloatOrVector -> text "red"++++-- 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 = RcFloatOrVector++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"
+ GHC/CmmToAsm/Ppr.hs view
@@ -0,0 +1,281 @@+{-# 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+++-- -----------------------------------------------------------------------------+-- 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+      Text+        | OSMinGW32 <- platformOS platform, splitSections+                    -> text ",\"xr\""+        | splitSections+                    -> text ",\"ax\"," <> sectionType platform "progbits"+      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
+ GHC/CmmToAsm/RV64.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for RiscV64 architectures+module GHC.CmmToAsm.RV64 (ncgRV64) where++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.RV64.CodeGen qualified as RV64+import GHC.CmmToAsm.RV64.Instr qualified as RV64+import GHC.CmmToAsm.RV64.Ppr qualified as RV64+import GHC.CmmToAsm.RV64.RegInfo qualified as RV64+import GHC.CmmToAsm.RV64.Regs qualified as RV64+import GHC.CmmToAsm.Types+import GHC.Prelude+import GHC.Utils.Outputable (ftext)++ncgRV64 :: NCGConfig -> NcgImpl RawCmmStatics RV64.Instr RV64.JumpDest+ncgRV64 config =+  NcgImpl+    { ncgConfig = config,+      cmmTopCodeGen = RV64.cmmTopCodeGen,+      generateJumpTableForInstr = RV64.generateJumpTableForInstr config,+      getJumpDestBlockId = RV64.getJumpDestBlockId,+      canShortcut = RV64.canShortcut,+      shortcutStatics = RV64.shortcutStatics,+      shortcutJump = RV64.shortcutJump,+      pprNatCmmDeclS = RV64.pprNatCmmDecl config,+      pprNatCmmDeclH = RV64.pprNatCmmDecl config,+      maxSpillSlots = RV64.maxSpillSlots config,+      allocatableRegs = RV64.allocatableRegs platform,+      ncgAllocMoreStack = RV64.allocMoreStack platform,+      ncgMakeFarBranches = RV64.makeFarBranches,+      extractUnwindPoints = const [],+      invertCondBranches = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for RV64+instance Instruction RV64.Instr where+  regUsageOfInstr = RV64.regUsageOfInstr+  patchRegsOfInstr _ = RV64.patchRegsOfInstr+  isJumpishInstr = RV64.isJumpishInstr+  canFallthroughTo = RV64.canFallthroughTo+  jumpDestsOfInstr = RV64.jumpDestsOfInstr+  patchJumpInstr = RV64.patchJumpInstr+  mkSpillInstr = RV64.mkSpillInstr+  mkLoadInstr = RV64.mkLoadInstr+  takeDeltaInstr = RV64.takeDeltaInstr+  isMetaInstr = RV64.isMetaInstr+  mkRegRegMoveInstr _ _ = RV64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr+  mkJumpInstr = RV64.mkJumpInstr+  mkStackAllocInstr = RV64.mkStackAllocInstr+  mkStackDeallocInstr = RV64.mkStackDeallocInstr+  mkComment = pure . RV64.COMMENT . ftext+  pprInstr = RV64.pprInstr
+ GHC/CmmToAsm/RV64/CodeGen.hs view
@@ -0,0 +1,2231 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module GHC.CmmToAsm.RV64.CodeGen+  ( cmmTopCodeGen,+    generateJumpTableForInstr,+    makeFarBranches,+  )+where++import Control.Monad+import Data.Maybe+import Data.Word+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.DebugBlock+import GHC.Cmm.Switch+import GHC.Cmm.Utils+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Monad+  ( NatM,+    getBlockIdNat,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform,+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Float+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)+import GHC.Types.Tickish (GenTickish (..))+import GHC.Types.Unique.DSM+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- For an overview of an NCG's structure, see Note [General layout of an NCG]++cmmTopCodeGen ::+  RawCmmDecl ->+  NatM [NatCmmDecl RawCmmStatics Instr]+-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  picBaseMb <- getPicBaseMaybeNat+  when (isJust picBaseMb) $ panic "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"++  let blocks = toBlockListEntryFirst graph+  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  pure tops++-- ... or CmmData.+cmmTopCodeGen (CmmData sec dat) = pure [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+  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 `.loc` (DWARF debug location info)+  loc_instrs <- genLocInstrs++  -- Generate other instructions+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail++  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs++      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to+      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs+      -- work fine without it.++      -- 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.+      (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs++  return (BasicBlock id top : other_blocks, statics)+  where+    genLocInstrs :: NatM (OrdList Instr)+    genLocInstrs = do+      dbg <- getDebugBlock (entryLabel block)+      case dblSourceTick =<< dbg of+        Just (SourceNote span name) ->+          do+            fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            pure $ unitOL $ LOCATION fileId line col name+        _ -> pure nilOL++mkBlocks ::+  Instr ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+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)++-- -----------------------------------------------------------------------------++-- | Utilities++-- | Annotate an `Instr` with a `SDoc` comment+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc 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 could 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 {- debugIsOn -} = ANN (text . show $ e)+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++-- Note [RISCV64 Jump Tables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Jump tables are implemented by generating a table of relative addresses,+-- where each entry is the relative offset to the target block from the first+-- entry / table label (`generateJumpTableForInstr`). Using the jump table means+-- loading the entry's value and jumping to the calculated absolute address+-- (`genSwitch`).+--+-- For example, this Cmm switch+--+--   switch [1 .. 10] _s2wn::I64 {+--       case 1 : goto c347;+--       case 2 : goto c348;+--       case 3 : goto c349;+--       case 4 : goto c34a;+--       case 5 : goto c34b;+--       case 6 : goto c34c;+--       case 7 : goto c34d;+--       case 8 : goto c34e;+--       case 9 : goto c34f;+--       case 10 : goto c34g;+--   }   // CmmSwitch+--+-- leads to this jump table in Assembly+--+--   .section .rodata+--           .balign 8+--   .Ln34G:+--           .quad   0+--           .quad   .Lc347-(.Ln34G)+0+--           .quad   .Lc348-(.Ln34G)+0+--           .quad   .Lc349-(.Ln34G)+0+--           .quad   .Lc34a-(.Ln34G)+0+--           .quad   .Lc34b-(.Ln34G)+0+--           .quad   .Lc34c-(.Ln34G)+0+--           .quad   .Lc34d-(.Ln34G)+0+--           .quad   .Lc34e-(.Ln34G)+0+--           .quad   .Lc34f-(.Ln34G)+0+--           .quad   .Lc34g-(.Ln34G)+0+--+-- and this indexing code where the jump should be done (register t0 contains+-- the index)+--+--           addi t0, t0, 0 // silly move (ignore it)+--           la t1, .Ln34G // load the table's address+--           sll t0, t0, 3 // index * 8 -> offset in bytes+--           add t0, t0, t1 // address of the table's entry+--           ld t0, 0(t0) // load entry+--           add t0, t0, t1 // relative to absolute address+--           jalr zero, t0, 0 // jump to the block+--+-- In object code (disassembled) the table looks like+--+--   0000000000000000 <.Ln34G>:+--        ...+--        8: R_RISCV_ADD64        .Lc347+--        8: R_RISCV_SUB64        .Ln34G+--        10: R_RISCV_ADD64       .Lc348+--        10: R_RISCV_SUB64       .Ln34G+--        18: R_RISCV_ADD64       .Lc349+--        18: R_RISCV_SUB64       .Ln34G+--        20: R_RISCV_ADD64       .Lc34a+--        20: R_RISCV_SUB64       .Ln34G+--        28: R_RISCV_ADD64       .Lc34b+--        28: R_RISCV_SUB64       .Ln34G+--        30: R_RISCV_ADD64       .Lc34c+--        30: R_RISCV_SUB64       .Ln34G+--        38: R_RISCV_ADD64       .Lc34d+--        38: R_RISCV_SUB64       .Ln34G+--        40: R_RISCV_ADD64       .Lc34e+--        40: R_RISCV_SUB64       .Ln34G+--        48: R_RISCV_ADD64       .Lc34f+--        48: R_RISCV_SUB64       .Ln34G+--        50: R_RISCV_ADD64       .Lc34g+--        50: R_RISCV_SUB64       .Ln34G+--+-- I.e. the relative offset calculations are done by the linker via relocations.+-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not+-- complain.+++-- | Generate jump to jump table target+--+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the relative address to jump to (relative+-- to the jump table's first entry / the table's own label).+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  let fmt = II64+  targetReg <- getNewRegNat fmt+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg dynRef+  let code =+        toOL+          [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),+            COMMENT (text "dynRef" <+> (text . show) dynRef)+          ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [ COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (SLL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDRU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL ids (Just lbl) targetReg+            ]+  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++-- | Generate jump table data (if required)+--+-- The idea is to emit one table entry per case. The entry is the relative+-- address of the block to jump to (relative to the table's first entry /+-- table's own label.) The calculation itself is done by the linker.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel 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++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++stmtsToInstrs ::+  -- | Cmm Statements+  [CmmNode O O] ->+  -- | Resulting instruction+  NatM InstrBlock+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts++stmtToInstrs ::+  CmmNode e x ->+  -- | Resulting instructions+  NatM InstrBlock+stmtToInstrs stmt = do+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args ->+      genCCall target result_regs args+    CmmComment s -> pure (unitOL (COMMENT (ftext s)))+    CmmTick {} -> pure nilOL+    CmmAssign reg src+      | isFloatType ty -> assignReg_FltCode format reg src+      | otherwise -> assignReg_IntCode format reg src+      where+        ty = cmmRegType 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 true false arg+    CmmSwitch arg ids -> genSwitch config arg ids+    CmmCall {cml_target = arg} -> genJump arg+    CmmUnwind _regs -> pure nilOL+    -- Intentionally not have a default case here: If anybody adds a+    -- constructor, the compiler should force them to think about this here.+    CmmForeignCall {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)+    CmmEntry {} -> 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 _format reg code) = Fixed format' reg code+swizzleRegisterRep format' (Any _format codefn) = Any format' codefn++-- | Grab a `Reg` for a `CmmReg`+--+-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are+-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a+-- STG register.+getRegisterReg :: Platform -> CmmReg -> Reg+getRegisterReg _ (CmmLocal (LocalReg u pk)) =+  RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)+getRegisterReg platform (CmmGlobal mid) =+  case globalRegMaybe platform (globalRegUse_reg mid) of+    Just reg -> RegReal reg+    Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- | Compute an expression into any register+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Compute an expression into any floating-point register+--+-- If the initial expression is not a floating-point expression, finally move+-- the result into a floating-point register.+getFloatReg :: (HasCallStack) => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Any II32 code -> do+      newReg <- getNewRegNat FF32+      return (newReg, FF32, code newReg)+    Any II64 code -> do+      newReg <- getNewRegNat FF64+      return (newReg, FF64, code newReg)+    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)++-- | Map `CmmLit` to `OpImm`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- | Compute a `CmmExpr` into a `Register`+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+opRegWidth W32 = W32+opRegWidth W16 = W32+opRegWidth W8 = W32+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on RISCV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to RISCV64'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.+--+-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by+-- Craig Topper covers possible future improvements+-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf)+--+--+-- Note [Handling PIC on RV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- RV64 does not have a special PIC register, the general approach is to simply+-- do PC-relative addressing or go through the GOT. There is assembly support+-- for both.+--+-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows+-- loading a label's address into a register. The instruction is desugared into+-- different addressing modes, e.g. PC-relative addressing:+--+-- 1: lui  rd1, %pcrel_hi(label)+--    addi rd1, %pcrel_lo(1b)+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html,+-- PIC can be enabled/disabled through+--+--  .option pic+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives+--+-- 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 RV64. 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 (GlobalRegUse PicBaseReg _)) ->+      -- See Note [Handling PIC on RV64]+      pprPanic "getRegister': There's no PIC base register on RISCV" (ppr PicBaseReg)+    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w ->+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+           in pure (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))+        CmmFloat 0 w -> do+          let op = litToImm' lit+          pure (Any (floatFormat w) (\dst -> unitOL $ 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+          intReg <- getNewRegNat (intFormat W32)+          return+            ( Any+                (floatFormat W32)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W32 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W32 dst) (OpReg W32 intReg)+                      ]+                )+            )+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          intReg <- getNewRegNat (intFormat W64)+          return+            ( Any+                (floatFormat W64)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W64 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W64 dst) (OpReg W64 intReg)+                      ]+                )+            )+        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)+        CmmLabel lbl -> do+          let op = OpImm (ImmCLbl lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ annExpr expr (LDR format (OpReg (formatToWidth format) dst) op)))+        CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          let op = OpImm (ImmIndex lbl off)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ LDR format (OpReg (formatToWidth format) dst) op))+        CmmLabelOff lbl off -> do+          let op = litToImm' (CmmLabel lbl)+              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 ->+                    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+      let format = cmmTypeFormat rep+          width = typeWidth rep+      Amode addr addr_code <- getAmode plat width mem+      case width of+        w+          | w <= W64 ->+              -- Load without sign-extension. See Note [Signed arithmetic on RISCV64]+              pure+                ( Any+                    format+                    ( \dst ->+                        addr_code+                          `snocOL` LDRU format (OpReg width dst) (OpAddr addr)+                    )+                )+        _ ->+          pprPanic ("Width too big! Cannot load: " ++ show width) (pdoc plat expr)+    CmmStackSlot _ _ ->+      pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)+    CmmReg reg ->+      return+        ( Fixed+            (cmmTypeFormat (cmmRegType 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 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 reg)++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)+    -- 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`+                -- pseudo instruction `not` is `xori rd, rs, -1`+                ann (text "not") (XORI (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt (-1))))+                `appOL` truncateReg w' w dst -- See Note [Signed arithmetic on RISCV64]+        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)+              )+        -- TODO: Can this case happen?+        MO_SF_Round from to | from < W32 -> do+          -- extend to the smallest available representation+          (reg_x, code_x) <- signExtendReg from W32 reg+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `appOL` code_x+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float)+              )+        MO_SF_Round from to ->+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)+              )+        -- TODO: Can this case happen?+        MO_FS_Truncate from to+          | to < W32 ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL`+                        -- W32 is the smallest width to convert to. Decrease width afterwards.+                        annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg))+                        `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed)+                  )+        MO_FS_Truncate from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg))+                    `appOL` truncateReg from to dst -- (float convert (-> zero) signed)+              )+        MO_UU_Conv from to+          | from <= to ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg to dst) (OpReg from reg))+                  )+        MO_UU_Conv from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                    `appOL` truncateReg from to dst+              )+        MO_SS_Conv from to -> ss_conv from to reg code+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg)))+        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))++        -- Conversions+        -- TODO: Duplication with MO_UU_Conv+        MO_XX_Conv from to+          | to < from ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                        `appOL` truncateReg from to dst+                  )+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e+        MO_AlignmentCheck align wordWidth -> do+          reg <- getRegister' config plat e+          addAlignmentCheck align wordWidth reg+        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+        -- See Note [Signed arithmetic on RISCV64].+        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+          | from < to = do+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` signExtend from to reg dst+                  `appOL` truncateReg from to dst+          | from > to =+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` toOL+                    [ ann+                        (text "MO_SS_Conv: narrow register signed" <+> ppr reg <+> ppr from <> text "->" <> ppr to)+                        (SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt shift))),+                      -- signed right shift+                      SRA (OpReg to dst) (OpReg to dst) (OpImm (ImmInt shift))+                    ]+                  `appOL` truncateReg from to dst+          | otherwise =+              -- No conversion necessary: Just copy.+              pure $ Any (intFormat from) $ \dst ->+                code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          where+            shift = 64 - (widthInBits from - widthInBits to)++    -- 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 _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || 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` truncateReg (formatToWidth format_x) w reg_x+                `appOL` code_y+                `appOL` truncateReg (formatToWidth format_y) w reg_y+                `snocOL` annExpr expr (DIVU (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 (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    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 (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)] | fitsIn12bitImm n -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpImm (ImmInteger n)))+          )+    CmmMachOp (MO_S_Shr w) [x, y] -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `appOL` code_y+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpReg w reg_y))+          )+    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+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    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+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, y] | w == W8 || 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+                `appOL` truncateReg (formatToWidth format_x) w reg_x+                `snocOL` annExpr expr (SRL (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 (SRL (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 (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )++    -- 3. Logic &&, ||+    CmmMachOp (MO_And w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Or w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORI (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let -- 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 RISCV64].+          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))+        -- 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 -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_Ne w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        -- Signed multiply/divide+        MO_Mul w -> intOp True w (\d x y -> unitOL $ annExpr expr (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 $ annExpr expr (DIV d x y))+        MO_S_Rem w -> intOp True w (\d x y -> unitOL $ annExpr expr (REM d x y))+        -- Unsigned multiply/divide+        MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y))+        MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y))+        -- Signed comparisons+        MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE))+        MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE))+        MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT))+        MO_S_Lt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLT))+        -- Unsigned comparisons+        MO_U_Ge w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGE))+        MO_U_Le w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULE))+        MO_U_Gt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGT))+        MO_U_Lt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULT))+        -- Floating point arithmetic+        MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        -- Floating point comparison+        MO_F_Min w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y))+        MO_F_Max w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y))+        MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGE))+        MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLE)) -- x <= y <=> y > x+        MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGT))+        MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLT)) -- x < y <=> y >= x++        -- Bitwise operations+        MO_And w -> bitOp w (\d x y -> unitOL $ annExpr expr (AND d x y))+        MO_Or w -> bitOp w (\d x y -> unitOL $ annExpr expr (OR d x y))+        MO_Xor w -> bitOp w (\d x y -> unitOL $ annExpr expr (XOR d x y))+        MO_Shl w -> intOp False w (\d x y -> unitOL $ annExpr expr (SLL d x y))+        MO_U_Shr w -> intOp False w (\d x y -> unitOL $ annExpr expr (SRL d x y))+        MO_S_Shr w -> intOp True w (\d x y -> unitOL $ annExpr expr (SRA d x y))+        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->+      case op of+        -- Floating-point fused multiply-add operations+        --+        -- x86 fmadd    x * y + z <=> RISCV64 fmadd : d =   r1 * r2 + r3+        -- x86 fmsub    x * y - z <=> RISCV64 fnmsub: d =   r1 * r2 - r3+        -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3+        -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3+        MO_FMA var l w+          | l == 1+          -> case var of+                FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a)+                FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)+                FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a)+                FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> sorry "The RISCV64 backend does not (yet) support vectors."+        _ ->+          pprPanic "getRegister' (unhandled ternary CmmMachOp): "+            $ pprMachOp op+            <+> text "in"+            <+> pdoc plat expr+      where+        float3Op w op = do+          (reg_fx, format_x, code_fx) <- getFloatReg x+          (reg_fy, format_y, code_fy) <- getFloatReg y+          (reg_fz, format_z, code_fz) <- getFloatReg z+          massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z)+            $ text "float3Op: non-float"+          pure+            $ Any (floatFormat w)+            $ \dst ->+              code_fx+                `appOL` code_fy+                `appOL` code_fz+                `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)+    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)+    -- N.B. MUL does not set the overflow flag.+    -- Return 0 when the operation cannot overflow, /= 0 otherwise+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo w _x _y | w > W64 = pprPanic "Cannot multiply larger than 64bit" (ppr w)+    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+      -- TODO: Can't we clobber reg_x and reg_y to save registers?+      lo <- getNewRegNat II64+      hi <- getNewRegNat II64+      -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ+      let nonSense = OpImm (ImmInt 0)+      pure+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x+                `appOL` code_y+                `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y+                `appOL` toOL+                  [ annExpr expr (MULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y)),+                    MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y),+                    SRA (OpReg w lo) (OpReg w lo) (OpImm (ImmInt (widthInBits W64 - 1))),+                    ann+                      (text "Set flag if result of MULH contains more than sign bits.")+                      (XOR (OpReg w hi) (OpReg w hi) (OpReg w lo)),+                    CSET (OpReg w dst) (OpReg w hi) nonSense 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 width_x = formatToWidth format_x+          width_y = formatToWidth format_y+      if w > width_x && w > width_y+        then+          pure+            $ Any+              (intFormat w)+              ( \dst ->+                  -- 8bit * 8bit cannot overflow 16bit+                  -- 16bit * 16bit cannot overflow 32bit+                  -- 32bit * 32bit cannot overflow 64bit+                  unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 0)))+              )+        else do+          let use32BitMul = w <= W32 && width_x <= W32 && width_y <= W32+              nonSense = OpImm (ImmInt 0)+          if use32BitMul+            then do+              narrowedReg <- getNewRegNat II64+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      code_x+                        `appOL` signExtend (formatToWidth format_x) W32 reg_x reg_x+                        `appOL` code_y+                        `appOL` signExtend (formatToWidth format_y) W32 reg_y reg_y+                        `snocOL` annExpr expr (MUL (OpReg W32 dst) (OpReg W32 reg_x) (OpReg W32 reg_y))+                        `appOL` signExtendAdjustPrecission W32 w dst narrowedReg+                        `appOL` toOL+                          [ ann+                              (text "Check if the multiplied value fits in the narrowed register")+                              (SUB (OpReg w dst) (OpReg w dst) (OpReg w narrowedReg)),+                            CSET (OpReg w dst) (OpReg w dst) nonSense NE+                          ]+                  )+            else+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      -- Do not handle this unlikely case. Just tell that it may overflow.+                      unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 1)))+                  )++-- | 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 | w == W64 = pure (r, nilOL)+signExtendReg w w' r = do+  r' <- getNewRegNat (intFormat w')+  let instrs = signExtend w w' r r'+  pure (r', instrs)++-- | Sign extends to 64bit, if needed+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' _r _r' | w > w' = pprPanic "This is not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+signExtend w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtend w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtend w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtend w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtend w w' r r' =+  toOL+    [ ann+        (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@)+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtendAdjustPrecission w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtendAdjustPrecission w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtendAdjustPrecission w w' r r'+  | w > w' =+      toOL+        [ ann+            (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+            (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+          -- signed (arithmetic) right shift+          SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+        ]+  where+    shift = 64 - widthInBits w'+signExtendAdjustPrecission w w' r r' =+  toOL+    [ ann+        (text "sign extend register" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Instructions to truncate the value in the given register from width @w@+-- to width @w'@.+--+-- In other words, it just cuts the width out of the register. N.B.: This+-- ignores signedness (no sign extension takes place)!+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg _w w' _r | w' == W64 = nilOL+truncateReg _w w' r | w' > W64 = pprPanic "Cannot truncate to width bigger than register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w'+truncateReg w _w' r | w > W64 = pprPanic "Unexpected register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w+truncateReg w w' r =+  toOL+    [ ann+        (text "truncate register" <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (SLL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))),+      -- SHL ignores signedness!+      SRL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w'++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Width -> Register -> NatM Register+addAlignmentCheck align wordWidth reg = do+  jumpReg <- getNewRegNat II64+  cmpReg <- getNewRegNat II64+  okayLblId <- getBlockIdNat++  pure $ case reg of+    Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)+    Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)+  where+    check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock+    check fmt jumpReg cmpReg okayLblId reg =+      let width = formatToWidth fmt+       in assert (not $ isFloatFormat fmt)+            $ toOL+              [ ann+                  (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth))+                  (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1)),+                BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId),+                COMMENT (text "Alignment check failed"),+                LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel),+                B (TReg jumpReg),+                NEWBLOCK okayLblId+              ]++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++-- | Provide the value of a `CmmExpr` with an `Amode`+--+-- N.B. this function should be used to provide operands to load and store+-- instructions with signed 12bit wide immediates (S & I types). For other+-- immediate sizes and formats (e.g. B type uses multiples of 2) this function+-- would need to be adjusted.+getAmode ::+  Platform ->+  -- | width of loaded value+  Width ->+  CmmExpr ->+  NatM Amode+-- TODO: Specialize stuff we can destructure here.++-- LDR/STR: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64,+    fitsIn12bitImm off =+      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')])+  | fitsIn12bitImm off =+      do+        (reg, _format, code) <- getSomeReg expr+        return $ Amode (AddrRegImm reg (ImmInteger off)) code+getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | fitsIn12bitImm (-off) =+      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+-- AArch64 has 26bits for targets, whereas RiscV only has 20.+-- Thus we need to distinguish between far (outside of the)+-- current compilation unit. And regular branches.+-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB.+-- Thus for most branches we can get away with encoding it+-- directly in the instruction rather than always loading the+-- address into a register and then using that to jump.+-- Under the assumption that our linked build product is less than+-- ~2*128MB of TEXT, and there are no jump that span the whole+-- TEXT segment.+-- Something where riscv's compressed instruction might come in+-- handy.+genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock+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 (BCOND EQ zero (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 (BCOND NE zero (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+              w+                | w == W8 || w == W16 ->+                    code_x+                      `appOL` truncateReg (formatToWidth format_x) w reg_x+                      `appOL` code_y+                      `appOL` truncateReg (formatToWidth format_y) w reg_y+                      `appOL` code_y+                      `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))+              _ ->+                code_x+                  `appOL` code_y+                  `snocOL` annExpr expr (BCOND cmp x' y' (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+              w+                | w `elem` [W8, W16, W32] ->+                    code_x+                      `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x+                      `appOL` code_y+                      `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y+                      `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))+              _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (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+            condOpReg <- OpReg W64 <$> getNewRegNat II64+            oneReg <- getNewRegNat II64+            return $ code_fx+              `appOL` code_fy+              `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)+              `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))+              `snocOL` BCOND EQ condOpReg (OpReg w oneReg) (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 FGT+        MO_F_Ge w -> fbcond w FGE+        MO_F_Lt w -> fbcond w FLT+        MO_F_Le w -> fbcond w FLE+        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 "RV64.genCondJump:case mop: " (text $ show expr)+    _ -> pprPanic "RV64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+--+-- This is basically an "if with else" statement.+genCondBranch ::+  -- | the true branch target+  BlockId ->+  -- | the false branch target+  BlockId ->+  -- | the condition on which to branch+  CmmExpr ->+  -- | Instructions+  NatM InstrBlock+genCondBranch true false expr =+  appOL+    <$> genCondJump true expr+    <*> genBranch false++-- -----------------------------------------------------------------------------+--  Generating C calls++-- | Generate a call to a C function.+--+-- - Integer values are passed in GP registers a0-a7.+-- - Floating point values are passed in FP registers fa0-fa7.+-- - If there are no free floating point registers, the FP values are passed in GP registers.+-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack.+-- - For integers/words, the return value is in a0.+-- - The return value is in fa0 if the return type is a floating point value.+genCCall ::+  ForeignTarget -> -- function to call+  [CmmFormal] -> -- where to put the result+  [CmmActual] -> -- arguments (of mixed type)+  NatM InstrBlock+-- TODO: Specialize where we can.+-- Generic impl+genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do+  -- we want to pass arg_regs into allArgRegs+  -- The target :: ForeignTarget call can either+  -- be a foreign procedure with an address expr+  -- and a calling convention.+  (call_target_reg, call_target_code) <-+    -- Compute the address of the call target into a register. This+    -- addressing enables us to jump through the whole address space+    -- without further ado. PC-relative addressing would involve+    -- instructions to do similar, though.+    do+      (reg, _format, reg_code) <- getSomeReg expr+      pure (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 then 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++  (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++  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 spMachReg) (OpReg W64 spMachReg) (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 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))),+            POP_STACK_FRAME,+            DELTA 0+          ]++  let code =+        call_target_code -- compute the label (possibly into a register)+          `appOL` moveStackDown stackSpaceWords+          `appOL` passArgumentsCode -- put the arguments into x0, ...+          `snocOL` BL call_target_reg passRegs -- branch and link (C calls aren't tail calls, but return)+          `appOL` readResultsCode -- parse the results into registers+          `appOL` moveStackUp stackSpaceWords+  return code+  where+    -- Implementiation of the RISCV ABI calling convention.+    -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)+    -- Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)+    -- Still have GP regs, and we want to pass an GP argument.+    passArguments (gpReg : gpRegs) fpRegs ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      -- RISCV64 Integer Calling Convention: "When passed in registers or on the+      -- stack, integer scalars narrower than XLEN bits are widened according to+      -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."+      let w = formatToWidth format+          assignArg =+            if hint == SignedHint+              then+                COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)+                  `consOL` signExtend w W64 r gpReg+              else+                toOL+                  [ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r),+                    MOV (OpReg w gpReg) (OpReg w r)+                  ]+          accumCode' =+            accumCode+              `appOL` code_r+              `appOL` assignArg+      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- Still have FP regs, and we want to pass an FP argument.+    passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords 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 gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'++    -- No mor regs left to pass. Must pass on stack.+    passArguments [] [] ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            if hint == SignedHint+              then+                code_r+                  `appOL` signExtend w W64 r tmpReg+                  `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str+              else+                code_r+                  `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.+    passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' =+            accumCode+              `appOL` code_r+              `snocOL` ann (text "Pass fp argument in gpReg: " <> ppr r) mov+      passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'+    passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock+    readResults _ _ [] _ accumCode = return 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 (CmmLocal dst)+          format = cmmTypeFormat rep+          w = cmmRegWidth (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)+            `appOL`+            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations+            truncateReg W64 w r_dst+genCCall (PrimTarget mop) dest_regs arg_regs = do+  case mop of+    MO_F32_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    MO_F64_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    -- 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)+    -- Optional MachOps+    -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config+    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+    MO_VS_Quot {} -> unsupported mop+    MO_VS_Rem {} -> unsupported mop+    MO_VU_Quot {} -> unsupported mop+    MO_VU_Rem {} -> unsupported mop+    MO_I64X2_Min -> unsupported mop+    MO_I64X2_Max -> unsupported mop+    MO_W64X2_Min -> unsupported mop+    MO_W64X2_Max -> unsupported mop+    -- Memory Ordering+    -- The related C functions are:+    -- #include <stdatomic.h>+    -- atomic_thread_fence(memory_order_acquire);+    -- atomic_thread_fence(memory_order_release);+    -- atomic_thread_fence(memory_order_seq_cst);+    MO_AcquireFence -> pure (unitOL (FENCE FenceRead FenceReadWrite))+    MO_ReleaseFence -> pure (unitOL (FENCE FenceReadWrite FenceWrite))+    MO_SeqCstFence -> pure (unitOL (FENCE FenceReadWrite FenceReadWrite))+    MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)+    -- Prefetch+    MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.++    -- Memory copy/set/move/cmp, with alignment for optimization+    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@(MO_AtomicRead w ord)+      | [p_reg] <- arg_regs,+        [dst_reg] <- dest_regs -> do+          (p, _fmt_p, code_p) <- getSomeReg p_reg+          platform <- getPlatform+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_load_n(&a, __ATOMIC_ACQUIRE);+          -- __atomic_load_n(&a, __ATOMIC_SEQ_CST);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))+                MemOrderAcquire ->+                  toOL+                    [ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceReadWrite),+                      LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+              dst = getRegisterReg platform (CmmLocal dst_reg)+              moDescr = (text . show) mo+              code = code_p `appOL` instrs+          return code+      | otherwise -> panic "mal-formed AtomicRead"+    mo@(MO_AtomicWrite w ord)+      | [p_reg, val_reg] <- arg_regs -> do+          (p, _fmt_p, code_p) <- getSomeReg p_reg+          (val, fmt_val, code_val) <- getSomeReg val_reg+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST);+          -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (STR fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                      FENCE FenceReadWrite FenceReadWrite+                    ]+                MemOrderRelease ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                    ]+                MemOrderAcquire -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo+              moDescr = (text . show) mo+              code =+                code_p+                  `appOL` code_val+                  `appOL` instrs+          pure code+      | otherwise -> panic "mal-formed AtomicWrite"+    MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+    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+    mkCCall name = do+      config <- getConfig+      target <-+        cmmMakeDynamicReference config CallReference+          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    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)+      pure code++{- Note [RISCV64 far jumps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++RISCV64 conditional jump instructions can only encode an offset of +/-4KiB+(12bits) which is usually enough but can be exceeded in edge cases. In these+cases we will replace:++  b.cond <cond> foo++with the sequence:++  b.cond <cond> <lbl_true>+  b <lbl_false>+  <lbl_true>:+  la reg foo+  b reg+  <lbl_false>:++and++  b foo++with the sequence:++  la reg foo+  b reg++Compared to AArch64 the target label is loaded to a register, because+unconditional jump instructions can only address +/-1MiB. The LA+pseudo-instruction will be replaced by up to two real instructions, ensuring+correct addressing.++One could surely find more efficient replacements, taking PC-relative addressing+into account. This could be a future improvement. (As far branches are pretty+rare, one might question and measure the value of such improvement.)++RISCV has many pseudo-instructions which emit more than one real instructions.+Thus, we count the real instructions after the Assembler has seen them.++We make some simplifications in the name of performance which can result in+overestimating jump <-> label offsets:++\* To avoid having to recalculate the label offsets once we replaced a jump we simply+  assume all label jumps will be expanded to a three instruction far jump sequence.+\* For labels associated with a info table we assume the info table is 64byte large.+  Most info tables are smaller than that but it means we don't have to distinguish+  between multiple types of info tables.++In terms of implementation we walk the instruction stream at least once calculating+label offsets, and if we determine during this that the functions body is big enough+to potentially contain out of range jumps we walk the instructions a second time, replacing+out of range jumps with the sequence of instructions described above.++-}++-- | A conditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  skip_lbl_id <- newBlockId+  jmp_lbl_id <- newBlockId++  -- TODO: We can improve this by inverting the condition+  -- but it's not quite trivial since we don't know if we+  -- need to consider float orderings.+  -- So we take the hit of the additional jump in the false+  -- case for now.+  return+    $ toOL+      [ ann (text "Conditional far jump to: " <> ppr far_target)+          $ BCOND cond op1 op2 (TBlock jmp_lbl_id),+        B (TBlock skip_lbl_id),+        NEWBLOCK jmp_lbl_id,+        LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg),+        NEWBLOCK skip_lbl_id+      ]++-- | An unconditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock+genFarJump far_target =+  return+    $ toOL+      [ ann (text "Unconditional far jump to: " <> ppr far_target)+          $ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg)+      ]++-- See Note [RISCV64 far jumps]+data BlockInRange = InRange | NotInRange BlockId++-- See Note [RISCV64 far jumps]+makeFarBranches ::+  Platform ->+  LabelMap RawCmmStatics ->+  [NatBasicBlock Instr] ->+  UniqDSM [NatBasicBlock Instr]+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of RISCV64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks++    -- 2^11, 12 bit immediate with one bit is reserved for the sign+    max_jump_dist = 2 ^ (11 :: Int) - 1 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_size = 5 :: Int+    long_b_jump_size = 2 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (_, []) -> error "RV64:replace_jump"+            (idx, instr' : instrs') ->+              pure (idx, ANN ann instr' : instrs')+        BCOND cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + instr_size instr, fromOL jmp_code)+        B t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genFarJump far_target+              pure (pos + instr_size instr, fromOL jmp_code)+        _ -> pure (pos + instr_size instr, [instr])++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg {}) -> InRange+        (TBlock bid) -> block_in_range m src bid++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing ->+          pprTrace "not in range" (ppr dest_lbl)+            $ NotInRange dest_lbl+        Just dest_pos ->+          if abs (dest_pos - src_pos) < max_jump_dist+            then InRange+            else NotInRange dest_lbl++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =+      let !pos' = pos + infoTblSize_maybe lbl+       in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr = (pos + instr_size instr, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing -> 0 :: Int+        Just _info_static -> max_info_size++    instr_size :: Instr -> Int+    instr_size i = case i of+      COMMENT {} -> 0+      MULTILINE_COMMENT {} -> 0+      ANN _ instr -> instr_size instr+      LOCATION {} -> 0+      DELTA {} -> 0+      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)+      NEWBLOCK {} -> panic "mkFarBranched - Unexpected"+      LDATA {} -> panic "mkFarBranched - Unexpected"+      PUSH_STACK_FRAME -> 4+      POP_STACK_FRAME -> 4+      ADD {} -> 1+      MUL {} -> 1+      MULH {} -> 1+      NEG {} -> 1+      DIV {} -> 1+      REM {} -> 1+      REMU {} -> 1+      SUB {} -> 1+      DIVU {} -> 1+      AND {} -> 1+      OR {} -> 1+      SRA {} -> 1+      XOR {} -> 1+      SLL {} -> 1+      SRL {} -> 1+      MOV {} -> 2+      ORI {} -> 1+      XORI {} -> 1+      CSET {} -> 2+      STR {} -> 1+      LDR {} -> 3+      LDRU {} -> 1+      FENCE {} -> 1+      FCVT {} -> 1+      FABS {} -> 1+      FMIN {} -> 1+      FMAX {} -> 1+      FMA {} -> 1+      -- estimate the subsituted size for jumps to lables+      -- jumps to registers have size 1+      BCOND {} -> long_bc_jump_size+      B (TBlock _) -> long_b_jump_size+      B (TReg _) -> 1+      J op -> instr_size (B op)+      BL _ _ -> 1+      J_TBL {} -> 1
+ GHC/CmmToAsm/RV64/Cond.hs view
@@ -0,0 +1,42 @@+module GHC.CmmToAsm.RV64.Cond+  ( Cond (..),+  )+where++import GHC.Prelude hiding (EQ)++-- | Condition codes.+--+-- Used in conditional branches and bit setters. According to the available+-- instruction set, some conditions are encoded as their negated opposites. I.e.+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.+data Cond+  = -- | int and float+    EQ+  | -- | int and float+    NE+  | -- | signed less than+    SLT+  | -- | signed less than or equal+    SLE+  | -- | signed greater than or equal+    SGE+  | -- | signed greater than+    SGT+  | -- | unsigned less than+    ULT+  | -- | unsigned less than or equal+    ULE+  | -- | unsigned greater than or equal+    UGE+  | -- | unsigned greater than+    UGT+  | -- | floating point instruction @flt@+    FLT+  | -- | floating point instruction @fle@+    FLE+  | -- | floating point instruction @fge@+    FGE+  | -- | floating point instruction @fgt@+    FGT+  deriving (Eq, Show)
+ GHC/CmmToAsm/RV64/Instr.hs view
@@ -0,0 +1,868 @@+-- All instructions will be rendered eventually. Thus, there's no benefit in+-- being lazy in data types.+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.RV64.Instr where++import Data.Maybe+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Instr (RegUsage (..))+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Data.FastString (LexicalFastString)+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Types.Unique.DSM+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Stack frame header size in bytes.+--+-- The stack frame header is made of the values that are always saved+-- (regardless of the context.) It consists of the saved return address and a+-- pointer to the previous frame. Thus, its size is two stack frame slots which+-- equals two addresses/words (2 * 8 byte).+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * spillSlotSize++-- | 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 =+  ( (ncgSpillPreallocSize config - stackFrameHeaderSize)+      `div` spillSlotSize+  )+    - 1++-- | Convert a spill slot number to a *byte* offset.+spillSlotToOffset :: Int -> Int+spillSlotToOffset slot =+  stackFrameHeaderSize + spillSlotSize * slot++instance Outputable RegUsage where+  ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++-- | 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>]+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  ANN _ i -> regUsageOfInstr platform i+  COMMENT {} -> usage ([], [])+  MULTILINE_COMMENT {} -> usage ([], [])+  PUSH_STACK_FRAME -> usage ([], [])+  POP_STACK_FRAME -> usage ([], [])+  LOCATION {} -> usage ([], [])+  DELTA {} -> usage ([], [])+  ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  NEG dst src -> usage (regOp src, regOp dst)+  MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOV dst src -> usage (regOp src, regOp dst)+  -- ORI's third operand is always an immediate+  ORI dst src1 _ -> usage (regOp src1, regOp dst)+  XORI dst src1 _ -> usage (regOp src1, regOp dst)+  J_TBL _ _ t -> usage ([t], [])+  J t -> usage (regTarget t, [])+  B t -> usage (regTarget t, [])+  BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, [])+  BL t ps -> usage (t : ps, callerSavedRegisters)+  CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst)+  STR _ src dst -> usage (regOp src ++ regOp dst, [])+  LDR _ dst src -> usage (regOp src, regOp dst)+  LDRU _ dst src -> usage (regOp src, regOp dst)+  FENCE _ _ -> usage ([], [])+  FCVT _variant dst src -> usage (regOp src, regOp dst)+  FABS dst src -> usage (regOp src, regOp dst)+  FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMA _ dst src1 src2 src3 ->+    usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr+  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 :: ([Reg], [Reg]) -> RegUsage+    usage (srcRegs, dstRegs) =+      RU+        (map mkFmt $ filter (interesting platform) srcRegs)+        (map mkFmt $ filter (interesting platform) dstRegs)++      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+      -- As the RISCV64 NCG does not currently support SIMD registers,+      -- this simple logic is OK.+    mkFmt r = RegWithFormat r fmt+      where+        fmt = case cls of+                RcInteger -> II64+                RcFloat   -> FF64+                RcVector  -> sorry "The RISCV64 NCG does not (yet) support vectors; please use -fllvm."+        cls = case r of+                RegVirtual vr -> classOfVirtualReg (platformArch platform) vr+                RegReal rr -> classOfRealReg rr++    regAddr :: AddrMode -> [Reg]+    regAddr (AddrRegImm r1 _imm) = [r1]+    regAddr (AddrReg r1) = [r1]++    regOp :: Operand -> [Reg]+    regOp (OpReg _w r1) = [r1]+    regOp (OpAddr a) = regAddr a+    regOp (OpImm _imm) = []++    regTarget :: Target -> [Reg]+    regTarget (TBlock _bid) = []+    regTarget (TReg r1) = [r1]++    -- Is this register interesting for the register allocator?+    interesting :: Platform -> Reg -> Bool+    interesting _ (RegVirtual _) = True+    interesting platform (RegReal (RealRegSingle i)) = freeReg platform i++-- | Caller-saved registers (according to calling convention)+--+-- These registers may be clobbered after a jump.+callerSavedRegisters :: [Reg]+callerSavedRegisters =+  [regSingle raRegNo]+    ++ map regSingle [t0RegNo .. t2RegNo]+    ++ map regSingle [a0RegNo .. a7RegNo]+    ++ map regSingle [t3RegNo .. t6RegNo]+    ++ map regSingle [ft0RegNo .. ft7RegNo]+    ++ map regSingle [fa0RegNo .. fa7RegNo]++-- | Apply a given mapping to all the register references in this instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+  ANN d i -> ANN d (patchRegsOfInstr i env)+  COMMENT {} -> instr+  MULTILINE_COMMENT {} -> instr+  PUSH_STACK_FRAME -> instr+  POP_STACK_FRAME -> instr+  LOCATION {} -> instr+  DELTA {} -> instr+  ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)+  MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)+  NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)+  MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3)+  DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3)+  REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3)+  REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3)+  SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3)+  DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3)+  AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)+  OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3)+  SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3)+  XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3)+  SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3)+  SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3)+  MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)+  -- o3 cannot be a register for ORI (always an immediate)+  ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3)+  XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3)+  J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+  J t -> J (patchTarget t)+  B t -> B (patchTarget t)+  BL t ps -> BL (patchReg t) ps+  BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)+  CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c+  STR f o1 o2 -> STR f (patchOp o1) (patchOp o2)+  LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)+  LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2)+  FENCE o1 o2 -> FENCE o1 o2+  FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2)+  FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)+  FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)+  FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)+  FMA s o1 o2 o3 o4 ->+    FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+  _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr+  where+    patchOp :: Operand -> Operand+    patchOp (OpReg w r) = OpReg w (env r)+    patchOp (OpAddr a) = OpAddr (patchAddr a)+    patchOp opImm = opImm++    patchTarget :: Target -> Target+    patchTarget (TReg r) = TReg (env r)+    patchTarget tBlock = tBlock++    patchAddr :: AddrMode -> AddrMode+    patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm+    patchAddr (AddrReg r) = AddrReg (env r)++    patchReg :: Reg -> Reg+    patchReg = env++-- | 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+  J_TBL {} -> True+  J {} -> True+  B {} -> True+  BL {} -> True+  BCOND {} -> True+  _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    J (TBlock target) -> bid == target+    B (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this (potential) 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)+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    J (TBlock bid) -> J (TBlock (patchF bid))+    B (TBlock bid) -> B (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- Note [RISCV64 Spills and Reloads]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading+-- registers. The load and store instructions of RISCV64 address with a signed+-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case.+--+-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a+-- single load/store instruction. There are offsets to sp (not to be confused+-- with STG's SP!) which need a register to be calculated.+--+-- Using sp to compute the offset would 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.+--+-- So, we reserve one register (TMP) for this purpose (and other, unrelated+-- intermediate operations.) See Note [The made-up RISCV64 TMP (IP) register]++-- | Generate instructions to spill a register into a spill slot.+mkSpillInstr ::+  (HasCallStack) =>+  NCGConfig ->+  -- | register to spill+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkStrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkStrSpImm imm =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Spill: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Spill: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkStrTmp =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))++    off = spillSlotToOffset slot++-- | Generate instructions to load a register from a spill slot.+mkLoadInstr ::+  NCGConfig ->+  -- | register to load+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkLdrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkLdrSpImm imm =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Reload: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Reload: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkLdrTmp =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))++    off = spillSlotToOffset 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 desc instr+  where+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst+    instr = MOV (operandFromReg dst) (operandFromReg src)++-- | Take the source and destination from this (potential) reg -> reg move instruction+--+-- We have to be a bit careful here: A `MOV` can also mean an implicit+-- conversion. This case is filtered out.+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr = pure . B . TBlock++-- | Decrement @sp@ to allocate stack space.+--+-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes).+-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not+-- to be confused with the STG stack pointer.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform = moveSp . negate++-- | Increment SP to deallocate stack space.+--+-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes).+-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to+-- be confused with the STG stack pointer.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform = moveSp++moveSp :: Int -> [Instr]+moveSp n+  | n == 0 = []+  | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n))+  | otherwise =+      -- This ends up in three effective instructions. We could get away with+      -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However,+      -- this way is likely less surprising.+      [ ANN desc (MOV tmp (OpImm (ImmInt n))),+        ADD sp sp tmp+      ]+  where+    desc = text "Move SP:" <+> int n++--+-- See Note [extra spill slots] in X86/Instr.hs+--+allocMoreStack ::+  Platform ->+  Int ->+  NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr ->+  UniqDSM (NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr, [(BlockId, BlockId)])+allocMoreStack _ _ top@(CmmData _ _) = return (top, [])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+  let entries = entryBlocks proc++  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++  let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where+          x = slots * spillSlotSize -- sp delta+      alloc = mkStackAllocInstr platform delta+      dealloc = mkStackDeallocInstr platform delta++      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 _ e -> insert_dealloc e 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+  return (CmmProc info lbl live (ListGraph new_code), retargetList)++data Instr+  = -- | Comment pseudo-op+    COMMENT SDoc+  | -- | Multi-line comment pseudo-op+    MULTILINE_COMMENT SDoc+  | -- | Annotated instruction. Should print <instr> # <doc>+    ANN SDoc Instr+  | -- | Location pseudo-op @.loc@ (file, line, col, name)+    LOCATION Int Int Int LexicalFastString+  | -- | Static data spat out during code generation.+    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+  | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP).+    PUSH_STACK_FRAME+  | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`.+    POP_STACK_FRAME+  | -- | Arithmetic addition (both integer and floating point)+    --+    -- @rd = rs1 + rs2@+    ADD Operand Operand Operand+  | -- | Arithmetic subtraction (both integer and floating point)+    --+    -- @rd = rs1 - rs2@+    SUB Operand Operand Operand+  | -- | Logical AND (integer only)+    --+    -- @rd = rs1 & rs2@+    AND Operand Operand Operand+  | -- | Logical OR (integer only)+    --+    -- @rd = rs1 | rs2@+    OR Operand Operand Operand+  | -- | Logical left shift (zero extened, integer only)+    --+    -- @rd = rs1 << rs2@+    SLL Operand Operand Operand+  | -- | Logical right shift (zero extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRL Operand Operand Operand+  | -- | Arithmetic right shift (sign-extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRA Operand Operand Operand+  | -- | Store to memory (both, integer and floating point)+    STR Format Operand Operand+  | -- | Load from memory (sign-extended, integer and floating point)+    LDR Format Operand Operand+  | -- | Load from memory (unsigned, integer and floating point)+    LDRU Format Operand Operand+  | -- | Arithmetic multiplication (both, integer and floating point)+    --+    -- @rd = rn × rm@+    MUL Operand Operand Operand+  | -- | Negation (both, integer and floating point)+    --+    -- @rd = -op2@+    NEG Operand Operand+  | -- | Division (both, integer and floating point)+    --+    -- @rd = rn ÷ rm@+    DIV Operand Operand Operand+  | -- | Remainder (integer only, signed)+    --+    -- @rd = rn % rm@+    REM Operand Operand Operand --+  | -- | Remainder (integer only, unsigned)+    --+    -- @rd = |rn % rm|@+    REMU Operand Operand Operand+  | -- | High part of a multiplication that doesn't fit into 64bits (integer only)+    --+    -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@.+    MULH Operand Operand Operand+  | -- | Unsigned division (integer only)+    --+    -- @rd = |rn ÷ rm|@+    DIVU Operand Operand Operand+  | -- | XOR (integer only)+    --+    -- @rd = rn ⊕ op2@+    XOR Operand Operand Operand+  | -- | ORI with immediate (integer only)+    --+    -- @rd = rn | op2@+    ORI Operand Operand Operand+  | -- | OR with immediate (integer only)+    --+    -- @rd = rn ⊕ op2@+    XORI Operand Operand Operand+  | -- | Move to register (integer and floating point)+    --+    -- @rd = rn@  or  @rd = #imm@+    MOV Operand Operand+  | -- | Pseudo-op for conditional setting of a register.+    --+    -- @if(o2 cond o3) op <- 1 else op <- 0@+    CSET Operand Operand Operand Cond+    -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others.+  | J Target+  | -- | A jump instruction with data for switch/jump tables+    J_TBL [Maybe BlockId] (Maybe CLabel) Reg+  | -- | Unconditional jump (no linking)+    B Target+  | -- | Unconditional jump, links return address (sets @ra@/@x1@)+    BL Reg [Reg]+  | -- | branch with condition (integer only)+    BCOND Cond Operand Operand Target+  | -- | Fence instruction+    --+    -- Memory barrier.+    FENCE FenceType FenceType+  | -- | Floating point conversion+    FCVT FcvtVariant Operand Operand+  | -- | Floating point ABSolute value+    FABS Operand Operand++  | -- | Min+    -- dest = min(r1)+    FMIN Operand Operand Operand+  | -- | Max+    FMAX Operand Operand Operand++  | -- | Floating-point fused multiply-add instructions+    --+    -- - fmadd : d =   r1 * r2 + r3+    -- - fnmsub: d =   r1 * r2 - r3+    -- - fmsub : d = - r1 * r2 + r3+    -- - fnmadd: d = - r1 * r2 - r3+    FMA FMASign Operand Operand Operand Operand++-- | Operand of a FENCE instruction (@r@, @w@ or @rw@)+data FenceType = FenceRead | FenceWrite | FenceReadWrite++-- | Variant of a floating point conversion instruction+data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt++instrCon :: Instr -> String+instrCon i =+  case i of+    COMMENT {} -> "COMMENT"+    MULTILINE_COMMENT {} -> "COMMENT"+    ANN {} -> "ANN"+    LOCATION {} -> "LOCATION"+    LDATA {} -> "LDATA"+    NEWBLOCK {} -> "NEWBLOCK"+    DELTA {} -> "DELTA"+    PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME"+    POP_STACK_FRAME {} -> "POP_STACK_FRAME"+    ADD {} -> "ADD"+    OR {} -> "OR"+    MUL {} -> "MUL"+    NEG {} -> "NEG"+    DIV {} -> "DIV"+    REM {} -> "REM"+    REMU {} -> "REMU"+    MULH {} -> "MULH"+    SUB {} -> "SUB"+    DIVU {} -> "DIVU"+    AND {} -> "AND"+    SRA {} -> "SRA"+    XOR {} -> "XOR"+    SLL {} -> "SLL"+    SRL {} -> "SRL"+    MOV {} -> "MOV"+    ORI {} -> "ORI"+    XORI {} -> "ORI"+    STR {} -> "STR"+    LDR {} -> "LDR"+    LDRU {} -> "LDRU"+    CSET {} -> "CSET"+    J_TBL {} -> "J_TBL"+    J {} -> "J"+    B {} -> "B"+    BL {} -> "BL"+    BCOND {} -> "BCOND"+    FENCE {} -> "FENCE"+    FCVT {} -> "FCVT"+    FABS {} -> "FABS"+    FMIN {} -> "FMIN"+    FMAX {} -> "FMAX"+    FMA variant _ _ _ _ ->+      case variant of+        FMAdd -> "FMADD"+        FMSub -> "FMSUB"+        FNMAdd -> "FNMADD"+        FNMSub -> "FNMSUB"++data Target+  = TBlock BlockId+  | TReg Reg++data Operand+  = -- | register+    OpReg Width Reg+  | -- | immediate value+    OpImm Imm+  | -- | memory reference+    OpAddr AddrMode+  deriving (Eq, Show)++operandFromReg :: Reg -> Operand+operandFromReg = OpReg W64++operandFromRegNo :: RegNo -> Operand+operandFromRegNo = operandFromReg . regSingle++zero, ra, sp, gp, tp, fp, tmp :: Operand+zero = operandFromReg zeroReg+ra = operandFromReg raReg+sp = operandFromReg spMachReg+gp = operandFromRegNo 3+tp = operandFromRegNo 4+fp = operandFromRegNo 8+tmp = operandFromReg tmpReg++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 = operandFromRegNo x0RegNo+x1 = operandFromRegNo 1+x2 = operandFromRegNo 2+x3 = operandFromRegNo 3+x4 = operandFromRegNo 4+x5 = operandFromRegNo x5RegNo+x6 = operandFromRegNo 6+x7 = operandFromRegNo x7RegNo++x8 = operandFromRegNo 8++x9 = operandFromRegNo 9++x10 = operandFromRegNo x10RegNo++x11 = operandFromRegNo 11++x12 = operandFromRegNo 12++x13 = operandFromRegNo 13++x14 = operandFromRegNo 14++x15 = operandFromRegNo 15++x16 = operandFromRegNo 16++x17 = operandFromRegNo x17RegNo++x18 = operandFromRegNo 18++x19 = operandFromRegNo 19++x20 = operandFromRegNo 20++x21 = operandFromRegNo 21++x22 = operandFromRegNo 22++x23 = operandFromRegNo 23++x24 = operandFromRegNo 24++x25 = operandFromRegNo 25++x26 = operandFromRegNo 26++x27 = operandFromRegNo 27++x28 = operandFromRegNo x28RegNo++x29 = operandFromRegNo 29++x30 = operandFromRegNo 30++x31 = operandFromRegNo x31RegNo++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 = operandFromRegNo d0RegNo+d1 = operandFromRegNo 33+d2 = operandFromRegNo 34+d3 = operandFromRegNo 35+d4 = operandFromRegNo 36+d5 = operandFromRegNo 37+d6 = operandFromRegNo 38+d7 = operandFromRegNo d7RegNo++d8 = operandFromRegNo 40++d9 = operandFromRegNo 41++d10 = operandFromRegNo d10RegNo++d11 = operandFromRegNo 43++d12 = operandFromRegNo 44++d13 = operandFromRegNo 45++d14 = operandFromRegNo 46++d15 = operandFromRegNo 47++d16 = operandFromRegNo 48++d17 = operandFromRegNo d17RegNo++d18 = operandFromRegNo 50++d19 = operandFromRegNo 51++d20 = operandFromRegNo 52++d21 = operandFromRegNo 53++d22 = operandFromRegNo 54++d23 = operandFromRegNo 55++d24 = operandFromRegNo 56++d25 = operandFromRegNo 57++d26 = operandFromRegNo 58++d27 = operandFromRegNo 59++d28 = operandFromRegNo 60++d29 = operandFromRegNo 61++d30 = operandFromRegNo 62++d31 = operandFromRegNo d31RegNo++fitsIn12bitImm :: (Num a, Ord a) => a -> Bool+fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit++intMin12bit :: (Num a) => a+intMin12bit = -2048++intMax12bit :: (Num a) => a+intMax12bit = 2047++fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool+fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1)++isNbitEncodeable :: Int -> Integer -> Bool+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++isEncodeableInWidth :: Width -> Integer -> Bool+isEncodeableInWidth = isNbitEncodeable . widthInBits++isIntOp :: Operand -> Bool+isIntOp = not . isFloatOp++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ reg) | isFloatReg reg = True+isFloatOp _ = False++isFloatReg :: Reg -> Bool+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True+isFloatReg (RegVirtual (VirtualRegD _)) = True+isFloatReg _ = False
+ GHC/CmmToAsm/RV64/Ppr.hs view
@@ -0,0 +1,719 @@+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Platform+import GHC.Platform.Reg+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Types.Unique (getUnique, pprUniqueAlways)+import GHC.Utils.Outputable+import GHC.Utils.Panic++pprNatCmmDecl :: forall doc. (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++      pprProcAlignment :: doc+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)+   in pprProcAlignment+        $$ case topInfoTable proc of+          Nothing ->+            -- special case for code without info table:+            pprSectionAlign config (Section Text lbl)+              $$+              -- do not+              -- pprProcAlignment config $$+              pprLabel platform lbl+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed+              $$ 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 $$+              ( if platformHasSubsectionsViaSymbols platform+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')+                  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 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) => Alignment -> doc+pprAlign alignment =+  -- "The .align directive for RISC-V is an alias to .p2align, which aligns to a+  -- power of two, so .align 2 means align to 4 bytes. Because the definition of+  -- the .align directive varies by architecture, it is recommended to use the+  -- unambiguous .p2align or .balign directives instead."+  -- (https://github.com/riscv-non-isa/riscv-asm-manual/blob/main/riscv-asm.md#-align)+  line $ text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+--+-- Currently, this always aligns to a full machine word (8 byte.) A future+-- improvement could be to really do this per section type (though, it's+-- probably not a big gain.)+pprAlignForSection :: (IsDoc doc) => SectionType -> doc+pprAlignForSection _seg = pprAlign . mkAlignment $ 8++-- | Print section header and appropriate alignment for that section.+--+-- This will e.g. emit a header like:+--+--     .section .text+--     .balign 8+pprSectionAlign :: (IsDoc doc) => NCGConfig -> Section -> doc+pprSectionAlign _config (Section (OtherSection _) _) =+  panic "RV64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+  line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++pprProcEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Procedure name+  CLabel ->+  doc+pprProcEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon++pprBlockEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Block name+  CLabel ->+  doc+pprBlockEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon++-- | Output the ELF .size directive (if needed.)+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> asmLbl <> text ", .-" <> asmLbl+  where+    asmLbl = pprAsmLabel platform lbl+pprSizeDecl _ _ = 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))+    $$ 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+    -- TODO: Check if we can  filter more instructions here.+    -- TODO: Shouldn't this be a more general check on a higher level?+    -- 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+          $$ ppWhen+            (ncgDwarfEnabled config)+            (line (pprBlockEndLabel platform info_lbl))+    -- 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)+-- TODO: AFAIK there no Darwin for RISCV, so we may consider to simplify this.+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 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" <> pprDataImm platform imm]+    ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]+    ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm]+    ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm 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)++-- | Pretty print an immediate value in the @data@ section+--+-- This does not include any checks. We rely on the Assembler to check for+-- errors. Use `pprOpImm` for immediates in instructions (operands.)+pprDataImm :: (IsLine doc) => Platform -> Imm -> doc+pprDataImm _ (ImmInt i) = int i+pprDataImm _ (ImmInteger i) = integer i+pprDataImm p (ImmCLbl l) = pprAsmLabel p l+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i+pprDataImm _ (ImmLit s) = ftext s+pprDataImm _ (ImmFloat f) = float (fromRational f)+pprDataImm _ (ImmDouble d) = double (fromRational d)+pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b+pprDataImm p (ImmConstantDiff a b) =+  pprDataImm p a+    <> char '-'+    <> lparen+    <> pprDataImm p b+    <> rparen++-- | Comment @c@ with @# c@+asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++-- | Commen @c@ with @// c@+asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++-- | Comment @c@ with @/* c */@ (multiline comment)+asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c = text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+--+-- The kinds of immediates we can use here is pretty limited: RISCV doesn't+-- support index expressions (as e.g. Aarch64 does.) Floating points need to+-- fit in range. As we don't need them, forbit them to save us from future+-- troubles.+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform im = case im of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  _ -> pprPanic "RV64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands" <> colon <+> (text . show) im)++-- | Negate integer immediate operand+--+-- This function is partial and will panic if the operand is not an integer.+negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "RV64.negOp" (text $ show op)++-- | Pretty print an operand+pprOp :: (IsLine doc) => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r -> pprReg w r+  OpImm im -> pprOpImm plat im+  OpAddr (AddrRegImm r1 im) -> pprOpImm plat im <> char '(' <> pprReg W64 r1 <> char ')'+  OpAddr (AddrReg r1) -> text "0(" <+> pprReg W64 r1 <+> char ')'++-- | Pretty print register with calling convention name+--+-- This representation makes it easier to reason about the emitted assembly+-- code.+pprReg :: forall doc. (IsLine doc) => Width -> Reg -> doc+pprReg w r = case r of+  RegReal (RealRegSingle i) -> ppr_reg_no i+  -- virtual regs should not show up, but this is helpful for debugging.+  RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u+  RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u+  _ -> pprPanic "RiscV64.pprReg" (text (show r) <+> ppr w)+  where+    ppr_reg_no :: Int -> doc+    -- General Purpose Registers+    ppr_reg_no 0 = text "zero"+    ppr_reg_no 1 = text "ra"+    ppr_reg_no 2 = text "sp"+    ppr_reg_no 3 = text "gp"+    ppr_reg_no 4 = text "tp"+    ppr_reg_no 5 = text "t0"+    ppr_reg_no 6 = text "t1"+    ppr_reg_no 7 = text "t2"+    ppr_reg_no 8 = text "s0"+    ppr_reg_no 9 = text "s1"+    ppr_reg_no 10 = text "a0"+    ppr_reg_no 11 = text "a1"+    ppr_reg_no 12 = text "a2"+    ppr_reg_no 13 = text "a3"+    ppr_reg_no 14 = text "a4"+    ppr_reg_no 15 = text "a5"+    ppr_reg_no 16 = text "a6"+    ppr_reg_no 17 = text "a7"+    ppr_reg_no 18 = text "s2"+    ppr_reg_no 19 = text "s3"+    ppr_reg_no 20 = text "s4"+    ppr_reg_no 21 = text "s5"+    ppr_reg_no 22 = text "s6"+    ppr_reg_no 23 = text "s7"+    ppr_reg_no 24 = text "s8"+    ppr_reg_no 25 = text "s9"+    ppr_reg_no 26 = text "s10"+    ppr_reg_no 27 = text "s11"+    ppr_reg_no 28 = text "t3"+    ppr_reg_no 29 = text "t4"+    ppr_reg_no 30 = text "t5"+    ppr_reg_no 31 = text "t6"+    -- Floating Point Registers+    ppr_reg_no 32 = text "ft0"+    ppr_reg_no 33 = text "ft1"+    ppr_reg_no 34 = text "ft2"+    ppr_reg_no 35 = text "ft3"+    ppr_reg_no 36 = text "ft4"+    ppr_reg_no 37 = text "ft5"+    ppr_reg_no 38 = text "ft6"+    ppr_reg_no 39 = text "ft7"+    ppr_reg_no 40 = text "fs0"+    ppr_reg_no 41 = text "fs1"+    ppr_reg_no 42 = text "fa0"+    ppr_reg_no 43 = text "fa1"+    ppr_reg_no 44 = text "fa2"+    ppr_reg_no 45 = text "fa3"+    ppr_reg_no 46 = text "fa4"+    ppr_reg_no 47 = text "fa5"+    ppr_reg_no 48 = text "fa6"+    ppr_reg_no 49 = text "fa7"+    ppr_reg_no 50 = text "fs2"+    ppr_reg_no 51 = text "fs3"+    ppr_reg_no 52 = text "fs4"+    ppr_reg_no 53 = text "fs5"+    ppr_reg_no 54 = text "fs6"+    ppr_reg_no 55 = text "fs7"+    ppr_reg_no 56 = text "fs8"+    ppr_reg_no 57 = text "fs9"+    ppr_reg_no 58 = text "fs10"+    ppr_reg_no 59 = text "fs11"+    ppr_reg_no 60 = text "ft8"+    ppr_reg_no 61 = text "ft9"+    ppr_reg_no 62 = text "ft10"+    ppr_reg_no 63 = text "ft11"+    ppr_reg_no i+      | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)+      | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)+      -- no support for widths > W64.+      | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)++-- | Single precission `Operand` (floating-point)+isSingleOp :: Operand -> Bool+isSingleOp (OpReg W32 _) = True+isSingleOp _ = False++-- | Double precission `Operand` (floating-point)+isDoubleOp :: Operand -> Bool+isDoubleOp (OpReg W64 _) = True+isDoubleOp _ = False++-- | `Operand` is an immediate value+isImmOp :: Operand -> Bool+isImmOp (OpImm _) = True+isImmOp _ = False++-- | `Operand` is an immediate @0@ value+isImmZero :: Operand -> Bool+isImmZero (OpImm (ImmFloat 0)) = True+isImmZero (OpImm (ImmDouble 0)) = True+isImmZero (OpImm (ImmInt 0)) = True+isImmZero _ = False++-- | `Target` represents a label+isLabel :: Target -> Bool+isLabel (TBlock _) = True+isLabel _ = False++-- | Get the pretty-printed label from a `Target`+--+-- This function is partial and will panic if the `Target` is not a label.+getLabel :: (IsLine doc) => Platform -> Target -> doc+getLabel platform (TBlock bid) = pprBlockId platform bid+  where+    pprBlockId :: (IsLine doc) => Platform -> BlockId -> doc+    pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+getLabel _platform _other = panic "Cannot turn this into a label"++-- | Pretty-print an `Instr`+--+-- This function is partial and will panic if the `Instr` is not supported. This+-- can happen due to invalid operands or unexpected meta instructions.+pprInstr :: (IsDoc doc) => Platform -> Instr -> doc+pprInstr platform instr = case instr of+  -- 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+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _ -> panic "pprInstr: LDATA"+  PUSH_STACK_FRAME ->+    lines_+      [ text "\taddi sp, sp, -16",+        text "\tsd x1, 8(sp)", -- store RA+        text "\tsd x8, 0(sp)", -- store FP/s0+        text "\taddi x8, sp, 16"+      ]+  POP_STACK_FRAME ->+    lines_+      [ text "\tld x8, 0(sp)", -- restore FP/s0+        text "\tld x1, 8(sp)", -- restore RA+        text "\taddi sp, sp, 16"+      ]+  ADD o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    -- This case is used for sign extension: SEXT.W op+    | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddiw") o1 o2 o3+    | otherwise -> op3 (text "\tadd") o1 o2 o3+  MUL o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | otherwise -> op3 (text "\tmul") o1 o2 o3+  MULH o1 o2 o3 -> op3 (text "\tmulh") o1 o2 o3+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+  NEG o1 o2 -> op2 (text "\tneg") o1 o2+  DIV o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 ->+        -- TODO: This must (likely) be refined regarding width+        op3 (text "\tfdiv." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+  DIV o1 o2 o3 -> op3 (text "\tdiv") o1 o2 o3+  REM o1 o2 o3+    | isFloatOp o1 || isFloatOp o2 || isFloatOp o3 ->+        panic "pprInstr - REM not implemented for floats (yet)"+  REM o1 o2 o3 -> op3 (text "\trem") o1 o2 o3+  REMU o1 o2 o3 -> op3 (text "\tremu") o1 o2 o3+  SUB o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | isImmOp o3 -> op3 (text "\taddi") o1 o2 (negOp o3)+    | otherwise -> op3 (text "\tsub") o1 o2 o3+  DIVU o1 o2 o3 -> op3 (text "\tdivu") o1 o2 o3+  AND o1 o2 o3+    | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> op3 (text "\tand") o1 o2 o3+  OR o1 o2 o3 -> op3 (text "\tor") o1 o2 o3+  SRA o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3+  SRA o1 o2 o3 -> op3 (text "\tsra") o1 o2 o3+  XOR o1 o2 o3 -> op3 (text "\txor") o1 o2 o3+  SLL o1 o2 o3 -> op3 (text "\tsll") o1 o2 o3+  SRL o1 o2 o3 -> op3 (text "\tsrl") o1 o2 o3+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.d") o1 o2 -- fmv.d rd, rs is pseudo op fsgnj.d rd, rs, rs+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.s") o1 o2 -- fmv.s rd, rs is pseudo op fsgnj.s rd, rs, rs+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tfcvt.d.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tfcvt.s.w") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tfmv.w.x") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | isImmOp o2 ->+        -- Surrender! Let the assembler figure out the right expressions with pseudo-op LI.+        lines_ [text "\tli" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0))+  ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3+  XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3+  J o1 -> pprInstr platform (B o1)+  J_TBL _ _ r -> pprInstr platform (B (TReg r))+  B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l+  B (TReg r) -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0"+  BL r _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0"+  BCOND c l r t+    | isLabel t ->+        line $ text "\t" <> pprBcond c <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform t+  BCOND _ _ _ (TReg _) -> panic "RV64.ppr: No conditional branching to registers!"+  CSET o l r c -> case c of+    EQ+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tseqz" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    EQ | isFloatOp l && isFloatOp r -> line $ binOp ("\tfeq." ++ floatOpPrecision platform l r)+    NE+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    NE+      | isFloatOp l && isFloatOp r ->+          lines_+            [ binOp ("\tfeq." ++ floatOpPrecision platform l r),+              text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+            ]+    SLT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    SLE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    ULT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    ULE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    FLT | isFloatOp l && isFloatOp r -> line $ binOp ("\tflt." ++ floatOpPrecision platform l r)+    FLE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfle." ++ floatOpPrecision platform l r)+    FGT | isFloatOp l && isFloatOp r -> line $ binOp ("\tfgt." ++ floatOpPrecision platform l r)+    FGE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfge." ++ floatOpPrecision platform l r)+    x -> pprPanic "RV64.ppr: unhandled CSET conditional" (text (show x) <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l)+    where+      subFor l r+        | (OpImm _) <- r = text "\taddi" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform (negOp r)+        | (OpImm _) <- l = panic "RV64.ppr: Cannot SUB IMM _"+        | otherwise = text "\tsub" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+      sltFor l r+        | (OpImm _) <- r = text "\tslti"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLT IMM _"+        | otherwise = text "\tslt"+      sltuFor l r+        | (OpImm _) <- r = text "\tsltui"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLTU IMM _"+        | otherwise = text "\tsltu"+      binOp :: (IsLine doc) => String -> doc+      binOp op = text op <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+  STR II8 o1 o2 -> op2 (text "\tsb") o1 o2+  STR II16 o1 o2 -> op2 (text "\tsh") o1 o2+  STR II32 o1 o2 -> op2 (text "\tsw") o1 o2+  STR II64 o1 o2 -> op2 (text "\tsd") o1 o2+  STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2+  STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2+  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    lines_+      [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl,+        text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+      ]+  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl+  LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2+  LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2+  LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2+  LDR II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDR FF32 o1 o2 -> op2 (text "\tflw") o1 o2+  LDR FF64 o1 o2 -> op2 (text "\tfld") o1 o2+  LDRU II8 o1 o2 -> op2 (text "\tlbu") o1 o2+  LDRU II16 o1 o2 -> op2 (text "\tlhu") o1 o2+  LDRU II32 o1 o2 -> op2 (text "\tlwu") o1 o2+  -- double words (64bit) cannot be sign extended by definition+  LDRU II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tflw") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tflw") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2+  LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2)+  FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w+  FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT FloatToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2+  FCVT IntToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible integer to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2+  FCVT FloatToInt o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to integer conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2+  FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2+  FMIN o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmin.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmin.d") o1 o2 o3+  FMAX o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmax.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmax.d") o1 o2 o3+  FMA variant d r1 r2 r3 ->+    let fma = case variant of+          FMAdd -> text "\tfmadd" <> dot <> floatPrecission d+          FMSub -> text "\tfmsub" <> dot <> floatPrecission d+          FNMAdd -> text "\tfnmadd" <> dot <> floatPrecission d+          FNMSub -> text "\tfnmsub" <> dot <> floatPrecission d+     in op4 fma d r1 r2 r3+  instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr+  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+    pprFenceType FenceRead = text "r"+    pprFenceType FenceWrite = text "w"+    pprFenceType FenceReadWrite = text "rw"+    floatPrecission o+      | isSingleOp o = text "s"+      | isDoubleOp o = text "d"+      | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)++floatOpPrecision :: Platform -> Operand -> Operand -> String+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision+floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r)++-- | Pretty print a conditional branch+--+-- This function is partial and will panic if the conditional is not supported;+-- i.e. if its floating point related.+pprBcond :: (IsLine doc) => Cond -> doc+pprBcond c = text "b" <> pprCond c+  where+    pprCond :: (IsLine doc) => Cond -> doc+    pprCond c = case c of+      EQ -> text "eq"+      NE -> text "ne"+      SLT -> text "lt"+      SLE -> text "le"+      SGE -> text "ge"+      SGT -> text "gt"+      ULT -> text "ltu"+      ULE -> text "leu"+      UGE -> text "geu"+      UGT -> text "gtu"+      -- BCOND cannot handle floating point comparisons / registers+      _ -> panic $ "RV64.ppr: unhandled BCOND conditional: " ++ show c
+ GHC/CmmToAsm/RV64/RegInfo.hs view
@@ -0,0 +1,41 @@+-- | Minimum viable implementation of jump short-cutting: No short-cutting.+--+-- The functions here simply implement the no-short-cutting case. Implementing+-- the real behaviour would be a great optimization in future.+module GHC.CmmToAsm.RV64.RegInfo+  ( getJumpDestBlockId,+    canShortcut,+    shortcutStatics,+    shortcutJump,+    JumpDest (..),+  )+where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.RV64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++-- | Extract BlockId+--+-- Never `Nothing` for Riscv64 NCG.+getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++-- No `Instr`s can bet shortcut (for now)+canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++-- Identity of the provided `RawCmmStatics`+shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++-- Identity of the provided `Instr`+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ GHC/CmmToAsm/RV64/Regs.hs view
@@ -0,0 +1,245 @@+module GHC.CmmToAsm.RV64.Regs where++import GHC.Cmm+import GHC.Cmm.CLabel (CLabel)+import GHC.CmmToAsm.Format+import GHC.Data.FastString+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Platform.Regs+import GHC.Prelude+import GHC.Types.Unique+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- * Registers++-- | First integer register number. @zero@ register.+x0RegNo :: RegNo+x0RegNo = 0++-- | return address register+x1RegNo, raRegNo :: RegNo+x1RegNo = 1+raRegNo = x1RegNo++x5RegNo, t0RegNo :: RegNo+x5RegNo = 5+t0RegNo = x5RegNo++x7RegNo, t2RegNo :: RegNo+x7RegNo = 7+t2RegNo = x7RegNo++x28RegNo, t3RegNo :: RegNo+x28RegNo = 28+t3RegNo = x28RegNo++-- | Last integer register number. Used as TMP (IP) register.+x31RegNo, t6RegNo, tmpRegNo :: RegNo+x31RegNo = 31+t6RegNo = x31RegNo+tmpRegNo = x31RegNo++-- | First floating point register.+d0RegNo, ft0RegNo :: RegNo+d0RegNo = 32+ft0RegNo = d0RegNo++d7RegNo, ft7RegNo :: RegNo+d7RegNo = 39+ft7RegNo = d7RegNo++-- | Last floating point register.+d31RegNo :: RegNo+d31RegNo = 63++a0RegNo, x10RegNo :: RegNo+x10RegNo = 10+a0RegNo = x10RegNo++a7RegNo, x17RegNo :: RegNo+x17RegNo = 17+a7RegNo = x17RegNo++fa0RegNo, d10RegNo :: RegNo+d10RegNo = 42+fa0RegNo = d10RegNo++fa7RegNo, d17RegNo :: RegNo+d17RegNo = 49+fa7RegNo = d17RegNo++-- Note [The made-up RISCV64 TMP (IP) register]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- RISCV64 has no inter-procedural register in its ABI. However, we need one to+-- make register spills/loads to/from high number slots. I.e. slot numbers that+-- do not fit in a 12bit integer which is used as immediate in the arithmetic+-- operations. Thus, we're marking one additional register (x31) as permanently+-- non-free and call it TMP.+--+-- TMP can be used as temporary register in all operations. Just be aware that+-- it may be clobbered as soon as you loose direct control over it (i.e. using+-- TMP by-passes the register allocation/spilling mechanisms.) It should be fine+-- to use it as temporary register in a MachOp translation as long as you don't+-- rely on its value beyond this limited scope.+--+-- X31 is a caller-saved register. I.e. there are no guarantees about what the+-- callee does with it. That's exactly what we want here.++zeroReg, raReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle x0RegNo+raReg = regSingle 1++-- | Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 2++tmpReg = regSingle tmpRegNo++-- | All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = intRegs ++ fpRegs+  where+    intRegs = [x0RegNo .. x31RegNo]+    fpRegs = [d0RegNo .. d31RegNo]++-- | Registers available to the register allocator.+--+-- These are all registers minus those with a fixed role in RISCV ABI (zero, lr,+-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6,+-- D1..D6.)+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform =+  let isFree = freeReg platform+   in map RealRegSingle $ filter isFree allMachRegNos++-- | Integer argument registers according to the calling convention+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [a0RegNo .. a7RegNo]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo]++-- * Addressing modes++-- | Addressing modes+data AddrMode+  = -- | A register plus some immediate integer, e.g. @8(sp)@ or @-16(sp)@. The+    -- offset needs to fit into 12bits.+    AddrRegImm Reg Imm+  | -- | A register+    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)++-- | Map `CmmLit` to `Imm`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+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 l = panic $ "RV64.Regs.litToImm: no match for " ++ show l++-- == 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+    RcFloat ->+      case vr of+        VirtualRegD {} -> 1+        _other -> 0+    RcVector ->+      case vr of+        VirtualRegV128 {} -> 1+        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr =+  case cls of+    RcInteger ->+      case rr of+        RealRegSingle regNo+          | regNo < d0RegNo+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < d0RegNo+          || regNo > d31RegNo+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > d31RegNo+          -> 1+          | otherwise+          -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+  | not (isFloatFormat format) = VirtualRegI u+  | otherwise =+      case format of+        FF32 -> VirtualRegD u+        FF64 -> VirtualRegD u+        _ -> panic "RV64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+  | i < d0RegNo = RcInteger+  | i > d31RegNo = RcVector+  | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg =+  case classOfRealReg reg of+    RcInteger -> text "blue"+    RcFloat -> text "red"+    RcVector -> text "green"
+ GHC/CmmToAsm/Reg/Graph.hs view
@@ -0,0 +1,486 @@+{-# 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.Format+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.DSM+import GHC.Utils.Misc (seqList, HasDebugCallStack)+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+        -> UniqDSM ( [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,+            HasDebugCallStack)+        => 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+        -> UniqDSM ( [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 platform 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 platform 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 config) 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 platform) 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+        => Platform+        -> [LiveCmmDecl statics instr]+        -> UniqDSM (Color.Graph VirtualReg RegClass RealReg)++buildGraph platform code+ = do+        -- Slurp out the conflicts and reg->reg moves from this code.+        let (conflictList, moveList) =+                unzip $ map (slurpConflicts platform) 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 platform) Color.initGraph conflictBag++        -- Add the coalescences edges to the graph.+        let moveBag+                = unionBags (unionManyBags moveList2)+                            (unionManyBags moveList)++        let graph_coalesce+                = foldr (graphAddCoalesce platform) graph_conflict moveBag++        return  graph_coalesce+++-- | Add some conflict edges to the graph.+--   Conflicts between virtual and real regs are recorded as exclusions.+graphAddConflictSet+        :: Platform+        -> UniqSet RegWithFormat+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddConflictSet platform regs graph+ = let  arch = platformArch platform+        virtuals = takeVirtualRegs regs+        reals    = takeRealRegs regs++        graph1  = Color.addConflicts virtuals (classOfVirtualReg arch) graph+          -- NB: we could add "arch" as argument to functions such as "addConflicts"+          -- and "addExclusion" if it turns out that the partial application+          -- "classOfVirtualReg arch" affects performance.++        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 (classOfVirtualReg arch) r2)+                        graph1+                        [ (vr, rr)+                        | vr <- nonDetEltsUniqSet virtuals+                        , rr <- nonDetEltsUniqSet reals ]+                          -- 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+        :: Platform+        -> (Reg, Reg)+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddCoalesce platform (r1, r2) graph+        | RegReal rr            <- r1+        , RegVirtual vr         <- r2+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph++        | RegReal rr            <- r2+        , RegVirtual vr         <- r1+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph++        | RegVirtual vr1        <- r1+        , RegVirtual vr2        <- r2+        = Color.addCoalesce+                (vr1, classOfVirtualReg arch vr1)+                (vr2, classOfVirtualReg arch 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+        where+          arch = platformArch platform+++-- | 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 platform 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
+ GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -0,0 +1,165 @@++-- | 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)++import Data.List.NonEmpty (NonEmpty (..))++-- 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 $ 0 :| 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]
+ GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -0,0 +1,102 @@+-- | 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.Platform (Platform)+import GHC.Types.Unique (getUnique)+import GHC.Types.Unique.FM+import GHC.Types.Unique.Supply+import GHC.Types.Unique.Set++-- | 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+        => Platform+        -> [LiveCmmDecl statics instr]+        -> UniqSM [LiveCmmDecl statics instr]++regCoalesce platform code+ = do+        let joins       = foldl' unionBags emptyBag+                        $ map (slurpJoinMovs platform) code++        let alloc       = foldl' buildAlloc emptyUFM+                        $ bagToList joins++        let patched     = map (patchEraseLive platform (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+        => Platform+        -> LiveCmmDecl statics instr+        -> Bag (Reg, Reg)++slurpJoinMovs platform 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 platform instr+                , elemUniqSet_Directly (getUnique r1) $ liveDieRead live+                , elemUniqSet_Directly (getUnique 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+
+ GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -0,0 +1,394 @@+-- | 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.Format ( RegWithFormat(..) )+import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Reg.Utils+import GHC.CmmToAsm.Instr+import GHC.Platform.Reg+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+++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.DSM+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform++import Data.Function ( on )+import Data.List (intersectBy, nubBy)+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+        -> UniqDSM+            ([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.+                UDSM $ \us ->++                  -- Run the spiller on all the blocks.+                  let (code', state')     =+                          runState (mapM (regSpill_top platform regSlotMap) code)+                                   (initSpillS us)++                   in DUniqResult+                        ( code'+                        , minusUniqSet slotsFree (mkUniqSet slots)+                        , slotCount+                        , makeSpillStats state')+                        ( stateUS 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 -> UniqSet RegWithFormat-> 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 . regWithFormat_reg)+                                $ 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_             = nubBy ((==) `on` getUnique) rlRead+      rsWritten_          = nubBy ((==) `on` getUnique) rlWritten++  -- if a reg is modified, it appears in both lists, want to undo this..+  let rsModify            = intersectBy ((==) `on` getUnique) rsRead_ rsWritten_+      modified            = mkUniqSet rsModify+      rsRead              = filter (\ r -> not $ elementOfUniqSet r modified) rsRead_+      rsWritten           = filter (\ r -> not $ elementOfUniqSet r modified) rsWritten_+++  -- work out if any of the regs being used are currently being spilled.+  let rsSpillRead         = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsRead+  let rsSpillWritten      = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsWritten+  let rsSpillModify       = filter (\r -> elemUFM (regWithFormat_reg r) regSlotMap) rsModify++  -- rewrite the instr and work out spill code.+  (instr1, prepost1)      <- mapAccumLM (spillRead   platform regSlotMap) instr  rsSpillRead+  (instr2, prepost2)      <- mapAccumLM (spillWrite  platform regSlotMap) instr1 rsSpillWritten+  (instr3, prepost3)      <- mapAccumLM (spillModify platform 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+        => Platform+        -> UniqFM Reg Int+        -> instr+        -> RegWithFormat+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillRead platform regSlotMap instr (RegWithFormat reg fmt)+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr platform reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) 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+        => Platform+        -> UniqFM Reg Int+        -> instr+        -> RegWithFormat+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillWrite platform regSlotMap instr (RegWithFormat reg fmt)+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr platform reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }++         return  ( instr'+                 , ( []+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) 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+        => Platform+        -> UniqFM Reg Int+        -> instr+        -> RegWithFormat+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillModify platform regSlotMap instr (RegWithFormat reg fmt)+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr platform reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) 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+        => Platform -> Reg -> instr -> SpillM (instr, Reg)++patchInstr platform 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 platform reg nReg instr+        return          (instr', nReg)+++patchReg1+        :: Instruction instr+        => Platform -> Reg -> Reg -> instr -> instr++patchReg1 platform old new instr+ = let  patchF r+                | r == old      = new+                | otherwise     = r+   in   patchRegsOfInstr platform instr patchF+++-- Spiller monad --------------------------------------------------------------+-- | State monad for the spill code generator.+type SpillM = State SpillS++-- | Spill code generator state.+data SpillS+        = SpillS+        { -- | Unique supply for generating fresh vregs.+          stateUS       :: DUniqSupply++          -- | Spilled vreg vs the number of times it was loaded, stored.+        , stateSpillSL  :: UniqFM Reg (Reg, Int, Int) }++instance MonadGetUnique SpillM where+  getUniqueM = do+    us <- gets stateUS+    case takeUniqueFromDSupply us of+     (uniq, us')+      -> do modify $ \s -> s { stateUS = us' }+            return uniq+++-- | Create a new spiller state.+initSpillS :: DUniqSupply -> SpillS+initSpillS uniqueSupply+        = SpillS+        { stateUS       = uniqueSupply+        , stateSpillSL  = emptyUFM }+++-- | Allocate a new unique in the spiller monad.+newUnique :: SpillM Unique+newUnique = getUniqueM+++-- | 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))
+ GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -0,0 +1,609 @@+{-# 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.Config+import GHC.CmmToAsm.Reg.Liveness+import GHC.CmmToAsm.Format+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.Misc+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Cmm.Dataflow.Label++import Data.List (nub, 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+        => NCGConfig+        -> LiveCmmDecl statics instr+        -> LiveCmmDecl statics instr++cleanSpills config cmm+        = evalState (cleanSpin config 0 cmm) initCleanS+++-- | Do one pass of cleaning.+cleanSpin+        :: Instruction instr+        => NCGConfig+        -> Int                              -- ^ Iteration number for the cleaner.+        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.+        -> CleanM (LiveCmmDecl statics instr)++cleanSpin config spinCount code+ = do+        -- Initialise count of cleaned spill and reload instructions.+        modify $ \s -> s+                { sCleanedSpillsAcc     = 0+                , sCleanedReloadsAcc    = 0+                , sReloadedBy           = emptyUFM }++        code_forward    <- mapBlockTopM (cleanBlockForward config) 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 config (spinCount + 1) code_backward+++-------------------------------------------------------------------------------+-- | Clean out unneeded reload instructions,+--   while walking forward over the code.+cleanBlockForward+        :: Instruction instr+        => NCGConfig+        -> LiveBasicBlock instr+        -> CleanM (LiveBasicBlock instr)++cleanBlockForward config (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 config 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+        => NCGConfig+        -> 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 config 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 config blockId assoc acc+                 $ li1 : LiveInstr (mkRegRegMoveInstr config (regWithFormat_format reg2) (regWithFormat_reg reg1) (regWithFormat_reg reg2)) Nothing+                       : instrs++cleanForward config blockId assoc acc (li@(LiveInstr i1 _) : instrs)+        | Just (r1, r2) <- takeRegRegMoveInstr (ncgPlatform config) 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 config 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 config blockId assoc' (li : acc) instrs+++cleanForward config blockId assoc acc (li : instrs)++        -- Update association due to the spill.+        | LiveInstr (SPILL reg slot) _  <- li+        = let   assoc'  = addAssoc (SReg $ regWithFormat_reg reg)  (SSlot slot)+                        $ delAssoc (SSlot slot)+                        $ assoc+          in    cleanForward config blockId assoc' (li : acc) instrs++        -- Clean a reload instr.+        | LiveInstr (RELOAD{}) _        <- li+        = do    (assoc', mli)   <- cleanReload config blockId assoc li+                case mli of+                 Nothing        -> cleanForward config blockId assoc' acc+                                                instrs++                 Just li'       -> cleanForward config 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 config blockId assoc (li : acc) instrs++        -- Writing to a reg changes its value.+        | LiveInstr instr _     <- li+        , RU _ written          <- regUsageOfInstr (ncgPlatform config) instr+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub $ map regWithFormat_reg written)+          in  cleanForward config blockId assoc' (li : acc) instrs++++-- | Try and rewrite a reload instruction to something more pleasing+cleanReload+        :: Instruction instr+        => NCGConfig+        -> BlockId+        -> Assoc Store+        -> LiveInstr instr+        -> CleanM (Assoc Store, Maybe (LiveInstr instr))++cleanReload config blockId assoc li@(LiveInstr (RELOAD slot (RegWithFormat reg fmt)) _)++        -- 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 config fmt 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+++-- | 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 = foldl1WithDefault' emptyAssoc intersectAssoc+++-- | 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
+ GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# 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.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 GHC.CmmToAsm.Format+import GHC.Utils.Misc++import Data.List        (nub)+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  <- takeVirtualRegs 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) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) read+                mapM_ (incDefs scale) $ nub $ mapMaybe (takeVirtualReg . regWithFormat_reg) written++                -- Compute liveness for entry to next instruction.+                let liveDieRead_virt    = takeVirtualRegs (liveDieRead  live)+                let liveDieWrite_virt   = takeVirtualRegs (liveDieWrite live)+                let liveBorn_virt       = takeVirtualRegs (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++-- | 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))+                $ expectNonEmpty $ 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) ]+
+ GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -0,0 +1,358 @@+-- | 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  = [srms | RegAllocStatsColored{ raSRMs = srms } <- stats]++        -- sum up how many stores\/loads\/reg-reg-moves were left in the code+        total   = foldl' addSRM (0, 0, 0) 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+                          [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- 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+                $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]++        scatter =+          [ let lifetime  = case lookupUFM lifeMap r of+                    Just (_, l) -> l+                    Nothing     -> 0+            in parens $ hcat $ punctuate (text ", ")+              [ doubleQuotes $ ppr $ Color.nodeId node+              , ppr $ sizeUniqSet (Color.nodeConflicts node)+              , ppr $ lifetime ]+          | node <- nonDetEltsUFM+                -- See Note [Unique Determinism and code generation]+                $ Color.graphMap graph+          , let r = Color.nodeId node+          ]++   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+        => Platform+        -> LiveCmmDecl statics instr -> (Int, Int, Int)++countSRMs platform cmm+        = execState (mapBlockTopM (countSRM_block platform) cmm) (0, 0, 0)+++countSRM_block+        :: Instruction instr+        => Platform+        -> GenBasicBlock (LiveInstr instr)+        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))++countSRM_block platform (BasicBlock i instrs)+ = do   instrs' <- mapM (countSRM_instr platform) instrs+        return  $ BasicBlock i instrs'+++countSRM_instr+        :: Instruction instr+        => Platform -> LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)++countSRM_instr platform 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 platform 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)+
+ GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -0,0 +1,232 @@+module GHC.CmmToAsm.Reg.Graph.TrivColorable (+        trivColorable,+)++where++import GHC.Prelude++import GHC.Platform.Reg.Class+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import GHC.Platform.Reg++import GHC.Data.Graph.Base++import GHC.Types.Unique.Set ( nonDetEltsUniqSet, UniqSet )+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 RcFloatOrVector+--              (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 rc conflicts exclusions =+  let allocatableRegsThisClass = allocatableRegs (platformArch platform) rc+      count2 = accSqueeze 0       allocatableRegsThisClass (virtualRegSqueeze rc) conflicts+      count3 = accSqueeze count2  allocatableRegsThisClass (realRegSqueeze    rc) exclusions+  in count3 < allocatableRegsThisClass++allocatableRegs :: Arch -> RegClass -> Int+allocatableRegs arch rc =+  case arch of+    ArchX86 -> case rc of+      Unified.RcInteger       -> 3+      Unified.RcFloatOrVector -> 8+        -- in x86 32bit mode sse2 there are only+        -- 8 XMM registers xmm0 ... xmm7+    ArchX86_64    -> case rc of+      Unified.RcInteger       -> 5+      Unified.RcFloatOrVector -> 10+        -- in x86_64 there are 16 XMM registers+        -- xmm0 .. xmm15, here 10 is a+        -- "don't need to solve conflicts" count that+        -- was chosen at some point in the past.+    ArchPPC       -> case rc of+      Unified.RcInteger       -> 16+      Unified.RcFloatOrVector -> 26+    ArchPPC_64 _  -> case rc of+      Unified.RcInteger       -> 15+      Unified.RcFloatOrVector -> 20+    ArchARM _ _ _ -> panic "trivColorable ArchARM"+    ArchAArch64   -> case rc of+      Unified.RcInteger       -> 17+        -- N.B. x18 is reserved by the platform on AArch64/Darwin+        -- 32 - Base - Sp - Hp - R1..R6 - SpLim - IP0 - SP - LR - FP - X18+        -- -> 32 - 15 = 17+        -- (one stack pointer for Haskell, one for C)+      Unified.RcFloatOrVector -> 24+        -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.+        -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.+    ArchAlpha     -> panic "trivColorable ArchAlpha"+    ArchMipseb    -> panic "trivColorable ArchMipseb"+    ArchMipsel    -> panic "trivColorable ArchMipsel"+    ArchS390X     -> panic "trivColorable ArchS390X"+    ArchRISCV64   -> case rc of+      -- TODO for Sven Tennie+      Separate.RcInteger -> 14+      Separate.RcFloat   -> 20+      Separate.RcVector  -> 20+    ArchLoongArch64   -> case rc of+      Separate.RcInteger -> 16+      Separate.RcFloat   -> 24+      Separate.RcVector  -> 24+    ArchJavaScript-> panic "trivColorable ArchJavaScript"+    ArchWasm32    -> panic "trivColorable ArchWasm32"+    ArchUnknown   -> panic "trivColorable ArchUnknown"+++-- 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)+                RcFloatOrVector -> (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 RcFloatOrVector++   in   squeese < allocatableRegsInClass classN++-- | Worst case displacement+--      node N of classN has n neighbors of class C.+--+--      We currently only have RcInteger and RcFloatOrVector, 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)+                RcFloatOrVector -> 0++        RcFloatOrVector+         -> case classC of+                RcFloatOrVector -> min n (allocatableRegsInClass RcFloatOrVector)+                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+        RcFloatOrVector -> allocatableRegsDouble++allocatableRegsInteger :: Int+allocatableRegsInteger+        = length $ filter (\r -> regClass r == RcInteger)+                 $ map RealReg allocatableRegs++allocatableRegsDouble :: Int+allocatableRegsDouble+        = length $ filter (\r -> regClass r == RcFloatOrVector)+                 $ map RealReg allocatableRegs+-}
+ GHC/CmmToAsm/Reg/Graph/X86.hs view
@@ -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 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)+
+ GHC/CmmToAsm/Reg/Linear.hs view
@@ -0,0 +1,1011 @@++-----------------------------------------------------------------------------+--+-- 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 qualified GHC.CmmToAsm.Reg.Linear.RV64    as RV64+import qualified GHC.CmmToAsm.Reg.Linear.LA64    as LA64+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.Format+import GHC.CmmToAsm.Types+import GHC.Platform.Reg+import GHC.Platform.Reg.Class (RegArch (..), registerArch)+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm++import GHC.Data.Graph.Directed+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+import GHC.Types.Unique.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform++import Data.Containers.ListUtils+import Data.Maybe+import Data.List (sortOn)+import Control.Monad++-- -----------------------------------------------------------------------------+-- Top level of the register allocator++-- Allocate registers+regAlloc+        :: Instruction instr+        => NCGConfig+        -> LiveCmmDecl statics instr+        -> UniqDSM ( 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 !final_blocks' = sortOn ((/= 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 final_blocks')+                        , 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 (UniqSet RegWithFormat)+              -- ^ live regs on entry to each basic block+        -> [SCC (LiveBasicBlock instr)]+              -- ^ instructions annotated with "deaths"+        -> UniqDSM ([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    -> go (frInitFreeRegs platform :: RV64.FreeRegs)+      ArchLoongArch64 -> go $ (frInitFreeRegs platform :: LA64.FreeRegs)+      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"+      ArchWasm32     -> panic "linearRegAlloc ArchWasm32"+      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"+ where+  go :: (FR regs, Outputable regs)+     => regs -> UniqDSM ([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 (UniqSet RegWithFormat)              -- ^ live regs on entry to each basic block+        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"+        -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)++linearRegAlloc' config initFreeRegs entry_ids block_live sccs+ = UDSM $ \us -> do+    let !(_, !stack, !stats, !blocks, us') =+            runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us+                $ linearRA_SCCs entry_ids block_live [] sccs+     in DUniqResult (blocks, stats, getStackUse stack) us'+++linearRA_SCCs :: OutputableRegConstraint freeRegs instr+              => [BlockId]+              -> BlockMap (UniqSet RegWithFormat)+              -> [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 (UniqSet RegWithFormat)+        -> [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 (UniqSet RegWithFormat)              -- ^ 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 (UniqSet RegWithFormat) -> 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)+                                                  (nonDetEltsUniqSet $ takeRealRegs 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 (UniqSet RegWithFormat)                      -- ^ 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 (UniqSet RegWithFormat)                      -- ^ 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+    platform <- getPlatform+    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 platform instr of+        Just (src,dst)  | Just (RegWithFormat _ fmt) <- lookupUniqSet_Directly (liveDieRead live) (getUnique src),+                          isVirtualReg dst,+                          not (dst `elemUFM` assig),+                          isRealReg src || isInReg src assig -> do+           case src of+              RegReal rr -> setAssigR (addToUFM assig dst (InReg $ RealRegUsage rr fmt))+                -- 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+                        (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live)+                        (map regWithFormat_reg $ 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 (UniqSet RegWithFormat)+          -> [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                      | RegWithFormat {regWithFormat_reg = RegReal rr} <- written ]+    let virt_written = [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt         <- 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 :: [VirtualRegWithFormat]+        virt_read = nubOrdOn virtualRegWithFormat_reg [ VirtualRegWithFormat vr fmt | RegWithFormat (RegVirtual vr) fmt <- read ]++--     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+                        [ (virtualRegWithFormat_reg vr, RegReal rr)+                        | (vr, rr) <- zip virt_read    r_allocd+                                   ++ zip virt_written w_allocd ]++        patched_instr :: instr+        patched_instr+                = patchRegsOfInstr platform 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 platform 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 (realReg real) free) rs+         Just (InReg real)    -> loop (delFromUFM assig r)+                                      (frReleaseReg platform (realReg 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 $ realReg 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]) -> RealRegUsage -> RegM freeRegs (RegMap Loc,[instr])+     clobber temp (assig,instrs) (RealRegUsage reg fmt)+       = do config <- getConfig+            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 (RealRegUsage my_reg fmt))+                  let instr = mkRegRegMoveInstr config fmt+                                  (RegReal reg) (RegReal my_reg)++                  return (new_assign,(instr : instrs))++              -- (2) no free registers: spill the value+              [] -> do+                  (spill, slot)   <- spillR (RegWithFormat (RegReal reg) fmt) temp++                  -- record why this reg was spilled for profiling+                  recordSpill (SpillClobber temp)++                  let new_assign  = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) 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 allRegClasses =+               case registerArch (platformArch platform) of+                 Unified   ->   Unified.allRegClasses+                 Separate  ->  Separate.allRegClasses+                 NoVectors -> NoVectors.allRegClasses+            allFreeRegs = foldMap (\ rc -> frGetFreeRegs platform rc freeregs) allRegClasses++        let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ]++        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 $ realReg 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)+        -> [VirtualRegWithFormat] -- don't push these out+        -> [instr]            -- spill insns+        -> [RealReg]          -- real registers allocated (accum.)+        -> [VirtualRegWithFormat] -- temps to allocate+        -> RegM freeRegs ( [instr] , [RealReg])++allocateRegsAndSpill _       _    spills alloc []+        = return (spills, reverse alloc)++allocateRegsAndSpill reading keep spills alloc (r@(VirtualRegWithFormat vr _fmt):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 vr of+                -- case (1a): already in a register+                Just (InReg my_reg) ->+                        allocateRegsAndSpill reading keep spills (realReg 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 vr (InReg my_reg)))+                        allocateRegsAndSpill reading keep spills (realReg 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 vr)+                   -- 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+                        -> [VirtualRegWithFormat]+                        -> [instr]+                        -> [RealReg]+                        -> VirtualRegWithFormat+                        -> [VirtualRegWithFormat]+                        -> UniqFM VirtualReg Loc+                        -> SpillLoc+                        -> RegM freeRegs ([instr], [RealReg])+allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc+ = do   platform <- getPlatform+        freeRegs <- getFreeRegsR+        let regclass = classOfVirtualReg (platformArch platform) vr+            freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs :: [RealReg]++        -- Can we put the variable into a register it already was?+        pref_reg <- findPrefRealReg vr++        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 vr $! newLocation spill_loc $ RealRegUsage final_reg fmt)+                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 (fmap virtualRegWithFormat_reg 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 compat reg'+                      =  targetClassOfRealReg platform reg'+                      == regclass+                    candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)]+                    candidates_inBoth+                        = [ (temp, reg, mem)+                          | (temp, InBoth reg mem) <- candidates+                          , compat (realReg reg) ]++                -- 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+                          , compat (realReg reg) ]++                let result++                        -- we have a temporary that is in both register and mem,+                        -- just free up its register for use.+                        | (temp, (RealRegUsage my_reg _old_fmt), slot) : _ <- candidates_inBoth+                        = do    spills' <- loadTemp r spill_loc my_reg spills+                                let assig1  = addToUFM_Directly assig temp (InMem slot)+                                let assig2  = addToUFM assig1 vr $! newLocation spill_loc (RealRegUsage my_reg fmt)++                                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, RealRegUsage my_reg fmt) : _+                                        <- candidates_inReg+                        = do+                                (spill_store, slot) <- spillR (RegWithFormat (RegReal my_reg) fmt) 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 vr $! newLocation spill_loc (RealRegUsage my_reg fmt)+                                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 vr)+                                , text "assignment:       " <> ppr assig+                                , text "format:           " <> ppr fmt+                                , text "freeRegs:         " <> text (showRegs freeRegs)+                                , text "initFreeRegs:     " <> text (showRegs (frInitFreeRegs platform `asTypeOf` freeRegs))+                                ]+                        where showRegs = show . map (\reg -> (reg, targetClassOfRealReg platform reg)) . allFreeRegs platform++                result+++-- | Calculate a new location after a register has been loaded.+newLocation :: SpillLoc -> RealRegUsage -> 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)+        => VirtualRegWithFormat   -- the temp being loaded+        -> SpillLoc     -- the current location of this temp+        -> RealReg      -- the hreg to load the temp into+        -> [instr]+        -> RegM freeRegs [instr]++loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills+ = do+        insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot+        recordSpill (SpillLoad $ getUnique vreg)+        return  $  {- mkComment (text "spill load") : -} insn ++ spills++loadTemp _ _ _ spills =+   return spills
+ GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -0,0 +1,136 @@+module GHC.CmmToAsm.Reg.Linear.AArch64 where++import GHC.Prelude++import GHC.CmmToAsm.AArch64.Regs+import GHC.Platform.Reg.Class.Unified+import GHC.Platform.Reg++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc( HasDebugCallStack )+import GHC.Platform++import Data.Word++-- 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 :: HasDebugCallStack => 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) =+  case cls of+    RcFloatOrVector -> go 32 f 31+    -- x18 is a platform-reserved register for Win/Mac and free for Linux (See Note [Aarch64 Register x18 at Darwin and Windows])+    RcInteger       -> 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 :: HasDebugCallStack => 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
+ GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -0,0 +1,209 @@+{-# 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,+        RealRegUsage(..),++        -- 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.DSM+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Reg.Utils+import GHC.CmmToAsm.Format++import Data.Function ( on )++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 $ realReg rr+    fromLoc (InBoth rr _) = Just $ realReg 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   {-# UNPACK #-} !RealRegUsage++        -- | vreg is held in stack slots+        | InMem   {-# UNPACK #-}  !StackSlot+++        -- | vreg is held in both a register and stack slots+        | InBoth   {-# UNPACK #-} !RealRegUsage+                   {-# UNPACK #-} !StackSlot+        deriving (Eq, Ord, Show)++instance Outputable Loc where+        ppr l = text (show l)++-- | A 'RealReg', together with the specific 'Format' it is used at.+data RealRegUsage+  = RealRegUsage+    { realReg :: !RealReg+    , realRegFormat :: !Format+    } deriving Show++instance Outputable RealRegUsage where+  ppr (RealRegUsage r fmt) = ppr r <> dcolon <+> ppr fmt++-- NB: these instances only compare the underlying 'RealReg', as that is what+-- is important for register allocation.+--+-- (It would nonetheless be a good idea to remove these instances.)+instance Eq RealRegUsage where+  (==) = (==) `on` realReg+instance Ord RealRegUsage where+  compare = compare `on` realReg++-- | Get the reg numbers stored in this Loc.+regsOfLoc :: Loc -> [RealRegUsage]+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         :: DUniqSupply++        -- | 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)]++        }+
+ GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -0,0 +1,112 @@+module GHC.CmmToAsm.Reg.Linear.FreeRegs (+    FR(..),+    allFreeRegs,+    maxSpillSlots+)+where++import GHC.Prelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import qualified GHC.Platform.Reg.Class.Unified   as Unified+import qualified GHC.Platform.Reg.Class.Separate  as Separate+import qualified GHC.Platform.Reg.Class.NoVectors as NoVectors++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.Reg.Linear.RV64    as RV64+import qualified GHC.CmmToAsm.Reg.Linear.LA64    as LA64++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+import qualified GHC.CmmToAsm.RV64.Instr    as RV64.Instr+import qualified GHC.CmmToAsm.LA64.Instr    as LA64.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++instance FR RV64.FreeRegs where+    frAllocateReg = const RV64.allocateReg+    frGetFreeRegs = const RV64.getFreeRegs+    frInitFreeRegs = RV64.initFreeRegs+    frReleaseReg = const RV64.releaseReg++instance FR LA64.FreeRegs where+    frAllocateReg = \_ -> LA64.allocateReg+    frGetFreeRegs = \_ -> LA64.getFreeRegs+    frInitFreeRegs = LA64.initFreeRegs+    frReleaseReg = \_ -> LA64.releaseReg++allFreeRegs :: FR freeRegs => Platform -> freeRegs -> [RealReg]+allFreeRegs plat fr = foldMap (\rcls -> frGetFreeRegs plat rcls fr) allRegClasses+  where+    allRegClasses =+      case registerArch (platformArch plat) of+        Unified   ->   Unified.allRegClasses+        Separate  ->  Separate.allRegClasses+        NoVectors -> NoVectors.allRegClasses++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   -> RV64.Instr.maxSpillSlots config+   ArchLoongArch64  -> LA64.Instr.maxSpillSlots config+   ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"+   ArchWasm32    -> panic "maxSpillSlots ArchWasm32"+   ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
+ GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -0,0 +1,378 @@+-- | 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.Label+import GHC.Data.Graph.Directed+import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Monad (concatMapM)+import GHC.Types.Unique+import GHC.Types.Unique.FM++import GHC.Utils.Outputable+import GHC.CmmToAsm.Format+import GHC.Types.Unique.Set++-- | 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 (UniqSet RegWithFormat) -- ^ 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 (UniqSet RegWithFormat) -- ^ 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 live_set            = expectJust $ 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 $ map realReg 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 (UniqSet RegWithFormat)+                    -> [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 (UniqSet RegWithFormat)+                    -> [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     <- concatMapM (handleComponent delta instr) sccs++                -- 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 (RealRegUsage sreg scls)) ((InReg (RealRegUsage dreg dcls): _))) : 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 (RegWithFormat (RegReal sreg) scls) vreg++        -- reload into destination reg+        instrLoad       <- loadR (RegWithFormat (RegReal dreg) dcls) 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+      case (src, dst) of+          (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) ->+              do recordSpill (SpillJoinRR vreg)+                 return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)]+          (InMem s, InReg (RealRegUsage d cls)) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s+          (InReg (RealRegUsage s cls), InMem d) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkSpillInstr config (RegWithFormat (RegReal s) cls) 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))
+ GHC/CmmToAsm/Reg/Linear/LA64.hs view
@@ -0,0 +1,71 @@+module GHC.CmmToAsm.Reg.Linear.LA64 where++import GHC.Prelude++import Data.Word+import GHC.CmmToAsm.LA64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++data FreeRegs = FreeRegs !Word32 !Word32++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f++-- | Show bits as a `String` of @1@s and @0@s+showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]++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"++-- | Set bits of all allocatable registers to 1+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f)+  | RcInteger <- cls = go 0 g allocatableIntRegs+  | RcFloat   <- cls = go 32 f allocatableDoubleRegs+  | RcVector  <- cls = sorry "Linear.LA64.getFreeRegs: vector registers are not supported"+  where+    go _ _ [] = []+    go off x (i : is)+      | testBit x i = RealRegSingle (off + i) : (go off x $! is)+      | otherwise = go off x $! is+    allocatableIntRegs = [4 .. 11] ++ [12 .. 19]+    allocatableDoubleRegs = [0 .. 7] ++ [8 .. 23]++-- | Set corresponding register bit to 0+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.LA64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.LA64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)++-- | Set corresponding register bit to 1+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.LA64.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
+ GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -0,0 +1,57 @@+-- | 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.Unified+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) =+    case cls of+      RcFloatOrVector -> go f (0x80000000) 63+      RcInteger       -> 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+
+ GHC/CmmToAsm/Reg/Linear/RV64.hs view
@@ -0,0 +1,99 @@+-- | Functions to implement the @FR@ (as in "free regs") type class.+--+-- For LLVM GHC calling convention (used registers), see+-- https://github.com/llvm/llvm-project/blob/6ab900f8746e7d8e24afafb5886a40801f6799f4/llvm/lib/Target/RISCV/RISCVISelLowering.cpp#L13638-L13685+module GHC.CmmToAsm.Reg.Linear.RV64+  ( allocateReg,+    getFreeRegs,+    initFreeRegs,+    releaseReg,+    FreeRegs (..),+  )+where++import Data.Word+import GHC.CmmToAsm.RV64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Bitmaps to indicate which registers are free (currently unused)+--+-- The bit index represents the `RegNo`, in case of floating point registers+-- with an offset of 32. The register is free when the bit is set.+data FreeRegs+  = FreeRegs+      -- | integer/general purpose registers (`RcInteger`)+      !Word32+      -- | floating point registers (`RcDouble`)+      !Word32++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f++-- | Show bits as a `String` of @1@s and @0@s+showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]++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"++-- | Set bits of all allocatable registers to 1+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)+  where+    noFreeRegs :: FreeRegs+    noFreeRegs = FreeRegs 0 0++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f) =+  case cls of+    RcInteger -> go 0 g allocatableIntRegs+    RcFloat -> go 32 f allocatableDoubleRegs+    RcVector ->+      sorry "Linear.RV64.getFreeRegs: vector registers are not supported"++  where+    go _ _ [] = []+    go off x (i : is)+      | testBit x i = RealRegSingle (off + i) : (go off x $! is)+      | otherwise = go off x $! is+    -- The lists of allocatable registers are manually crafted: Register+    -- allocation is pretty hot code. We don't want to iterate and map like+    -- `initFreeRegs` all the time! (The register mappings aren't supposed to+    -- change often.)+    allocatableIntRegs = [5 .. 7] ++ [10 .. 17] ++ [28 .. 30]+    allocatableDoubleRegs = [0 .. 7] ++ [10 .. 17] ++ [28 .. 31]++-- | Set corresponding register bit to 0+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.RV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.RV64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)++-- | Set corresponding register bit to 1+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.RV64.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
+ GHC/CmmToAsm/Reg/Linear/StackMap.hs view
@@ -0,0 +1,65 @@++-- | 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+import GHC.CmmToAsm.Format+++-- | 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 -> Format -> Unique -> (StackMap, Int)++getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique+  | Just slot <- lookupUFM reserved regUnique  =  (fs, slot)++getStackSlotFor (StackMap freeSlot reserved) fmt regUnique =+  let+    nbSlots = (formatInBytes fmt + 7) `div` 8+  in+    (StackMap (freeSlot+nbSlots) (addToUFM reserved regUnique freeSlot), freeSlot)++-- | Return the number of stack slots that were allocated+getStackUse :: StackMap -> Int+getStackUse (StackMap freeSlot _) = freeSlot+
+ GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-}+{-# 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.Format+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Config+import GHC.Cmm.BlockId++import GHC.Platform+import GHC.Types.Unique+import GHC.Types.Unique.DSM+import GHC.Exts (oneShot)++import GHC.Utils.Monad.State.Strict as Strict++type RA_Result freeRegs a = (# a, RA_State freeRegs #)++pattern RA_Result :: a -> b -> (# b, a #)+pattern RA_Result a b = (# b, a #)+{-# COMPLETE RA_Result #-}++-- | The register allocator monad type.+newtype RegM freeRegs a+        = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }+        deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))++-- | 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)++-- | 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+        -> DUniqSupply+        -> RegM freeRegs a+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a, DUniqSupply)++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, ra_us state)+++-- | 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+       => RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)++spillR reg temp = mkRegM $ \s ->+  let (stack1,slots) = getStackSlotFor (ra_stack s) (regWithFormat_format reg) temp+      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slots+  in+  RA_Result s{ra_stack=stack1} (instr,slots)+++loadR :: Instruction instr+      => RegWithFormat -> 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 takeUniqueFromDSupply (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 }) ()
+ GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -0,0 +1,93 @@+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+import GHC.Platform (Platform)++-- | 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+        => Platform+        -> NatCmmDecl statics instr -> Int++countRegRegMovesNat platform cmm+        = execState (mapGenBlockTopM countBlock cmm) 0+ where+        countBlock b@(BasicBlock _ instrs)+         = do   mapM_ countInstr instrs+                return  b++        countInstr instr+                | Just _        <- takeRegRegMoveInstr platform instr+                = do    modify (+ 1)+                        return instr++                | otherwise+                =       return instr+++-- | Pretty print some RegAllocStats+pprStats+        :: Instruction instr+        => Platform -> [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc++pprStats platform 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 platform) 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 "")+
+ GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -0,0 +1,47 @@+{-# 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.Unified+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 (setBit f n)++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily+getFreeRegs platform cls (FreeRegs f) =+  case cls of+    RcInteger ->+      [ RealRegSingle i+      | i <- intregnos platform+      , testBit f i+      ]+    RcFloatOrVector ->+      [ RealRegSingle i+      | i <- xmmregnos platform+      , testBit f i+      ]++allocateReg :: RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs f)+        = FreeRegs (clearBit f r)+
+ GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -0,0 +1,47 @@+{-# 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.Unified+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 (setBit f n)++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily+getFreeRegs platform cls (FreeRegs f) =+  case cls of+    RcInteger ->+      [ RealRegSingle i+      | i <- intregnos platform+      , testBit f i+      ]+    RcFloatOrVector ->+      [ RealRegSingle i+      | i <- xmmregnos platform+      , testBit f i+      ]++allocateReg :: RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs f)+        = FreeRegs (clearBit f r)+
+ GHC/CmmToAsm/Reg/Liveness.hs view
@@ -0,0 +1,1073 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- The register liveness determinator+--+-- (c) The University of Glasgow 2004-2013+--+-----------------------------------------------------------------------------++module GHC.CmmToAsm.Reg.Liveness (+        RegMap, emptyRegMap,+        BlockMap,+        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.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.CmmToAsm.Reg.Target++import GHC.Data.Graph.Directed+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform+import GHC.Types.Unique (Uniquable(..))+import GHC.Types.Unique.Set+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM+import GHC.Data.Bag+import GHC.Utils.Monad.State.Strict++import Data.List (mapAccumL, sortOn)+import Data.Maybe+import Data.IntSet              (IntSet)+import GHC.Utils.Misc++-----------------------------------------------------------------------------++-- | 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++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  !RegWithFormat !Int++        -- | reload this reg from a stack slot+        | RELOAD !Int !RegWithFormat++        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 platform i f+         = case i of+                Instr instr     -> Instr (patchRegsOfInstr platform instr f)+                SPILL  reg slot -> SPILL (updReg f reg) slot+                RELOAD slot reg -> RELOAD slot (updReg f reg)+          where+            updReg g (RegWithFormat reg fmt) = RegWithFormat (g reg) fmt++        isJumpishInstr :: Instruction instr => InstrSR instr -> Bool+        isJumpishInstr i+         = case i of+                Instr instr     -> isJumpishInstr instr+                _               -> False++        canFallthroughTo i bid+         = case i of+                Instr instr     -> canFallthroughTo instr bid+                _               -> 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 fmt r1 r2+            = Instr (mkRegRegMoveInstr platform fmt r1 r2)++        takeRegRegMoveInstr platform i+         = case i of+                Instr instr     -> takeRegRegMoveInstr platform 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      :: UniqSet RegWithFormat      -- ^ registers born in this instruction (written to for first time).+        , liveDieRead   :: UniqSet RegWithFormat      -- ^ registers that died because they were read for the last time.+        , liveDieWrite  :: UniqSet RegWithFormat}     -- ^ 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 (UniqSet RegWithFormat))         -- 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 (RegWithFormat reg _fmt) slot)+           = hcat [+                text "\tSPILL",+                char ' ',+                ppr reg,+                comma,+                text "SLOT" <> parens (int slot)]++        ppr (RELOAD slot (RegWithFormat reg _fmt))+           = 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 -> UniqSet RegWithFormat -> 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 = " <> ppr 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+        => Platform+        -> LiveCmmDecl statics instr+        -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg))++slurpConflicts platform 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 platform 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 (RegWithFormat reg _fmt) 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 (RegWithFormat reg _fmt)) _ <- 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.+                final_blocks' = sortOn ((/= first_id) . blockId) final_blocks++           in   CmmProc info label live $ ListGraph $+                map (stripLiveBlock config) final_blocks'++        -- 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, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr++patchEraseLive platform patchF cmm+        = patchCmm cmm+ where+        patchCmm cmm@CmmData{}  = cmm++        patchCmm (CmmProc info label live sccs)+         | LiveInfo static id blockMap mLiveSlots <- info+         = let+                  -- See Note [Unique Determinism and code generation]+                blockMap'       = mapMap (mapRegFormatSet patchF) 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 platform i+                , eatMe r1 r2 live+                = patchInstrs lis++                | otherwise+                = li' : patchInstrs lis++                where   li'     = patchRegsLiveInstr platform patchF li++        eatMe   r1 r2 live+                -- source and destination regs are the same+                | r1 == r2      = True++                -- destination reg is never used+                | elemUniqSet_Directly (getUnique r2) (liveBorn live)+                , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live)+                = True++                | otherwise     = False+++-- | Patch registers in this LiveInstr, including the liveness information.+--+patchRegsLiveInstr+        :: (Instruction instr, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)+        -> LiveInstr instr -> LiveInstr instr++patchRegsLiveInstr platform patchF li+ = case li of+        LiveInstr instr Nothing+         -> LiveInstr (patchRegsOfInstr platform instr patchF) Nothing++        LiveInstr instr (Just live)+         -> LiveInstr+                (patchRegsOfInstr platform instr patchF)+                (Just live+                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg+                          liveBorn      = mapRegFormatSet patchF $ liveBorn live+                        , liveDieRead   = mapRegFormatSet patchF $ liveDieRead live+                        , liveDieWrite  = mapRegFormatSet 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+        -> UniqDSM (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+        -> UniqDSM (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 (UniqSet RegWithFormat))                 -- 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 (UniqSet RegWithFormat)+       -> [SCC (LiveBasicBlock instr)]          -- accum+       -> [SCC (LiveBasicBlock instr)]+       -> ( [SCC (LiveBasicBlock instr)]+          , BlockMap (UniqSet RegWithFormat))++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 (UniqSet RegWithFormat) -> [LiveBasicBlock instr]+                -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])++            linearLiveness = mapAccumL (livenessBlock platform)++                -- probably the least efficient way to compare two+                -- BlockMaps for equality.+            equalBlockMaps a b+                = a' == b'+              where a' = mapToList a+                    b' = mapToList b+                    -- See Note [Unique Determinism and code generation]++++-- | Annotate a basic block with register liveness information.+--+livenessBlock+        :: Instruction instr+        => Platform+        -> BlockMap (UniqSet RegWithFormat)+        -> LiveBasicBlock instr+        -> (BlockMap (UniqSet RegWithFormat), 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+        -> UniqSet RegWithFormat -- 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 $ elemUniqSet_Directly (getUnique 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+        -> UniqSet RegWithFormat            -- regs live on this instr+        -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs+        -> [LiveInstr instr]            -- instructions (accum)+        -> [LiveInstr instr]            -- instructions+        -> (UniqSet RegWithFormat, [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+        -> UniqSet RegWithFormat+        -> BlockMap (UniqSet RegWithFormat)+        -> LiveInstr instr+        -> (UniqSet RegWithFormat, 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   = r_dying+                        , liveDieWrite  = w_dying }))++        | otherwise+        = (liveregs_br, LiveInstr instr+                        (Just $ Liveness+                        { liveBorn      = emptyUniqSet+                        , liveDieRead   = r_dying_br+                        , liveDieWrite  = 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     = mkUniqSet+                          [ reg+                          | reg@(RegWithFormat r _) <- read+                          , not $ any (\ w -> getUnique w == getUnique r) written+                          , not (elementOfUniqSet reg liveregs) ]++            w_dying     = mkUniqSet+                          [ 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 -> emptyUniqSet++            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  = (r_dying `unionUniqSets` live_branch_only)+                          -- See Note [Unique Determinism and code generation]
+ GHC/CmmToAsm/Reg/Target.hs view
@@ -0,0 +1,147 @@++-- | 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,+        mapRegFormatSet,+)++where++import GHC.Prelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.CmmToAsm.Format++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Types.Unique+import GHC.Types.Unique.Set+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+import qualified GHC.CmmToAsm.RV64.Regs   as RV64+import qualified GHC.CmmToAsm.LA64.Regs      as LA64++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   -> RV64.virtualRegSqueeze+      ArchLoongArch64 -> LA64.virtualRegSqueeze+      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   -> RV64.realRegSqueeze+      ArchLoongArch64 -> LA64.realRegSqueeze+      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   -> RV64.classOfRealReg+      ArchLoongArch64 -> LA64.classOfRealReg+      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   -> RV64.mkVirtualReg+      ArchLoongArch64 -> LA64.mkVirtualReg+      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   -> RV64.regDotColor+      ArchLoongArch64 -> LA64.regDotColor+      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 (platformArch platform) vr+   RegReal rr -> targetClassOfRealReg platform rr++mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat+mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt)
+ GHC/CmmToAsm/Reg/Utils.hs view
@@ -0,0 +1,58 @@+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+
+ GHC/CmmToAsm/Types.hs view
@@ -0,0 +1,32 @@+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
+ GHC/CmmToAsm/Utils.hs view
@@ -0,0 +1,32 @@+module GHC.CmmToAsm.Utils+   ( topInfoTable+   , entryBlocks+   )+where++import GHC.Prelude++import GHC.Cmm.BlockId+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 _ = []
+ GHC/CmmToAsm/Wasm.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.CmmToAsm.Wasm (ncgWasm) where++import Data.ByteString.Builder+import Data.ByteString.Lazy.Char8 (unpack)+import Data.Maybe+import Data.Semigroup+import GHC.Cmm+import GHC.Cmm.ContFlowOpt+import GHC.Cmm.GenericOpt+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Wasm.Asm+import GHC.CmmToAsm.Wasm.FromCmm+import GHC.CmmToAsm.Wasm.Types+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (StreamS (..), runStream, liftIO)+import GHC.Driver.DynFlags+import GHC.Platform+import GHC.Prelude+import GHC.Settings+import GHC.Types.Unique.DSM+import GHC.Unit+import GHC.Utils.Logger+import GHC.Utils.Outputable (text)+import System.IO++ncgWasm ::+  NCGConfig ->+  Logger ->+  Platform ->+  ToolSettings ->+  ModLocation ->+  Handle ->+  CgStream RawCmmGroup a ->+  UniqDSMT IO a+ncgWasm ncg_config logger platform ts loc h cmms = do+  (r, s) <- streamCmmGroups ncg_config platform cmms+  outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"+  -- See Note [WasmTailCall]+  let cfg = (defaultWasmAsmConfig s) { pic = ncgPIC ncg_config, tailcall = doTailCall ts }+  outputWasm $ execWasmAsmM cfg $ asmTellEverything TagI32 s+  pure r+  where+    outputWasm builder = liftIO $ do+      putDumpFileMaybe+        logger+        Opt_D_dump_asm+        "Asm Code"+        FormatASM+        (text . unpack $ toLazyByteString builder)+      hPutBuilder h builder++streamCmmGroups ::+  NCGConfig ->+  Platform ->+  CgStream RawCmmGroup a ->+  UniqDSMT IO (a, WasmCodeGenState 'I32)+streamCmmGroups ncg_config platform cmms = withDUS $ \us -> do+  (r,s) <- go (initialWasmCodeGenState platform us) $ runStream cmms+  return ((r,s), wasmDUniqSupply s)+  where+    go s (Done r) = pure (r, s)+    go s (Effect m) = do+      (a, us') <- runUDSMT (wasmDUniqSupply s) m+      go s{wasmDUniqSupply = us'} a+    go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k+      where+        -- Run the generic cmm optimizations like other NCGs, followed+        -- by a late control-flow optimization pass that does shrink+        -- the CFG block count in some cases.+        opt decl = case decl of+          CmmData {} -> decl+          CmmProc {} -> CmmProc info lbl live $ cmmCfgOpts False graph+            where+              (CmmProc info lbl live graph, _) = cmmToCmm ncg_config decl++doTailCall :: ToolSettings -> Bool+doTailCall ts = Option "-mtail-call" `elem` as_args+  where+    (_, as_args) = toolSettings_pgm_a ts
+ GHC/CmmToAsm/Wasm/Asm.hs view
@@ -0,0 +1,569 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# 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 qualified Data.ByteString.Char8 as BS8+import Data.Coerce+import Data.Foldable+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.Settings.Config (cProjectVersion)+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Types.Unique.Map+import GHC.Types.Unique.Set+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 (WasmAsmConfig -> Builder -> State Builder a)+  deriving+    ( Functor,+      Applicative,+      Monad+    )+    via (ReaderT WasmAsmConfig (ReaderT Builder (State Builder)))++instance Semigroup a => Semigroup (WasmAsmM a) where+  (<>) = liftA2 (<>)++instance Monoid a => Monoid (WasmAsmM a) where+  mempty = pure mempty++getConf :: WasmAsmM WasmAsmConfig+getConf = WasmAsmM $ \conf _ -> pure conf++-- | Default indent level is none+execWasmAsmM :: WasmAsmConfig -> WasmAsmM a -> Builder+execWasmAsmM conf (WasmAsmM m) =+  execState (m conf mempty) mempty++-- | Increase indent level by a tab+asmWithTab :: WasmAsmM a -> WasmAsmM a+asmWithTab (WasmAsmM m) =+  WasmAsmM $ \conf t -> m conf $! 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+  WasmAsmConfig {..} <- getConf+  unless pic $ 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 0x" <> word8Hex i+  DataI16 i -> ".int16 0x" <> word16Hex i+  DataI32 i -> ".int32 0x" <> word32Hex i+  DataI64 i -> ".int64 0x" <> word64Hex 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 -> panic "asmTellDataSectionContent: negative offset"+         )+  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 -> UniqueSet -> SymName -> DataSection -> WasmAsmM ()+asmTellDataSection ty_word def_syms sym DataSection {..} = do+  when (getUnique sym `memberUniqueSet` 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 -> do+    WasmAsmConfig {..} <- getConf+    let+      asm_sym = asmFromSymName sym+      (ty_const, ty_add) = case ty_word of+        TagI32 -> ("i32.const ", "i32.add")+        TagI64 -> ("i64.const ", "i64.add")+        _ -> panic "asmTellWasmInstr: invalid word type"+    traverse_ asmTellLine $ if+      | pic, getUnique sym `memberUniqueSet` mbrelSyms -> [+          "global.get __memory_base",+          ty_const <> asm_sym <> "@MBREL",+          ty_add+        ]+      | pic, getUnique sym `memberUniqueSet` tbrelSyms -> [+          "global.get __table_base",+          ty_const <> asm_sym <> "@TBREL",+          ty_add+        ]+      | pic -> [ "global.get " <> asm_sym <> "@GOT" ]+      | otherwise -> [ ty_const <> asm_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"+  WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt"+  WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg"+  WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min"+  WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max"+  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 "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]) <> "}"+  -- See Note [WasmTailCall]+  WasmTailCall (WasmExpr e) -> do+    WasmAsmConfig {..} <- getConf+    if+        | tailcall,+          WasmSymConst sym <- e ->+            asmTellLine $ "return_call " <> asmFromSymName sym+        | tailcall ->+            do+              asmTellWasmInstr ty_word e+              asmTellLine $+                "return_call_indirect "+                  <> asmFromFuncType+                    []+                    [SomeWasmType ty_word]+        | otherwise ->+            do+              asmTellWasmInstr ty_word e+              asmTellLine "return"+  WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a+  WasmSeq c0 c1 -> do+    asmTellWasmControl ty_word c0+    asmTellWasmControl ty_word c1++asmTellFunc ::+  WasmTypeTag w ->+  UniqueSet ->+  SymName ->+  (([SomeWasmType], [SomeWasmType]), FuncBody w) ->+  WasmAsmM ()+asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do+  when (getUnique sym `memberUniqueSet` 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+  WasmAsmConfig {..} <- getConf+  when pic $ traverse_ asmTellTabLine [+      ".globaltype __memory_base, i32, immutable",+      ".globaltype __table_base, i32, immutable"+    ]+  for_ supportedCmmGlobalRegs $ \reg ->+    let+      (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg+      asm_sym = asmFromSymName sym+     in do+      asmTellTabLine $+          ".globaltype "+            <> asm_sym+            <> ", "+            <> asmFromSomeWasmType ty+      when pic $ traverse_ asmTellTabLine [+          ".import_module " <> asm_sym <> ", regs",+          ".import_name " <> asm_sym <> ", " <> asm_sym+        ]+  asmTellLF++asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()+asmTellCtors _ [] = mempty+asmTellCtors ty_word syms = do+  -- See Note [JSFFI initialization] for details+  asmTellSectionHeader ".init_array.101"+  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 $ BS8.pack cProjectVersion+          ]+    ]++asmTellTargetFeatures :: WasmAsmM ()+asmTellTargetFeatures = do+  WasmAsmConfig {..} <- getConf+  asmTellSectionHeader ".custom_section.target_features"+  asmTellVec+    [ do+        asmTellTabLine ".int8 0x2b"+        asmTellBS feature+      | feature <-+          ["tail-call" | tailcall]+            <> [ "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
+ GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -0,0 +1,1761 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use camelCase" #-}+module GHC.CmmToAsm.Wasm.FromCmm+  ( alignmentFromWordType,+    globalInfoFromCmmGlobalReg,+    supportedCmmGlobalRegs,+    onCmmGroup,+  )+where++import Control.Monad+import qualified Data.ByteString as BS+import Data.Foldable+import Data.Functor+import Data.Semigroup+import Data.String+import Data.Traversable+import Data.Type.Equality+import GHC.Cmm+import GHC.Cmm.BlockId+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.Types.Unique.Set+import GHC.Types.Unique.DSM+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. As a conservative+-- optimization, a data section with a single CmmString/CmmFileEmbed+-- has no alignment requirement, otherwise we always align to the word+-- size to satisfy pointer tagging requirements and avoid unaligned+-- loads/stores.+alignmentFromCmmSection :: WasmTypeTag w -> [DataSectionContent] -> Alignment+alignmentFromCmmSection _ [DataASCII {}] = mkAlignment 1+alignmentFromCmmSection _ [DataIncBin {}] = mkAlignment 1+alignmentFromCmmSection t _ = alignmentFromWordType t++-- | Lower a 'CmmStatic'.+lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent+lower_CmmStatic s = case s of+  CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ fromInteger $ narrowU W8 i+  CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ fromInteger $ narrowU W16 i+  CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ fromInteger $ narrowU W32 i+  CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ fromInteger $ narrowU 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)+  _ -> Nothing+  where+    ty_word = SomeWasmType t++supportedCmmGlobalRegs :: [GlobalReg]+supportedCmmGlobalRegs =+  [VanillaReg i | i <- [1 .. 10]]+    <> [FloatReg i | i <- [1 .. 6]]+    <> [DoubleReg i | i <- [1 .. 6]]+    <> [LongReg i | i <- [1 .. 1]]+    <> [Sp, SpLim, Hp, HpLim]++-- | 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 an unary homogeneous operation.+lower_MO_Un_Homo ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : pre)+      (t : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Un_Homo op lbl t0 [x] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` op ty+lower_MO_Un_Homo _ _ _ _ = panic "lower_MO_Un_Homo: unreachable"++-- | 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 @rts/prim/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 'MO_WF_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_WF_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_WF_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagF32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI32 TagF32+lower_MO_WF_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagF64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI64 TagF64+lower_MO_WF_Bitcast _ _ _ = panic "lower_MO_WF_Bitcast: unreachable"++-- | Lower a 'MO_FW_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_FW_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_FW_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x+  pure $+    SomeWasmExpr TagI32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF32 TagI32+lower_MO_FW_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF64 TagI64+lower_MO_FW_Bitcast _ _ _ = panic "lower_MO_FW_Bitcast: unreachable"++-- | Lower a 'CmmMachOp'.+lower_CmmMachOp ::+  CLabel ->+  MachOp ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_CmmMachOp lbl (MO_RelaxedRead w0) [x] = lower_CmmExpr lbl (CmmLoad x (cmmBits w0) NaturallyAligned)+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) xs =+  lower_MO_Un_Homo+    WasmNeg+    lbl+    (cmmFloat w0)+    xs+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_F_Min w0) xs =+  lower_MO_Bin_Homo+    WasmMin+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Max w0) xs =+  lower_MO_Bin_Homo+    WasmMax+    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_Round w0 w1) xs =+  lower_MO_Un_Conv+    (WasmConvert Signed)+    lbl+    (cmmBits w0)+    (cmmFloat w1)+    xs+lower_CmmMachOp lbl (MO_FS_Truncate 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 lbl (MO_FW_Bitcast w) xs  = lower_MO_FW_Bitcast lbl w xs+lower_CmmMachOp lbl (MO_WF_Bitcast w) xs  = lower_MO_WF_Bitcast lbl w xs+lower_CmmMachOp _ mop _ =+  pprPanic "lower_CmmMachOp: unreachable" $+    vcat [ text "offending MachOp:" <+> pprMachOp mop ]++-- | 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 $+                narrowU 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+    CmmBlock bid -> lower_CmmLit $ CmmLabel $ infoTblLbl bid+    _ -> 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 lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do+  ty_word <- wasmWordTypeM+  ty_word_cmm <- wasmWordCmmTypeM+  case greg of+    EagerBlackholeInfo ->+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            WasmSymConst "__stg_EAGER_BLACKHOLE_info"+    GCEnter1 -> do+      onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"+    GCFun -> do+      onFuncSym "__stg_gc_fun" [] [ty_word_cmm]+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun"+    BaseReg -> do+      platform <- wasmPlatformM+      lower_CmmExpr lbl $ regTableOffset platform 0+    _other+      | Just (sym_global, SomeWasmType ty) <-+          globalInfoFromCmmGlobalReg ty_word greg ->+          pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global+      | otherwise -> do+          platform <- wasmPlatformM+          case someWasmTypeFromCmmType reg_use_ty of+            SomeWasmType ty -> do+              (WasmExpr ptr_instr, o) <-+                lower_CmmExpr_Ptr lbl $+                  get_GlobalReg_addr platform greg+              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+  let (ptr', o) = case ptr of+        CmmLit (CmmLabelOff lbl o)+          | o >= 0 -> (CmmLit $ CmmLabel lbl, o)+        CmmRegOff reg o+          | o >= 0 -> (CmmReg reg, o)+        CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]+          | o >= 0 -> (base, fromInteger o)+        _ -> (ptr, 0)+  instrs <- lower_CmmExpr_Typed lbl ty_word ptr'+  pure (instrs, o)++-- | 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 a primitive operation.+lower_CMO_Un_Homo_Prim ::+  CLabel ->+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : pre)+      (t : pre)+  ) ->+  WasmTypeTag t ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do+  (ri, _) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  pure $+    WasmStatements $+      x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_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_Prim lbl WasmAbs TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 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_Prim lbl WasmAbs TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs+lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs+lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_SeqCstFence _ _ = 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")+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_PopCnt w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pdep w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pdep" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pext w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pext" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Clz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_clz" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Ctz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_ctz" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BSwap w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bswap" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BRev w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0))+    Nothing+    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)+    )+    Nothing+    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))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_SuspendThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "suspendThread")+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_ResumeThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "resumeThread")+    Nothing+    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 <- getUniqueM+  let ret_local = LocalReg ret_uniq ret_cmm_ty+  lower_CmmUnsafeForeignCall+    lbl+    (Left sym_callee)+    Nothing+    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) ->+  Maybe+    ([ForeignHint], [ForeignHint]) ->+  CmmReturnInfo ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = do+  platform <- wasmPlatformM+  SomeWasmPreCCall arg_tys args_instr <-+    foldrM+      ( \(arg_expr, arg_hint) (SomeWasmPreCCall acc_tys acc_instr) -> do+          SomeWasmExpr arg_ty arg_wasm_expr <- lower_CmmExpr lbl arg_expr+          let WasmExpr arg_instr = case arg_hint of+                SignedHint ->+                  extendSubword+                    (cmmExprWidth platform arg_expr)+                    arg_ty+                    arg_wasm_expr+                _ -> arg_wasm_expr+          pure $+            SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $+              arg_instr `WasmConcat` acc_instr+      )+      (SomeWasmPreCCall TypeListNil WasmNop)+      arg_exprs_hints+  SomeWasmPostCCall ret_tys ret_instr <-+    foldrM+      ( \(reg, ret_hint) (SomeWasmPostCCall acc_tys acc_instr) -> do+          (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg+          pure $+            SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $+              case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of+                (# SignedHint, W8 #) ->+                  acc_instr+                    `WasmConcat` WasmConst reg_ty 0xFF+                    `WasmConcat` WasmAnd reg_ty+                    `WasmConcat` WasmLocalSet reg_ty reg_i+                (# SignedHint, W16 #) ->+                  acc_instr+                    `WasmConcat` WasmConst reg_ty 0xFFFF+                    `WasmConcat` WasmAnd reg_ty+                    `WasmConcat` WasmLocalSet reg_ty reg_i+                _ -> acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i+      )+      (SomeWasmPostCCall TypeListNil WasmNop)+      ret_locals_hints+  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+                         )+  where+    (# arg_exprs_hints, ret_locals_hints #) = case mb_hints of+      Just (arg_hints, ret_hints) ->+        (# zip arg_exprs arg_hints, zip ret_locals ret_hints #)+      _ -> (# map (,NoHint) arg_exprs, map (,NoHint) ret_locals #)++-- | 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 (GlobalRegUse 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 arg_hints ret_hints ret_info)+        )+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Left $ symNameFromCLabel lbl_callee)+              (Just (arg_hints, ret_hints))+              ret_info+              ret_locals+              arg_exprs+    CmmUnsafeForeignCall+      (ForeignTarget target_expr (ForeignConvention conv arg_hints ret_hints ret_info))+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Right target_expr)+              (Just (arg_hints, ret_hints))+              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 =+          insertUniqueSet+            (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 -> do+    ty_word <- wasmWordTypeM+    wasmModifyM $ \s@WasmCodeGenState {..} ->+      s {funcTypes = addToUniqMap_C const funcTypes sym ([], [SomeWasmType ty_word])}+  _ -> 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 cs,+            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 #)
+ GHC/CmmToAsm/Wasm/Types.hs view
@@ -0,0 +1,522 @@+{-# 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,+    wasmRunM,+    WasmAsmConfig (..),+    defaultWasmAsmConfig+  )+where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Coerce+import Data.Functor+import Data.Kind+import Data.String+import Data.Type.Equality+import Data.Word+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.Set+import GHC.Types.Unique.DSM+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 @.globl@ directives in the output assembly. Also adds+    -- @.hidden@ when not generating PIC code, similar to+    -- -fvisibility=hidden in clang.+    --+    -- @[ 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 Word8+  | DataI16 Word16+  | DataI32 Word32+  | DataI64 Word64+  | 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 = UniqueSet++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)+  WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmMax :: WasmTypeTag t -> WasmInstr w (t : 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)]++  -- Note [WasmTailCall]+  -- ~~~~~~~~~~~~~~~~~~~+  -- This represents the exit point of each CmmGraph: tail calling the+  -- destination in CmmCall. The STG stack may grow before the call,+  -- but it's always a tail call in the sense that the C call stack is+  -- guaranteed not to grow.+  --+  -- In the wasm backend, WasmTailCall is lowered to different+  -- assembly code given whether the wasm tail-call extension is+  -- enabled:+  --+  -- When tail-call is not enabled (which is the default as of today),+  -- a WasmTailCall is lowered to code that pushes the callee function+  -- pointer onto the value stack and returns immediately. The actual+  -- call is done by the trampoline in StgRun.+  --+  -- When tail-call is indeed enabled via passing -mtail-call in+  -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered+  -- to return_call/return_call_indirect, thus tail calling into its+  -- callee without returning to StgRun.+  WasmTailCall ::+    e ->+    WasmControl s e 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,+    wasmDUniqSupply :: DUniqSupply+  }++initialWasmCodeGenState :: Platform -> DUniqSupply -> WasmCodeGenState w+initialWasmCodeGenState platform us =+  WasmCodeGenState+    { wasmPlatform =+        platform,+      defaultSyms = emptyUniqueSet,+      funcTypes = emptyUniqMap,+      funcBodies =+        emptyUniqMap,+      dataSections = emptyUniqMap,+      ctors =+        [],+      localRegs = emptyUFM,+      localRegsCount = 0,+      wasmDUniqSupply = us+    }++newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a)+  deriving newtype (Functor, Applicative, Monad)++instance MonadUniqDSM (WasmCodeGenM w) where+  liftUniqDSM (UDSM m) = wasmStateM $ \st ->+    let DUniqResult a us' = m (wasmDUniqSupply st)+     in (# a, st{wasmDUniqSupply=us'} #)++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++wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w)+wasmRunM (WasmCodeGenM s) = runState s++instance MonadGetUnique (WasmCodeGenM w) where+  getUniqueM = wasmStateM $+    \s@WasmCodeGenState {..} -> case takeUniqueFromDSupply wasmDUniqSupply of+      (u, us) -> (# u, s {wasmDUniqSupply = us} #)++data WasmAsmConfig = WasmAsmConfig+  {+    pic, tailcall :: Bool,+    -- | Data/function symbols with 'SymStatic' visibility (defined+    -- but not visible to other compilation units). When doing PIC+    -- codegen, private symbols must be emitted as @MBREL@/@TBREL@+    -- relocations in the code section. The public symbols, defined or+    -- elsewhere, are all emitted as @GOT@ relocations instead.+    mbrelSyms, tbrelSyms :: ~SymSet+  }++-- | The default 'WasmAsmConfig' must be extracted from the final+-- 'WasmCodeGenState'.+defaultWasmAsmConfig :: WasmCodeGenState w -> WasmAsmConfig+defaultWasmAsmConfig WasmCodeGenState {..} =+  WasmAsmConfig+    { pic = False,+      tailcall = False,+      mbrelSyms = mk_rel_syms dataSections,+      tbrelSyms = mk_rel_syms funcBodies+    }+  where+    mk_rel_syms :: SymMap a -> SymSet+    mk_rel_syms =+      nonDetFoldUniqMap+        ( \(sym, _) acc ->+            if getUnique sym `memberUniqueSet` defaultSyms+              then acc+              else insertUniqueSet (getUnique sym) acc+        )+        emptyUniqueSet
+ GHC/CmmToAsm/Wasm/Utils.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++module GHC.CmmToAsm.Wasm.Utils+  ( 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++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 . nonDetUniqMapToList++builderCommas :: (a -> Builder) -> [a] -> Builder+builderCommas f xs = mconcat (intersperse ", " (map f xs))
+ GHC/CmmToAsm/X86.hs view
@@ -0,0 +1,66 @@+{-# 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        = \_p _i bs -> pure bs+   , 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+   canFallthroughTo        = X86.canFallthroughTo+   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
+ GHC/CmmToAsm/X86/CodeGen.hs view
@@ -0,0 +1,6718 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NondecreasingIndentation #-}++-----------------------------------------------------------------------------+--+-- 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 ( ghcInternalUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+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.Data.Maybe ( expectJust )+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad ( foldMapM )+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.DSM ( getUniqueM )++import qualified Data.Semigroup as S++import Control.Monad+import Control.Monad.Trans.State.Strict+  ( StateT, evalStateT, get, put )+import Control.Monad.Trans.Class (lift)+import Data.Foldable (fold)+import Data.Int+import Data.List (partition, (\\))+import Data.Maybe+import Data.Word++import qualified Data.Map as Map++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    platform <- getPlatform+    return $ target32Bit platform++ssse3Enabled :: NatM Bool+ssse3Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSSE3)++sse4_1Enabled :: NatM Bool+sse4_1Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE4)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE42)++avxEnabled :: NatM Bool+avxEnabled = do+  config <- getConfig+  return (ncgAvxEnabled config)++avx2Enabled :: NatM Bool+avx2Enabled = do+  config <- getConfig+  return (ncgAvx2Enabled config)++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 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 (LexicalFastString name))+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col (unpackFS 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+    let platform = ncgPlatform config+    if ncgDwarfUnwindings config+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ 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) = Map.singleton reg (fmap (toUnwindExpr platform) expr)+        case foldMap to_unwind_entry regs of+          tbl | Map.null tbl -> return nilOL+              | otherwise    -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code reg src+        | isVecType ty           -> assignReg_VecCode reg src+        | otherwise              -> assignReg_IntCode reg src+          where ty = cmmRegType reg++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code        addr src+        | isVecType ty           -> assignMem_VecCode format 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 -> [GlobalRegUse] -> [RegWithFormat]+jumpRegs platform gregs =+  [ RegWithFormat (RegReal r) (cmmTypeFormat ty)+  | GlobalRegUse gr ty <- gregs+  , Just r <- [globalRegMaybe platform gr] ]++--------------------------------------------------------------------------------+-- | '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 ty)+  = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated+    RegVirtual (mkVirtualReg u (cmmTypeFormat ty))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform $ globalRegUse_reg 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 :: CmmReg -> Int -> CmmExpr+mangleIndexTree reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType 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)++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 W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (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 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II16 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II8 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do+   RegCode64 code rhi rlo <- iselExpr64 expr+   Reg64 rohi rolo <- getNewReg64+   let+        ocode = code `appOL`+                toOL [ MOV II32 (OpReg rlo) (OpReg rolo),+                       XOR II32 (OpReg rohi) (OpReg rohi),+                       NEGI II32 (OpReg rolo),+                       SBB II32 (OpReg rhi) (OpReg rohi) ]+   return (RegCode64 ocode rohi rolo)++-- To multiply two 64-bit numbers we use the following decomposition (in C notation):+--+--     ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo)+--      = ((r2lo * r1hi) << 32)+--      + ((r1lo * r2hi) << 32)+--      + r1lo * r2lo+--+-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely.++iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   tmp <- getNewRegNat II32+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV  II32 (OpReg r1lo) (OpReg eax),+                       MOV  II32 (OpReg r2lo) (OpReg tmp),+                       MOV  II32 (OpReg r1hi) (OpReg rhi),+                       IMUL II32 (OpReg tmp) (OpReg rhi),+                       MOV  II32 (OpReg r2hi) (OpReg rlo),+                       IMUL II32 (OpReg eax) (OpReg rlo),+                       ADD  II32 (OpReg rlo) (OpReg rhi),+                       MUL2 II32 (OpReg tmp),+                       ADD  II32 (OpReg edx) (OpReg rhi),+                       MOV  II32 (OpReg eax) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do+   -- Performance sensitive users won't use 32 bit so let's keep it simple:+   -- We always return a (usually false) positive.+   Reg64 rhi rlo <- getNewReg64+   let code = toOL   [+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rhi),+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)+++-- To shift a 64-bit number to the left we use the SHLD and SHL instructions.+-- We use SHLD to shift the bits in @rhi@ to the left while copying+-- high bits from @rlo@ to fill the new space in the low bits of @rhi@.+-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left.+-- However, both these instructions only use the lowest 5 bits from %cl to do+-- their shifting. So if the sixth bit (0x32) is set then we additionally move+-- the contents of @rlo@ to @rhi@ and clear @rlo@.++iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   code2 <- getAnyReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 ecx `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi),+                       SHL II32 (OpReg ecx) (OpReg rlo),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rlo) (OpReg rhi),+                       XOR II32 (OpReg rlo) (OpReg rlo),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to above, however now we're shifting to the right+-- and we're doing a signed shift which means that @rhi@ needs+-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise,+-- and if the sixth bit of %cl is set (so the shift amount is more than 32).+-- To accomplish that we shift @rhi@ by 31.++iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpImm (ImmInt 31)) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to the above.++iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SHR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       XOR II32 (OpReg rhi) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2+iselExpr64 (CmmMachOp (MO_Or  _) [e1,e2]) = iselExpr64ParallelBin OR  e1 e2+iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2++iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       NOT II32 (OpReg rlo),+                       NOT II32 (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i)++iselExpr64 expr+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr))++iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr))+iselExpr64ParallelBin op 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),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       op  II32 (OpReg r2lo) (OpReg rlo),+                       op  II32 (OpReg r2hi) (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++--------------------------------------------------------------------------------++getRegister :: HasDebugCallStack => CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+                   is32Bit <- is32BitPlatform+                   getRegister' platform is32Bit e++getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal (GlobalRegUse 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)+        _ ->+          let ty = cmmRegType reg+              reg_fmt = cmmTypeFormat ty+          in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL++getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree r n++getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e])+  = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned)++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' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II8+  return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ])++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II16+  return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ])++-- 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 (GlobalRegUse PicBaseReg _)),+                                     CmmLit displacement])+ | not is32Bit =+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' _ _ (CmmMachOp mop []) =+  pprPanic "getRegister(x86): nullary MachOp" (text $ show mop)++getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+    avx    <- avxEnabled+    avx2   <- avx2Enabled+    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++      MO_FW_Bitcast W32 -> bitcast FF32 II32 x+      MO_WF_Bitcast W32 -> bitcast II32 FF32 x+      MO_FW_Bitcast W64 -> bitcast FF64 II64 x+      MO_WF_Bitcast W64 -> bitcast II64 FF64 x+      MO_WF_Bitcast {}  -> incorrectOperands+      MO_FW_Bitcast {}  -> incorrectOperands++      -- 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_FF_Conv from to -> invalidConversion from to+      MO_UU_Conv from to -> invalidConversion from to+      MO_SS_Conv from to -> invalidConversion from to+      MO_XX_Conv from to -> invalidConversion from to++      MO_FS_Truncate from to -> coerceFP2Int from to x+      MO_SF_Round    from to -> coerceInt2FP from to x++      MO_VF_Neg l w  | avx       -> vector_float_negate_avx l w x+                     | otherwise -> vector_float_negate_sse l w x+      -- SIMD NCG TODO: Support 256/512-bit integer vectors+      MO_VS_Neg l w -> getRegister' platform is32Bit (CmmMachOp (MO_V_Sub l w) [zero_vec, x])+        where zero_vec = CmmLit $ CmmVec $ replicate l $ CmmInt 0 w++      MO_VF_Broadcast l w+        | avx+        -> vector_float_broadcast_avx l w x+        | otherwise+        -> vector_float_broadcast_sse l w x+      MO_V_Broadcast l w+        | avx2, l * widthInBits w `elem` [128, 256] -- AVX-512 is not supported for now+        -> vector_int_broadcast_avx2 l w x+      MO_V_Broadcast 16 W8 -> vector_int8x16_broadcast x+      MO_V_Broadcast 8 W16 -> vector_int16x8_broadcast x+      MO_V_Broadcast 4 W32 -> vector_int32x4_broadcast x+      MO_V_Broadcast 2 W64 -> vector_int64x2_broadcast x+      MO_V_Broadcast {}+        -> pprPanic "Unsupported integer vector broadcast operation for: " (pdoc platform x)++      -- Binary MachOps+      MO_Add {}    -> incorrectOperands+      MO_Sub {}    -> incorrectOperands+      MO_Eq {}     -> incorrectOperands+      MO_Ne {}     -> incorrectOperands+      MO_Mul {}    -> incorrectOperands+      MO_S_MulMayOflo {} -> incorrectOperands+      MO_S_Quot {} -> incorrectOperands+      MO_S_Rem {}  -> incorrectOperands+      MO_U_Quot {} -> incorrectOperands+      MO_U_Rem {}  -> incorrectOperands+      MO_S_Ge {}   -> incorrectOperands+      MO_S_Le {}   -> incorrectOperands+      MO_S_Gt {}   -> incorrectOperands+      MO_S_Lt {}   -> incorrectOperands+      MO_U_Ge {}   -> incorrectOperands+      MO_U_Le {}   -> incorrectOperands+      MO_U_Gt {}   -> incorrectOperands+      MO_U_Lt {}   -> incorrectOperands+      MO_F_Add {}  -> incorrectOperands+      MO_F_Sub {}  -> incorrectOperands+      MO_F_Mul {}  -> incorrectOperands+      MO_F_Quot {} -> incorrectOperands+      MO_F_Eq {}   -> incorrectOperands+      MO_F_Ne {}   -> incorrectOperands+      MO_F_Ge {}   -> incorrectOperands+      MO_F_Le {}   -> incorrectOperands+      MO_F_Gt {}   -> incorrectOperands+      MO_F_Lt {}   -> incorrectOperands+      MO_F_Min {}  -> incorrectOperands+      MO_F_Max {}  -> incorrectOperands+      MO_And {}    -> incorrectOperands+      MO_Or {}     -> incorrectOperands+      MO_Xor {}    -> incorrectOperands+      MO_Shl {}    -> incorrectOperands+      MO_U_Shr {}  -> incorrectOperands+      MO_S_Shr {}  -> incorrectOperands++      MO_V_Extract {}     -> incorrectOperands+      MO_V_Add {}         -> incorrectOperands+      MO_V_Sub {}         -> incorrectOperands+      MO_V_Mul {}         -> incorrectOperands+      MO_V_Shuffle {}     -> incorrectOperands+      MO_VF_Shuffle {}    -> incorrectOperands+      MO_VU_Min {}  -> incorrectOperands+      MO_VU_Max {}  -> incorrectOperands+      MO_VS_Min {}  -> incorrectOperands+      MO_VS_Max {}  -> incorrectOperands+      MO_VF_Min {}  -> incorrectOperands+      MO_VF_Max {}  -> incorrectOperands++      MO_VF_Extract {}    -> incorrectOperands+      MO_VF_Add {}        -> incorrectOperands+      MO_VF_Sub {}        -> incorrectOperands+      MO_VF_Mul {}        -> incorrectOperands+      MO_VF_Quot {}       -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {}           -> incorrectOperands+      MO_VF_Insert {}     -> incorrectOperands+      MO_V_Insert {}      -> incorrectOperands++      --_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)++        bitcast :: Format -> Format -> CmmExpr -> NatM Register+        bitcast fmt rfmt expr =+          do (src, e_code) <- getSomeReg expr+             let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst))+             return (Any rfmt 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)++        vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_avx l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm.+                       _ -> panic "AVX floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VXOR fmt (OpReg maskReg) dst dst)+          return (Any fmt code)++        vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_sse l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values.+                       _ -> panic "SSE floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (XOR  fmt (OpReg maskReg) (OpReg dst))+          return (Any fmt code)++        -----------------------++        -- TODO: we could use VBROADCASTSS/SD when AVX2 is available.+        vector_float_broadcast_avx :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_avx len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_float_broadcast_sse :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_sse len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = SHUF fmt (ImmInt 0) (OpReg dst) dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_int_broadcast_avx2 :: Length+                                  -> Width+                                  -> CmmExpr+                                  -> NatM Register+        vector_int_broadcast_avx2 len w expr = do+          (reg, exp) <- getNonClobberedReg expr+          let (movFormat, fmt) = case w of+                W8  -> (II32, VecFormat len FmtInt8)+                W16 -> (II32, VecFormat len FmtInt16)+                W32 -> (II32, VecFormat len FmtInt32)+                W64 -> (II64, VecFormat len FmtInt64)+                _   -> pprPanic "Broadcast not supported for: " (pdoc platform expr)+              code dst = exp `snocOL`+                         -- VPBROADCAST from GPR requires AVX-512,+                         -- so we use an additional MOVD.+                         (MOVD movFormat fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VPBROADCAST fmt fmt (OpReg dst) dst)+          return $ Any fmt code++        vector_int8x16_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int8x16_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 16 FmtInt8+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLBW fmt (OpReg dst) dst) `snocOL`+                                    (PUNPCKLWD (VecFormat 8 FmtInt16) (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int16x8_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int16x8_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 8 FmtInt16+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLWD fmt (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int32x4_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int32x4_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 4 FmtInt32+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int64x2_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int64x2_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 2 FmtInt64+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLQDQ fmt (OpReg dst) dst)+                                    )++getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+  sse4_1 <- sse4_1Enabled+  sse4_2 <- sse4_2Enabled+  avx <- avxEnabled+  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 (\fmt op2 -> ADD fmt op2 . OpReg) x y+      MO_F_Sub  w -> trivialFCode_sse2 w (\fmt op2 -> SUB fmt op2 . OpReg) x y+      MO_F_Quot w -> trivialFCode_sse2 w FDIV x y+      MO_F_Mul  w -> trivialFCode_sse2 w (\fmt op2 -> MUL fmt op2 . OpReg) x y+      MO_F_Min  w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y+      MO_F_Max  w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) 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_VF_Shuffle 4 W32 is | avx -> vector_shuffle_float_avx 4 x y is+                             | otherwise -> vector_shuffle_floatx4_sse sse4_1 x y is+      MO_VF_Shuffle 2 W64 is | avx -> vector_shuffle_double_avx 2 x y is+                             | otherwise -> vector_shuffle_doublex2_sse x y is+      MO_VF_Shuffle {} -> sorry "Please use -fllvm for wide shuffle instructions"++      MO_VF_Extract l W32   | avx       -> vector_float_extract l W32 x y+                            | otherwise -> vector_float_extract_sse l W32 x y+      MO_VF_Extract l W64               -> vector_float_extract l W64 x y+      MO_VF_Extract {} -> incorrectOperands++      MO_V_Extract 16 W8 | sse4_1 -> vector_int_extract_pextr 16 W8 x y+                         | otherwise -> vector_int8x16_extract_sse2 x y+      MO_V_Extract 8 W16 -> vector_int_extract_pextr 8 W16 x y -- PEXTRW (SSE2)+      MO_V_Extract 4 W32 | sse4_1 -> vector_int_extract_pextr 4 W32 x y+                         | otherwise -> vector_int32x4_extract_sse2 x y+      MO_V_Extract 2 W64 | sse4_1 -> vector_int_extract_pextr 2 W64 x y+                         | otherwise -> vector_int64x2_extract_sse2 x y+      -- SIMD NCG TODO: 256/512-bit vector+      MO_V_Extract {} -> needLlvm mop++      MO_VF_Add l w         | avx       -> vector_float_op_avx VADD l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> ADD fmt op2 . OpReg) l w x y++      MO_VF_Sub l w         | avx       -> vector_float_op_avx VSUB l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> SUB fmt op2 . OpReg) l w x y++      MO_VF_Mul l w         | avx       -> vector_float_op_avx VMUL l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> MUL fmt op2 . OpReg) l w x y++      MO_VF_Quot l w        | avx       -> vector_float_op_avx VDIV l w x y+                            | otherwise -> vector_float_op_sse FDIV l w x y++      MO_VF_Min l w         | avx       -> vector_float_op_avx (VMINMAX Min FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Min FloatMinMax) l w x y++      MO_VF_Max l w         | avx       -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y++      -- SIMD NCG TODO: 256/512-bit integer vector operations+      MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is+      MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is+      MO_V_Shuffle 4 W32 is -> vector_shuffle_int32x4 sse4_1 x y is+      MO_V_Shuffle 2 W64 is -> vector_shuffle_int64x2 sse4_1 x y is+      MO_V_Shuffle {} -> needLlvm mop+      MO_V_Add l w | l * widthInBits w == 128 -> vector_int_op_sse PADD l w x y+                   | otherwise -> needLlvm mop+      MO_V_Sub l w | l * widthInBits w == 128 -> vector_int_op_sse PSUB l w x y+                   | otherwise -> needLlvm mop+      MO_V_Mul 16 W8 -> vector_int8x16_mul_sse2 x y+      MO_V_Mul l@8 w@W16 -> vector_int_op_sse PMULL l w x y -- PMULLW (SSE2)+      MO_V_Mul l@4 w@W32 | sse4_1 -> vector_int_op_sse PMULL l w x y -- PMULLD (SSE4.1)+                         | otherwise -> vector_int32x4_mul_sse2 x y+      MO_V_Mul 2 W64 -> vector_int64x2_mul_sse2 x y+      MO_V_Mul {} -> needLlvm mop++      MO_VU_Min l@16 w@W8+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUB (SSE2)+      MO_VU_Min l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Min)+      MO_VU_Min {} -> needLlvm mop+      MO_VU_Max l@16 w@W8+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUB (SSE2)+      MO_VU_Max l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Max)+      MO_VU_Max {} -> needLlvm mop+      MO_VS_Min l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@8 w@W16+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSW (SSE2)+      MO_VS_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Min)+      MO_VS_Min {} -> needLlvm mop+      MO_VS_Max l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@8 w@W16+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSW (SSE2)+      MO_VS_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Max)+      MO_VS_Max {} -> needLlvm mop++      -- Unary MachOps+      MO_S_Neg {} -> incorrectOperands+      MO_F_Neg {} -> incorrectOperands+      MO_Not {} -> incorrectOperands+      MO_SF_Round {} -> incorrectOperands+      MO_FS_Truncate {} -> incorrectOperands+      MO_SS_Conv {} -> incorrectOperands+      MO_XX_Conv {} -> incorrectOperands+      MO_FF_Conv {} -> incorrectOperands+      MO_UU_Conv {} -> incorrectOperands+      MO_WF_Bitcast {} -> incorrectOperands+      MO_FW_Bitcast  {} -> incorrectOperands+      MO_RelaxedRead {} -> incorrectOperands+      MO_AlignmentCheck {} -> incorrectOperands+      MO_VS_Neg {} -> incorrectOperands+      MO_VF_Neg {} -> incorrectOperands+      MO_V_Broadcast {} -> incorrectOperands+      MO_VF_Broadcast {} -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {} -> incorrectOperands+      MO_V_Insert {} -> incorrectOperands+      MO_VF_Insert {} -> incorrectOperands++  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 W8 a b = do+         -- The general case (W16, W32, W64) doesn't work for W8 as its+         -- multiplication doesn't use two registers.+         --+         -- The plan is:+         -- 1. truncate and sign-extend a and b to 8bit width+         -- 2. multiply a' = a * b in 32bit width+         -- 3. copy and sign-extend 8bit from a' to c+         -- 4. compare a' and c: they are equal if there was no overflow+         (a_reg, a_code) <- getNonClobberedReg a+         (b_reg, b_code) <- getNonClobberedReg b+         let+             code = a_code `appOL` b_code `appOL`+                        toOL [+                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),+                           IMUL II32 (OpReg b_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg a_reg) (OpReg eax),+                           CMP II16 (OpReg a_reg) (OpReg eax),+                           SETCC NE (OpReg eax)+                        ]+         return (Fixed II8 eax code)+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W16 -> 15+                           W32 -> 31+                           W64 -> 63+                           w -> panic ("shift_amt: " ++ show w)++             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+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = 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)+        , 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 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)++    -----------------------+    -- Vector operations---+    vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr)+                        -> Length+                        -> Width+                        -> CmmExpr+                        -> CmmExpr+                        -> NatM Register+    vector_float_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point AVX vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_op_avx_reg :: (Format -> Reg -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_avx_reg instr format expr1 expr2 = do+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let -- opcode src2 src1 dst <==> dst = src1 `opcode` src2+          code dst = exp1 `appOL` exp2 `snocOL`+                     (instr format reg2 reg1 dst)+      return (Any format code)++    vector_float_op_sse :: (Format -> Operand -> Reg -> Instr)+                        -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_float_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point SSE vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_int_op_sse :: (Format -> Operand -> Reg -> Instr)+                      -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W8 -> VecFormat l FmtInt8+                       W16 -> VecFormat l FmtInt16+                       W32 -> VecFormat l FmtInt32+                       W64 -> VecFormat l FmtInt64+                       _ -> pprPanic "Integer SSE vector operation not supported at this width"+                              (text "width:" <+> ppr w)++    -- This function is similar to genTrivialCode, but re-using it would require+    -- handling alignment correctly: SSE vector instructions typically require 16-byte+    -- alignment for their memory operand (this restriction is relaxed with VEX-encoded+    -- instructions).+    -- For now, we always load the value into a register and avoid the alignment issue.+    vector_op_sse :: (Format -> Operand -> Reg -> Instr)+                  -> Format+                  -> CmmExpr+                  -> CmmExpr+                  -> NatM Register+    vector_op_sse instr = vector_op_sse_reg (\fmt -> instr fmt . OpReg)++    vector_op_sse_reg :: (Format -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_sse_reg instr format expr1 expr2 = do+      config <- getConfig+      exp1_code <- getAnyReg expr1+      (reg2, exp2_code) <- getSomeReg expr2 -- vector registers are never clobbered by an instruction+      tmp <- getNewRegNat format+      let code dst+            -- opcode src2 src1 <==> src1 = src1 `opcode` src2+            | dst == reg2 = exp2_code `snocOL`+                            movInstr config format (OpReg reg2) (OpReg tmp) `appOL` -- MOVU or MOVDQU+                            exp1_code dst `snocOL`+                            instr format tmp dst+            | otherwise = exp2_code `appOL`+                          exp1_code dst `snocOL`+                          instr format reg2 dst+      return (Any format code)+    --------------------+    vector_float_extract :: Length+                         -> Width+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    vector_float_extract l W32 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract _ W64 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL`+                              (MOV FF64 (OpReg r) (OpReg dst))+                CmmInt 1 _ -> exp `snocOL`+                              (MOVHLPS FF64 r dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF64 code)+    vector_float_extract _ w c e =+      pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    vector_float_extract_sse :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_float_extract_sse l W32 expr (CmmLit lit)+      = do+      (r,exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract_sse _ w c e+      = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    -- PEXTRW ("to GPR" variant) is an SSE2 instruction,+    -- whereas PEXTR{B,D,Q} and PEXTRW ("to memory" variant) require SSE4.1.+    vector_int_extract_pextr :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_int_extract_pextr l w expr (CmmLit (CmmInt i _))+      | 0 <= i, i < toInteger l+      = do+      (r, exp) <- getSomeReg expr -- vector registers are never clobbered by an instruction+      let (scalarFormat, vectorFormat) = case w of+            W8 -> (II32, VecFormat l FmtInt8)+            W16 -> (II32, VecFormat l FmtInt16)+            W32 -> (II32, VecFormat l FmtInt32)+            W64 -> (II64, VecFormat l FmtInt64)+            _ -> sorry "Unsupported vector format"+          code dst = exp `snocOL`+                     (PEXTR scalarFormat vectorFormat (ImmInteger i) r (OpReg dst))+      return (Any scalarFormat code)+    vector_int_extract_pextr _ _ _ i+      = pprPanic "Unsupported offset" (pdoc platform i)++    vector_int8x16_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int8x16_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 16+      = do+      (r, exp) <- getSomeReg expr+      let code dst =+            case i `quotRem` 2 of+              (j, 0) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) -- PEXTRW+              (j, _) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) `snocOL` -- PEXTRW+                        (SHR II32 (OpImm (ImmInt 8)) (OpReg dst))+      return (Any II8 code)+    vector_int8x16_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int32x4_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int32x4_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 4+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 4 FmtInt32+      tmp <- getNewRegNat fmt+      let code dst =+            case i of+              0 -> exp `snocOL`+                   (MOVD fmt II32 (OpReg r) (OpReg dst))+              1 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b01_01_01_01) (OpReg r) tmp) `snocOL` -- tmp <- (r[1],r[1],r[1],r[1])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              2 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_10_11_10) (OpReg r) tmp) `snocOL` -- tmp <- (r[2],r[3],r[2],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              _ -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_11_11_11) (OpReg r) tmp) `snocOL` -- tmp <- (r[3],r[3],r[3],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+      return (Any II32 code)+    vector_int32x4_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int64x2_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int64x2_extract_sse2 expr (CmmLit lit)+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 2 FmtInt64+      tmp <- getNewRegNat fmt+      let code dst =+            case lit of+              CmmInt 0 _ -> exp `snocOL`+                            (MOVD fmt II64 (OpReg r) (OpReg dst))+              CmmInt 1 _ -> exp `snocOL`+                            (MOVHLPS FF64 r tmp) `snocOL`+                            (MOVD fmt II64 (OpReg tmp) (OpReg dst))+              _          -> panic "Error in offset while unpacking"+      return (Any II64 code)+    vector_int64x2_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int8x16_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int8x16_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULLW (low 16 bits of int16 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 16 FmtInt8+          format16 = VecFormat 8 FmtInt16 -- for PMULLW+      tmp1lo <- getNewRegNat format+      tmp1hi <- getNewRegNat format+      tmp2hi <- getNewRegNat format+      tmp2lo <- getNewRegNat format+      (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate 8 (CmmInt 0xff W16)) -- (0xff,0,0xff,0,...,0xff,0) :: Int8X16+      let code = exp1 `appOL` exp2 `appOL` maskCode `snocOL`+                 (MOVDQU format (OpReg reg1) (OpReg tmp1lo)) `snocOL` -- tmp1lo <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2lo)) `snocOL` -- tmp2lo <- reg2+                 (PUNPCKLBW format (OpReg reg1) tmp1lo) `snocOL`      -- tmp1lo <- (tmp1lo[0],reg1[0],tmp1lo[1],reg1[1],...,tmp1lo[7],reg1[7]); The first operand does not really matter+                 (PUNPCKLBW format (OpReg reg2) tmp2lo) `snocOL`      -- tmp2lo <- (tmp2lo[0],reg2[0],tmp2lo[1],reg2[1],...,tmp2lo[7],reg2[7]); The first operand does not really matter+                 (MOVDQU format (OpReg reg1) (OpReg tmp1hi)) `snocOL` -- tmp1hi <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2hi)) `snocOL` -- tmp2hi <- reg2+                 (PUNPCKHBW format (OpReg reg1) tmp1hi) `snocOL`      -- tmp1hi <- (tmp1hi[8],reg1[8],tmp1hi[9],reg1[9],...,tmp1hi[15],reg1[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2lo) tmp1lo) `snocOL`      -- PMULLW; tmp1lo <- (tmp1lo[0]*tmp2lo[0],*,tmp1lo[2]*tmp2lo[2],*,...,tmp1lo[14]*tmp2lo[14],*)+                 (PUNPCKHBW format (OpReg reg2) tmp2hi) `snocOL`      -- tmp2hi <- (tmp2hi[8],reg2[8],tmp2hi[9],reg2[9],...,tmp2hi[15],reg2[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2hi) tmp1hi) `snocOL`      -- PMULLW; tmp1hi <- (tmp1hi[0]*tmp2hi[0],*,tmp1hi[2]*tmp2hi[2],*,...,tmp1hi[14]*tmp2hi[14],*)+                 (PAND format (OpReg maskReg) tmp1lo) `snocOL`        -- tmp1lo <- (tmp1lo[0],0,tmp1lo[2],0,...,tmp1lo[14],0)+                 (PAND format (OpReg maskReg) tmp1hi) `snocOL`        -- tmp1hi <- (tmp1hi[0],0,tmp1hi[2],0,...,tmp1hi[14],0)+                 (PACKUSWB format (OpReg tmp1hi) tmp1lo)              -- tmp1lo <- (tmp1lo[0],tmp1lo[2],...,tmp1lo[14],tmp1hi[0],tmp1hi[2],...tmp1hi[14])+      return (Fixed format tmp1lo code)++    vector_int32x4_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int32x4_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULUDQ (int32 x int32 -> int64 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 4 FmtInt32+      tmpEven <- getNewRegNat format+      tmpOdd1 <- getNewRegNat format+      tmpOdd2 <- getNewRegNat format+      let code dst = exp1 `appOL` exp2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg tmpEven)) `snocOL`                   -- tmpEven <- reg1+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg1) tmpOdd1) `snocOL`    -- tmpOdd1 <- (reg1[1],reg1[1],reg1[3],reg1[3])+                     (PMULUDQ format (OpReg reg2) tmpEven) `snocOL`                          -- tmpEven <- (tmpEven[0]*reg2[0],*,tmpEven[2]*reg2[2],*)+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg2) tmpOdd2) `snocOL`    -- tmpOdd2 <- (reg2[1],reg2[1],reg2[3],reg2[3])+                     (PMULUDQ format (OpReg tmpOdd2) tmpOdd1) `snocOL`                       -- tmpOdd1 <- (tmpOdd1[0]*tmpOdd2[0],*,tmpOdd1[2]*tmpOdd2[2],*)+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpEven) dst) `snocOL`     -- dst <- (tmpEven[0],tmpEven[2],tmpEven[0],tmpEven[0])+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpOdd1) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0],tmpOdd1[2],tmpOdd1[0],tmpOdd1[0])+                     (PUNPCKLDQ format (OpReg tmpOdd1) dst)                                  -- dst <- (dst[0],tmpOdd1[0],dst[1],tmpOdd1[1])+      return (Any format code)++    -- TODO: We could use `VPMULLQ` if AVX-512 or AVX10.1 is available.+    vector_int64x2_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int64x2_mul_sse2 expr1 expr2 = do+      -- implement 64 bit multiplication using 32-bit PMULUDQ multiplication instructions+      -- (lo1 + shiftL hi1 32) * (lo2 + shiftL hi2 32) = lo1 * lo2 + shiftL (lo1 * hi2) 32 + shiftL (lo2 * hi1) 32+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = VecFormat 2 FmtInt64+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1Hi <- getNewRegNat format+      tmp2Hi <- getNewRegNat format+      let code dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`    -- dst <- reg1+                     (MOVDQU format (OpReg reg1) (OpReg tmp1Hi)) `snocOL` -- tmp1Hi <- reg1+                     (MOVDQU format (OpReg reg2) (OpReg tmp2Hi)) `snocOL` -- tmp2Hi <- reg2+                     (PSRL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSRLQ (logical shift); tmp1Hi <- (tmp1Hi[0] >> 32, tmp1Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) dst) `snocOL`           -- dst <- ((dst as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (dst as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PSRL format (OpImm (ImmInt 32)) tmp2Hi) `snocOL`    -- PSRLQ (logical shift); tmp2Hi <- (tmp2Hi[0] >> 32, tmp2Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) tmp1Hi) `snocOL`        -- tmp1Hi <- ((tmp1Hi as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (tmp1Hi as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PMULUDQ format (OpReg reg1) tmp2Hi) `snocOL`        -- tmp2Hi <- ((tmp2Hi as Word32X4)[0] * (reg1 as Word32X4)[0] as Word64, (tmp2Hi as Word32X4)[2] * (reg1 as Word32X4)[2] as Word64)+                     (PADD format (OpReg tmp2Hi) tmp1Hi) `snocOL`         -- PADDQ; tmp1Hi <- (tmp1Hi[0] + tmp2Hi[0], tmp1Hi[1] + tmp2Hi[1])+                     (PSLL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSLLQ; tmp1Hi <- (tmp1Hi[0] << 32, tmp1Hi[1] << 32)+                     (PADD format (OpReg tmp1Hi) dst)                     -- PADDQ; dst <- (dst[0] + tmp1Hi[0], dst[1] + tmp1Hi[1])+      return (Any format code)++    vector_int_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = case w of+            W8 -> VecFormat l FmtInt8+            W16 -> VecFormat l FmtInt16+            W32 -> VecFormat l FmtInt32+            W64 -> VecFormat l FmtInt64+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp <- getNewRegNat format+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp)) `snocOL` -- tmp <- reg2+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`          -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg1) (OpReg tmp)) `snocOL` -- tmp <- reg1+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`          -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_word_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_word_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      -- We can use PCMPGT to compare unsigned integers by flipping the most significant bit.+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let (format, sign) = case w of+            W8 -> (VecFormat l FmtInt8, 0x80)+            W16 -> (VecFormat l FmtInt16, 0x8000)+            W32 -> (VecFormat l FmtInt32, 2^(31 :: Int))+            W64 -> (VecFormat l FmtInt64, 2^(63 :: Int))+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1 <- getNewRegNat format+      tmp2 <- getNewRegNat format+      (signReg, signCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l (CmmInt sign w))+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg2) (OpReg tmp2)) `snocOL` -- tmp2 <- reg2+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 < dst ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`           -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg1) (OpReg tmp2)) `snocOL` -- tmp2 <- reg1+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 <- tmp1 ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`           -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_shuffle_floatx4_sse :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_floatx4_sse sse4_1 v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat 4 FmtFloat++            -- A helper function to shuffle a vector `r` in-place using (dst,src) pairs+            -- (r[d0],r[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 -> nilOL -- trivial+                0b01_00_01_00 -> unitOL (MOVLHPS fmt r r)+                0b11_10_11_10 -> unitOL (MOVHLPS fmt r r)+                0b01_01_00_00 -> unitOL (UNPCKL fmt (OpReg r) r)+                0b11_11_10_10 -> unitOL (UNPCKH fmt (OpReg r) r)+                _ -> unitOL (SHUF fmt (ImmInt mask) (OpReg r) r)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              exp <- getAnyReg v+              let code dst = exp dst `appOL`+                             inplaceShuffle [p0,p1,p2,p3] dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_op_sse UNPCKL fmt v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_op_sse UNPCKL fmt v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_op_sse UNPCKH fmt v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_op_sse UNPCKH fmt v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if sse4_1 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                in vector_op_sse (`BLEND` (ImmInt imm)) fmt v1 v2+              else do+                let imm = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_op_sse (`SHUF` (ImmInt imm)) fmt v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | sse4_1 = do -- Use INSERTPS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                let imm2 = (snd q0 `shiftL` 6) .|. (fst q0 `shiftL` 4)+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,fst q0)] dst `snocOL`+                           (INSERTPS fmt (ImmInt imm2) (OpReg r2) dst)+                return $ Fixed fmt dst code++              | (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use MOVSS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `snocOL`+                           (MOV fmt (OpReg r2) (OpReg dst)) `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,0)] dst+                return $ Fixed fmt dst code++              | otherwise = do -- Use two or three SHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (SHUF fmt (ImmInt imm1) (OpReg r1) dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (SHUF fmt (ImmInt imm2) (OpReg r1) dst) `appOL`+                           inplaceShuffle pairs dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 8 && is == [0,2,5,7]` would represent `shuffleFloatX8# _ _ (# 0#, 2#, 9#, 11#, 4#, 6#, 13#, 15# #)`.+    vector_shuffle_float_avx :: Length -- Vector length. 4 for XMM, 8 for YMM, 16 for ZMM.+                             -> CmmExpr+                             -> CmmExpr+                             -> [Int] -- 4-element list of indices+                             -> NatM Register+    vector_shuffle_float_avx l v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat l FmtFloat++            -- A helper function to shuffle a vector using (dst,src) pairs+            -- (dst[d0],dst[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r dst = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 | r == dst -> nilOL+                              | otherwise -> unitOL (VMOVU fmt (OpReg r) (OpReg dst)) -- trivial+                0b01_00_01_00 | l == 4 -> unitOL (VMOVLHPS fmt r r dst) -- 128-bit only+                0b11_10_11_10 | l == 4 -> unitOL (VMOVHLPS fmt r r dst) -- 128-bit only+                0b01_01_00_00 -> unitOL (VUNPCKL fmt (OpReg r) r dst)+                0b11_11_10_10 -> unitOL (VUNPCKH fmt (OpReg r) r dst)+                _ -> unitOL (VSHUF fmt (ImmInt mask) (OpReg r) r dst)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              (r, exp) <- getSomeReg v+              let code dst = exp `appOL`+                             inplaceShuffle [p0,p1,p2,p3] r dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if l <= 8 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                -- VBLENDPS does not support ZMM (no EVEX-encoded variant)+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                    imm' = if l == 4 then imm .|. (imm `shiftL` 4) else imm+                in vector_float_op_avx (`VBLEND` (ImmInt imm')) l W32 v1 v2+              else do+                let imm1 = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_float_op_avx (`VSHUF` (ImmInt imm1)) l W32 v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | l == 4, (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use VMOVSS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let code dst = exp1 `appOL` exp2 `snocOL`+                               (VMOV_MERGE fmt r2 r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,0)] dst dst+                return $ Any fmt code++              | l == 4 = do -- Use VINSERTPS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let i = case [0, 1, 2, 3] \\ [snd p0, snd p1, snd p2] of+                          i:_ -> i -- We can clobber this position of r1+                          _ -> panic "cannot occur"+                    imm = (snd q0 `shiftL` 6) .|. (i `shiftL` 4)+                    code dst = exp1 `appOL` exp2 `snocOL`+                               (VINSERTPS fmt (ImmInt imm) (OpReg r2) r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,i)] dst dst+                return $ Any fmt code++              | otherwise = do -- Use two or three VSHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (VSHUF fmt (ImmInt imm1) (OpReg r1) dst dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (VSHUF fmt (ImmInt imm2) (OpReg r1) dst dst) `appOL`+                           inplaceShuffle pairs dst dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    vector_shuffle_doublex2_sse :: CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_doublex2_sse v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat 2 FmtDouble+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- MOVSD/UNPCKLPD/UNPCKHPD have shorter encoding than SHUFPD+          -- If SSE4.1 is available, BLENDPD could also be used in place of MOVSD (the encoding is longer though)+          (0, 3) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v2 v1 -- MOVSD+          (2, 1) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v1 v2 -- MOVSD+          _ | i0 == i1 -> do+            exp <- getAnyReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then UNPCKL+                        else UNPCKH+                code dst = exp dst `snocOL`+                           (unpck fmt (OpReg dst) dst)+            return (Any fmt code)+          (0, 2) -> vector_op_sse UNPCKL fmt v1 v2+          (2, 0) -> vector_op_sse UNPCKL fmt v2 v1+          (1, 3) -> vector_op_sse UNPCKH fmt v1 v2+          (3, 1) -> vector_op_sse UNPCKH fmt v2 v1++          -- SHUFPD+          (1, 2) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v1 v2+          (3, 0) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v2 v1+          (1, 0) -> do+            exp <- getAnyReg v1+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          (3, 2) -> do+            exp <- getAnyReg v2+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 4 && is == [0,3]` would represent `shuffleDoubleX4# _ _ (# 0#, 5#, 2#, 7# #)`.+    vector_shuffle_double_avx :: Length -- Vector length. 2 for XMM, 4 for YMM, 8 for ZMM.+                              -> CmmExpr+                              -> CmmExpr+                              -> [Int] -- 2-element list of indices+                              -> NatM Register+    vector_shuffle_double_avx l v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat l FmtDouble+            repeatShufpdMask m = case l of+              8 -> m .|. (m `shiftL` 2) .|. (m `shiftL` 4) .|. (m `shiftL` 6)+              4 -> m .|. (m `shiftL` 2)+              _ -> m+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- VMOVSD/VUNPCKLPD/VUNPCKHPD have shorter encoding than VSHUFPD+          (0, 3) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r1 r2 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v1 v2+          (2, 1) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r2 r1 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v2 v1+          _ | i0 == i1 -> do+            (r, exp) <- getSomeReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then VUNPCKL+                        else VUNPCKH+                code dst = exp `snocOL`+                           (unpck fmt (OpReg r) r dst)+            return (Any fmt code)+          (0, 2) -> vector_float_op_avx VUNPCKL l W64 v1 v2+          (2, 0) -> vector_float_op_avx VUNPCKL l W64 v2 v1+          (1, 3) -> vector_float_op_avx VUNPCKH l W64 v1 v2+          (3, 1) -> vector_float_op_avx VUNPCKH l W64 v2 v1++          -- SHUFPD+          (1, 2) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v1 v2+          (3, 0) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v2 v1+          (1, 0) -> do+            (r, exp) <- getSomeReg v1+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          (3, 2) -> do+            (r, exp) <- getSomeReg v2+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    isZeroVecLit :: CmmExpr -> Bool+    isZeroVecLit (CmmLit (CmmVec elems)) = all (\lit -> case lit of CmmInt 0 _ -> True; _ -> False) elems+    isZeroVecLit _ = False++    vector_shuffle_int128_common :: Bool -> Format -> CmmExpr -> CmmExpr -> [Int] -> Maybe (NatM Register)+    vector_shuffle_int128_common sse4_1 fmt v1 v2 is+      | length is == n, all (\i -> 0 <= i && i < 2 * n) is = if+        -- Trivial cases+        | is == [0..n-1] -> Just $ getRegister' platform is32Bit v1+        | is == [n..2*n-1] -> Just $ getRegister' platform is32Bit v2++        -- We would like to emit PXOR for these trivial cases, instead of PSLLDQ.+        -- These conditions can be generalized to the cases where all elements are equal,+        -- or more generally, a constant-folding rule.+        | v1IsZero, all (< n) is -> Just $ getRegister' platform is32Bit v1+        | v2IsZero, all (>= n) is -> Just $ getRegister' platform is32Bit v2++        -- PSLLDQ: v2 == 0 && is == [n..(2n-1),...,n..(2n-1);0,1,2,3,...,n-i-1]+        | v2IsZero, (z, js) <- span (>= n) is, and (zipWith (==) js [0..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSLLDQ: v1 == 0 && is == [0..(n-1),...,0..(n-1);n,n+1,...,2n-i-1]+        | v1IsZero, (z, js) <- span (< n) is, and (zipWith (==) js [n..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v2 == 0 && is == [i,i+1,...,n-2,n-1;n..(2n-1),...,n..(2n-1)]+        | v2IsZero, (js, z) <- span (< n) is, all (>= n) z, and (zipWith (==) (reverse js) [n-1,n-2..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v1 == 0 && is == [n+i,...,2n-2,2n-1;0..(n-1),...,0..(n-1)]+        | v1IsZero, (js, z) <- span (>= n) is, all (< n) z, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [i,i+1,...,n-2,n-1;n,n+1,...,n+i-1]+        | (js, ks) <- span (< n) is, and (zipWith (==) (reverse js) [n-1,n-2..]), and (zipWith (==) ks [n..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v2 v1+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp1 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp2 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [n+i,n+i+1,...,2n-2,2n-1;0,1,...,i-1]+        | (js, ks) <- span (>= n) is, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]), and (zipWith (==) ks [0..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v1 v2+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp2 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp1 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PBLENDW (SSE4.1): map (`mod` n) is == [0,1,...,n-1] if widthInBytes >= 2+        | sse4_1, widthInBytes >= 2, and (zipWith (\i j -> i `rem` n == j) is [0..]) -> Just $ do+          let k = widthInBytes `quot` 2+              m = bit k - 1+              imm = foldr (\i acc -> if i >= n then (acc `shiftL` k) .|. m else acc `shiftL` k) 0 is+          vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++        | otherwise -> Nothing++      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)+      where+        (n, widthInBytes) = case fmt of+          VecFormat 16 FmtInt8 -> (16, 1)+          VecFormat 8 FmtInt16 -> (8, 2)+          VecFormat 4 FmtInt32 -> (4, 4)+          VecFormat 2 FmtInt64 -> (2, 8)+          _ -> pprPanic "Invalid format" (ppr fmt)+        v1IsZero = isZeroVecLit v1+        v2IsZero = isZeroVecLit v2++    vector_shuffle_int8x16 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int8x16 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        ssse3 <- ssse3Enabled+        let fmtInt16X8 = VecFormat 8 FmtInt16+            v1IsZero = isZeroVecLit v1+            v2IsZero = isZeroVecLit v2+            tryInt16X8Mask [] = Just []+            tryInt16X8Mask (j0:j1:js)+              | even j0, j1 == j0 + 1 = (j0 `quot` 2 :) <$> tryInt16X8Mask js+            tryInt16X8Mask _ = Nothing+        if+          -- PUNPCKLBW / PUNPCKHBW+          | [0,16,1,17,2,18,3,19,4,20,5,21,6,22,7,23] <- is -> vector_op_sse PUNPCKLBW fmt v1 v2+          | [16,0,17,1,18,2,19,3,20,4,21,5,22,6,23,7] <- is -> vector_op_sse PUNPCKLBW fmt v2 v1+          | [8,24,9,25,10,26,11,27,12,28,13,29,14,30,15,31] <- is -> vector_op_sse PUNPCKHBW fmt v1 v2+          | [24,8,25,9,26,10,27,11,28,12,29,13,30,14,31,15] <- is -> vector_op_sse PUNPCKHBW fmt v2 v1++          -- PSHUFB (SSSE3)+          | ssse3, all (< 16) is || v2IsZero -> do+            exp1 <- getAnyReg v1+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            let code dst = exp1 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) dst)+            return (Any fmt code)++          -- PSHUFB (SSSE3)+          | ssse3, all (>= 16) is || v1IsZero -> do+            exp2 <- getAnyReg v2+            let mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp2 dst `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst)+            return (Any fmt code)++          -- PBLENDW (SSE4.1): js <- tryInt16X8Mask is, map (`mod` 8) js == [0,1,...,7]+          | sse4_1, Just js <- tryInt16X8Mask is, and (zipWith (\i j -> i `rem` 8 == j) js [0..]) -> do+            let imm = foldr (\i acc -> if i >= 8 then (acc `shiftL` 1) .|. 1 else acc `shiftL` 1) 0 js+            vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++          -- General case with SSSE3: PSHUFB + PSHUFB + POR+          | ssse3 -> do+            exp1 <- getAnyReg v1+            exp2 <- getAnyReg v2+            tmp1 <- getNewRegNat fmt+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+                mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp1 tmp1 `appOL` exp2 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) tmp1) `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst) `snocOL`+                           (POR fmt (OpReg tmp1) dst)+            return (Any fmt code)++          -- General case with SSE2: GPR + MOVQ + PUNPCKLQDQ+          | otherwise -> do+            (r1, exp1) <- getSomeReg v1+            (r2, exp2) <- getSomeReg v2+            tmp <- getNewRegNat II64+            tmpLo <- getNewRegNat II64+            tmpHi <- getNewRegNat II64+            tmpXmm <- getNewRegNat fmt+            dst <- getNewRegNat fmt+            let place8Bits srcPos dstPos dst =+                  -- Assumption: 0 <= srcPos < 32, 0 <= dstPos < 8+                  -- tmp <- (src[srcPos] `shiftR` ((srcPos `rem` 16) * 8)) .&. 0xff+                  -- dst <- dst .|. (tmp `shiftL` (dstPos * 8))+                  let r = if srcPos < 16 then r1 else r2+                  in case (srcPos `rem` 16) `quotRem` 2 of+                      (k, 0) -> toOL [ PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)+                                     , MOVZxL II8 (OpReg tmp) (OpReg tmp)+                                     , SHL II64 (OpImm (ImmInt (8 * dstPos))) (OpReg tmp)+                                     , OR II64 (OpReg tmp) (OpReg dst)+                                     ]+                      (k, _) -> (PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)) `consOL`+                                ((case dstPos of+                                    0 -> unitOL (SHR II32 (OpImm (ImmInt 8)) (OpReg tmp))+                                    1 -> unitOL (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp))+                                    _ -> toOL [ AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)+                                              , SHL II64 (OpImm (ImmInt (8 * (dstPos - 1)))) (OpReg tmp) ]) `snocOL`+                                 (OR II64 (OpReg tmp) (OpReg dst)))+                makeInt8x8OnGPR dst js = (XOR II32 (OpReg dst) (OpReg dst)) `consOL`+                                         concatOL [ place8Bits srcPos dstPos dst | (srcPos, dstPos) <- zip js [0..] ]+                code = exp1 `appOL` exp2 `appOL`+                       makeInt8x8OnGPR tmpLo (take 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpLo) (OpReg dst)) `appOL`+                       makeInt8x8OnGPR tmpHi (drop 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpHi) (OpReg tmpXmm)) `snocOL`+                       (PUNPCKLQDQ fmt (OpReg tmpXmm) dst)+            return (Fixed fmt dst code)+      where fmt = VecFormat 16 FmtInt8++    vector_shuffle_int16x8 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int16x8 sse4_1 v1 v2 is@(i0:i1:i2:i3:i4567@[i4,i5,i6,i7])+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        (r1, exp1) <- getSomeReg v1+        (r2, exp2) <- getSomeReg v2+        let -- shufL src dst k0 k1 k2 k3 (0 <= k_i < 4):+            --   dst <- (src[k0],src[k1],src[k2],src[k3],src[4],src[5],src[6],src[7])+            shufL src dst 0 1 2 3 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufL src dst k0 k1 k2 k3 = let imm = k0 + (k1 `shiftL` 2) + (k2 `shiftL` 4) + (k3 `shiftL` 6)+                                        in unitOL (PSHUFLW fmt (ImmInt imm) (OpReg src) dst)+            -- shufH src dst k0 k1 k2 k3 (4 <= k_i < 8):+            --   dst <- (src[0],src[1],src[2],src[3],src[k0],src[k1],src[k2],src[k3])+            shufH src dst 4 5 6 7 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufH src dst k0 k1 k2 k3 = let imm = (k0 - 4) + ((k1 - 4) `shiftL` 2) + ((k2 - 4) `shiftL` 4) + ((k3 - 4) `shiftL` 6)+                                        in unitOL (PSHUFHW fmt (ImmInt imm) (OpReg src) dst)++            shufLHImm src dst immLo immHi = case (immLo, immHi) of+              (0b11_10_01_00, 0b11_10_01_00)+                | src == dst -> nilOL+                | otherwise -> unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+              (0b11_10_01_00, _) -> unitOL (PSHUFHW fmt (ImmInt immHi) (OpReg src) dst)+              (_, 0b11_10_01_00) -> unitOL (PSHUFLW fmt (ImmInt immLo) (OpReg src) dst)+              (_, _) -> toOL [PSHUFLW fmt (ImmInt immLo) (OpReg src) dst,+                              PSHUFHW fmt (ImmInt immHi) (OpReg dst) dst]++            -- ks = [k0,...,k7]+            -- Assumption: 0 <= k_i < 4 for 0 <= i < 4, 4 <= k_i < 8 for 4 <= i < 8+            -- dst <- (src[k0],...,src[k7])+            shufLH src dst ks+              = let (k_lo, k_hi) = splitAt 4 ks+                    immLo = foldr (\k acc -> (acc `shiftL` 2) + k) 0 k_lo+                    immHi = foldr (\k acc -> (acc `shiftL` 2) + (k - 4)) 0 k_hi+                in shufLHImm src dst immLo immHi++            -- shufRev src dst j0 j1 j2 j3 j4 j5 j6 j7:+            -- Assumption: [j0,j1,j2,j3] `elem` permutations [0,1,2,3] && [j4,j5,j6,j7] `elem` permutations [4,5,6,7]:+            --   dst[j0] <- src[0]; dst[j1] <- src[1]; dst[j2] <- src[2]; dst[j3] <- src[3];+            --   dst[j4] <- src[4]; dst[j5] <- src[5]; dst[j6] <- src[6]; dst[j7] <- src[7];+            shufRev src dst _j0 j1 j2 j3 _j4 j5 j6 j7+              = let immLo = (1 `shiftL` (2 * j1)) + (2 `shiftL` (2 * j2)) + (3 `shiftL` (2 * j3))+                    immHi = (1 `shiftL` (2 * (j5 - 4))) + (2 `shiftL` (2 * (j6 - 4))) + (3 `shiftL` (2 * (j7 - 4)))+                in shufLHImm src dst immLo immHi+            i0123 = [i0, i1, i2, i3]+        if+          -- PSHUFLW + PSHUFHW+          | all (\i -> i < 4) i0123+          , all (\i -> 4 <= i && i < 8) i4567+          -> do+            let code dst = exp1 `appOL`+                           shufLH r1 dst is+            return (Any fmt code)++          -- PSHUFLW + PSHUFHW+          | all (\i -> 8 <= i && i < 12) i0123+          , all (\i -> 12 <= i) i4567+          -> do+            let code dst = exp2 `appOL`+                           shufLH r2 dst (map (subtract 8) is)+            return (Any fmt code)++          -- PSHUF{L,H}W + PBLENDW (SSE4.1)+          | sse4_1+          , all (\i -> i `rem` 8 < 4) i0123+          , all (\i -> 4 <= i `rem` 8) i4567+          -> do+            tmp <- getNewRegNat fmt+            let imm = foldl' (\acc (i,p) -> if i >= 8 then setBit acc p else acc) 0 (zip is [0..])+                js = zipWith (\i p -> if i >= 8 then p else i) is [0..]+                ks = zipWith (\i p -> if i >= 8 then i - 8 else p) is [0..]+                code dst = exp1 `appOL` exp2 `appOL`+                           shufLH r2 tmp ks `appOL`+                           shufLH r1 dst js `snocOL`+                           (PBLENDW fmt (ImmInt imm) (OpReg tmp) dst)+            return (Any fmt code)++          -- PSHUFLW + PSHUFLW + PUNPCKLWD + PSHUFLW + PSHUFHW+          | all (\i -> i < 4 || (8 <= i && i < 12)) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 4) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 4) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufL r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufL r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKLWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- PSHUFHW + PSHUFHW + PUNPCKHWD + PSHUFLW + PSHUFHW+          | all (\i -> (4 <= i && i < 8) || 12 <= i) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 8) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 8) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufH r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufH r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKHWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- Generic implementation+          | otherwise -> do+            tmp0 <- getNewRegNat II32+            tmps <- replicateM 7 (getNewRegNat II32)+            let code dst = exp1 `appOL` exp2 `appOL`+                           toOL [ PEXTR II32 fmt (ImmInt i') r (OpReg tmp)+                                | (i, tmp) <- zip is (tmp0:tmps)+                                , let (i', r) = if i < 8 then (i, r1) else (i - 8, r2)+                                ] `snocOL`+                           (MOVD II32 fmt (OpReg tmp0) (OpReg dst)) `appOL`+                           toOL [ PINSR II32 fmt (ImmInt i) (OpReg tmp) dst+                                | (i, tmp) <- zip [1..] tmps+                                ]+            return (Any fmt code)+      where fmt = VecFormat 8 FmtInt16+    vector_shuffle_int16x8 _ _ _ is = pprPanic "vector shuffle: wrong number of indices (expected 8)" (ppr is)++    vector_shuffle_int32x4 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int32x4 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        let -- `pshufd imm src dst` is equivalent to `PSHUFD fmt (ImmInt imm) (OpReg src) dst`+            pshufd 0b11_10_01_00 src dst+              | src == dst = nilOL+              | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            pshufd imm src dst = unitOL (PSHUFD fmt (ImmInt imm) (OpReg src) dst)++            -- PSHUFD (composeImm imm1 imm2) src dst == (PSHUFD imm1 src tmp; PSHUFD imm2 tmp dst)+            composeMask :: Int -> Int -> Int+            composeMask imm1 imm2 = foldr (\i acc -> let j = (imm2 `shiftR` (2 * i)) .&. 3+                                                     in (imm1 `shiftR` (2 * j) .&. 3) .|. (acc `shiftL` 2)+                                          ) 0 [0..3]++            makeMask :: [(Int, Int)] -- List of (dst,src). If src == -1, the value there can be anything.+                     -> Int+            makeMask m = foldl' (.|.) 0 [ src `shiftL` (2 * dst) | dst <- [0..3], let src = fromMaybe dst (mfilter (>= 0) $ lookup dst m) ]++            twoAndTwo p0@(1,_) p1@(3,_) q0@(0,_) q1@(2,_) imm4 v1 v2 = twoAndTwo' q0 q1 p0 p1 imm4 v2 v1+            twoAndTwo p0 p1 q0 q1 imm4 v1 v2 = twoAndTwo' p0 p1 q0 q1 imm4 v1 v2+            twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 = do+              (r1, exp1) <- getSomeReg v1+              (r2, exp2) <- getSomeReg v2+              tmp <- getNewRegNat fmt+              let (instr, imm1, imm2) =+                    if all (\(_,i) -> 2 <= i || i == -1) [p0,p1,q0,q1] then+                      -- The inputs are all from higher lanes+                      (PUNPCKHDQ, makeMask [(2,snd p0),(3,snd p1)], makeMask [(2,snd q0),(3,snd q1)])+                    else+                      (PUNPCKLDQ, makeMask [(0,snd p0),(1,snd p1)], makeMask [(0,snd q0),(1,snd q1)])+                  imm3 = makeMask [(fst p0,0),(fst q0,1),(fst p1,2),(fst q1,3)]+                  code dst = exp1 `appOL` exp2 `appOL`+                             pshufd imm2 r2 tmp `appOL`             -- tmp <- (*,*,r2[snd q0],r2[snd q1]) or (r2[snd q0],r2[snd q1],*,*)+                             pshufd imm1 r1 dst `snocOL`            -- dst <- (*,*,r1[snd p0],r1[snd p1]) or (r1[snd p0],r1[snd p1],*,*)+                             instr fmt (OpReg tmp) dst `appOL`      -- dst <- (dst[0],tmp[0],dst[1],tmp[1]) = (r1[snd p0],r2[snd q0],r1[snd p1],r2[snd q1])+                             pshufd (composeMask imm3 imm4) dst dst -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst q1]) <- dst+              return $ Any fmt code++            threeAndOne p0 p1 p2 q0+              | snd p0 == snd p1 = twoAndTwo p0 p2 q0 (fst p1,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p0),(fst p2,fst p2),(fst q0,fst q0)])+              | snd p0 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p0),(fst q0,fst q0)])+              | snd p1 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p1),(fst q0,fst q0)])+              | otherwise = \v1 v2 -> do+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                tmp1 <- getNewRegNat fmt+                if sse4_1+                  then do+                    let imm1 = makeMask [p0,p1,p2]+                        imm2 = makeMask [q0]+                        imm3 = foldl' (.|.) 0 [ (if i == fst q0 then 0 else 3) `shiftL` (2 * i) | i <- [0..3] ]+                    let code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r1 tmp1 `appOL`+                                   pshufd imm2 r2 dst `snocOL`+                                   PBLENDW fmt (ImmInt imm3) (OpReg tmp1) dst+                    return $ Any fmt code+                  else do+                    tmp2 <- getNewRegNat fmt+                    tmp3 <- getNewRegNat fmt+                    let imm1 = snd q0 .|. 0b11_10_01_00+                        imm2 = snd p1 .|. 0b11_10_01_00+                        imm3 = snd p0 .|. (snd p2 `shiftL` 2) .|. 0b11_10_00_00+                        imm6 = makeMask [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]+                        code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r2 tmp1 `appOL`              -- tmp1 <- (y0,*,*,*)+                                   pshufd imm2 r1 tmp2 `appOL`              -- tmp2 <- (x1,*,*,*)+                                   pshufd imm3 r1 tmp3 `snocOL`             -- tmp3 <- (x0,x2,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp2) tmp1 `snocOL` -- tmp1 <- unpckldq tmp1 tmp2 = (y0,x1,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp3) tmp1 `appOL`  -- tmp1 <- unpckldq tmp1 tmp3 = (y0,x0,x1,x2)+                                   pshufd imm6 tmp1 dst                     -- dst <- shuffle tmp1+                    return $ Any fmt code++        let (from_first, from_second) = partition (\(_dstPos,srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dstPos,srcPos) -> (dstPos, srcPos - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> do+            (r, exp) <- getSomeReg v1+            let imm = makeMask [p0,p1,p2,p3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([], [q0,q1,q2,q3]) -> do+            (r, exp) <- getSomeReg v2+            let imm = makeMask [q0,q1,q2,q3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 0b11_10_01_00 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2++          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      where fmt = VecFormat 4 FmtInt32++    vector_shuffle_int64x2 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int64x2 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = case is of+        -- PUNPCKLQDQ / PUNPCKHQDQ+        [i, i'] | i == i' -> do+          exp <- getAnyReg $ if i < 2 then v1 else v2+          let instr = if i == 0 || i == 2+                      then PUNPCKLQDQ+                      else PUNPCKHQDQ+              code dst = exp dst `snocOL`+                         (instr fmt (OpReg dst) dst)+          return $ Any fmt code+        [0, 2] -> vector_op_sse PUNPCKLQDQ fmt v1 v2+        [2, 0] -> vector_op_sse PUNPCKLQDQ fmt v2 v1+        [1, 3] -> vector_op_sse PUNPCKHQDQ fmt v1 v2+        [3, 1] -> vector_op_sse PUNPCKHQDQ fmt v2 v1++        -- PSHUFD+        [1, 0] -> do+          (r1, exp1) <- getSomeReg v1+          let code dst = exp1 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r1) dst)+          return $ Any fmt code+        [3, 2] -> do+          (r2, exp2) <- getSomeReg v2+          let code dst = exp2 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r2) dst)+          return $ Any fmt code++        -- Others:+        -- If SSE4.1 is available, use PBLENDW (see vector_shuffle_int128_common).+        -- Otherwise, we resort to SHUFPD.+        [0, 3] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v1 v2+        [2, 1] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v2 v1++        -- [0, 1], [2, 3], [1, 2], [3, 0] are covered by the common cases++        -- Indices are checked in vector_shuffle_int128_common, so the following line should be unreachable:+        _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)+      where fmt = VecFormat 2 FmtInt64+            doubleFormat = VecFormat 2 FmtDouble+++getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps+  avx    <- avxEnabled+  sse4_1 <- sse4_1Enabled+  case mop of+      -- Floating point fused multiply-add operations @ ± x*y ± z@+      MO_FMA var l w+        | l * widthInBits w > 256+        -> sorry "Please use -fllvm for wide vector FMA support"+        | otherwise+        -> genFMA3Code l w var x y z++      -- Ternary vector operations+      MO_VF_Insert l W32  | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z+                          | otherwise ->+         sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm"+           -- SIMD NCG TODO:+           --+           --   - add support for FloatX8, FloatX16.+      MO_VF_Insert l W64  -> vector_double_insert avx l x y z+      MO_V_Insert 16 W8 | sse4_1 -> vector_int_insert_pinsr 16 W8 x y z+                        | otherwise -> vector_int8x16_insert_sse2 x y z+      MO_V_Insert 8 W16 -> vector_int_insert_pinsr 8 W16 x y z -- PINSRW (SSE2)+      MO_V_Insert 4 W32 | sse4_1 -> vector_int_insert_pinsr 4 W32 x y z+                        | otherwise -> vector_int32x4_insert_sse2 x y z+      MO_V_Insert 2 W64 | sse4_1 -> vector_int_insert_pinsr 2 W64 x y z+                        | otherwise -> vector_int64x2_insert_sse2 x y z+      MO_V_Insert _ _ -> sorry "Unsupported integer vector insert operation; please use -fllvm"++      _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)"+                  (pprMachOp mop)++  where+    -- SIMD NCG TODO:+    --+    --   - add support for FloatX8, FloatX16.+    vector_floatx4_insert_sse :: Bool+                              -> CmmExpr+                              -> CmmExpr+                              -> CmmExpr+                              -> NatM Register+    vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _))+      | sse4_1 = do+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+            imm      = litToImm (CmmInt (offset `shiftL` 4) W32)+            code dst = exp `appOL`+                      (fn dst) `snocOL`+                      (INSERTPS fmt imm (OpReg r) dst)+         in return $ Any fmt code+      | otherwise = do -- SSE <= 3+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  0 -> exp `appOL`+                      (fn dst) `snocOL`+                      -- The following MOV compiles to MOVSS instruction and merges two vectors+                      (MOV fmt (OpReg r) (OpReg dst))  -- dst <- (r[0],dst[1],dst[2],dst[3])+                  1 -> exp `appOL`+                      (fn dst) `snocOL`+                      (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                      (UNPCKL fmt (OpReg r) dst) `snocOL`          -- dst <- (dst[0],r[0],dst[1],r[1])+                      (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[3])+                  2 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[0],tmp[3])+                  3 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[0])+                  _ -> panic "MO_VF_Insert FloatX4: unsupported offset"+         in return $ Any fmt code+    vector_floatx4_insert_sse _ _ _ offset+      = pprPanic "Unsupported vector insert operation" $+          vcat+            [ text "FloatX4#"+            , text "offset:" <+> pdoc platform offset ]+++    -- SIMD NCG TODO:+    --+    --   - add support for DoubleX4#, DoubleX8#.+    vector_double_insert :: Bool+                         -> Length+                         -> CmmExpr+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    -- DoubleX2+    vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let movu = if avx then VMOVU else MOVU+            fmt = VecFormat len FmtDouble+            code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                -- The following MOV compiles to MOVSD instruction and merges two vectors+                                (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst))+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst)+                  _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_double_insert _ _ _ _ _ =+      sorry "Unsupported floating-point vector insert operation; please use -fllvm"+    -- For DoubleX4: use VSHUFPD.+    -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd?++    -- SIMD NCG TODO:+    --+    --   - only supports 128-bit vector types (Int64X2, Int32X4, Int16X8, Int8X16),+    --     add support for 256-bit and 512-bit vector types.++    -- PINSRW is an SSE2 instruction, whereas PINSR{B,D,Q} require SSE4.1.+    vector_int_insert_pinsr :: HasCallStack => Length+                            -> Width+                            -> CmmExpr+                            -> CmmExpr+                            -> CmmExpr+                            -> NatM Register+    vector_int_insert_pinsr len w vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < toInteger len+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        let (scalarFormat, vectorFormat) = case w of+              W8 -> (II32, VecFormat len FmtInt8)+              W16 -> (II32, VecFormat len FmtInt16)+              W32 -> (II32, VecFormat len FmtInt32)+              W64 -> (II64, VecFormat len FmtInt64)+              _ -> sorry "Unsupported vector format"+            code dst = valExp `appOL`+                       (vecCode dst) `snocOL`+                       (PINSR scalarFormat vectorFormat (ImmInteger offset) (OpReg valReg) dst)+        return $ Any vectorFormat code+    vector_int_insert_pinsr _ _ _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int8x16_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int8x16_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 16+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        tmp <- getNewRegNat II32+        let vectorFormat = VecFormat 16 FmtInt8+            code dst+              = case offset `quotRem` 2 of+                  (j, 0) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) `snocOL`+                            (MOVZxL II8 (OpReg valReg) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+                  (j, _) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (MOVZxL II8 (OpReg tmp) (OpReg tmp)) `snocOL`+                            (SHL II32 (OpImm (ImmInt 8)) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+        return $ Any vectorFormat code+    vector_int8x16_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int32x4_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int32x4_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 4+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        -- Since SSE2 does not have an integer vector instruction to achieve this,+        -- we are forced to either use floating-point vector instructions+        -- or lots of integer vector instructions. (sigh)+        let floatVectorFormat = VecFormat 4 FmtFloat+        tmp1 <- getNewRegNat floatVectorFormat+        tmp2 <- getNewRegNat floatVectorFormat+        let vectorFormat = VecFormat 4 FmtInt32+            code dst+              = case offset of+                  0 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL`+                       (MOV floatVectorFormat (OpReg tmp1) (OpReg dst)) -- MOVSS; dst <- (tmp1[0],dst[1],dst[2],dst[3])+                  1 -> valExp `appOL`+                       (vecCode tmp1) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg dst)) `snocOL` -- dst <- (val,0,0,0)+                       (PUNPCKLQDQ vectorFormat (OpReg tmp1) dst) `snocOL` -- dst <- (dst[0],dst[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b11_10_00_10) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[2],dst[0],tmp1[2],tmp1[3])+                  2 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (MOVU floatVectorFormat (OpReg dst) (OpReg tmp2)) `snocOL` -- MOVUPS; tmp2 <- dst+                       (SHUF floatVectorFormat (ImmInt 0b01_00_01_11) (OpReg tmp1) tmp2) `snocOL` -- SHUFPS; tmp2 <- (tmp2[3],tmp2[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp2) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp2[2],tmp2[0])+                  _ -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (SHUF floatVectorFormat (ImmInt 0b11_10_01_00) (OpReg dst) tmp1) `snocOL` -- SHUFPS; tmp1 <- (tmp1[0],tmp1[1],dst[2],dst[3])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp1[2],tmp1[0])+        return $ Any vectorFormat code+    vector_int32x4_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int64x2_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int64x2_insert_sse2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let fmt = VecFormat 2 FmtInt64+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVHLPS FF64 vecReg tmp) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_int64x2_insert_sse2 _ _ offset = pprPanic "MO_V_Insert Int64X2: unsupported offset" (pdoc platform offset)++getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) =+  pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop)++getRegister' platform is32Bit load@(CmmLoad mem ty _)+  | isVecType ty+  = do+    config <- getConfig+    Amode addr mem_code <- getAmode mem+    let code dst =+          mem_code `snocOL`+            movInstr config format (OpAddr addr) (OpReg dst)+    return (Any format code)+  | isFloatType ty+  = do+    Amode addr mem_code <- getAmode mem+    loadAmode (floatFormat width) addr mem_code++  | is32Bit && not (isWord64 ty)+  = do+    let+      instr = case width of+                W8     -> MOVZxL II8+                  -- 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.+                _other -> MOV format+    code <- intLoadCode instr mem+    return (Any format code)++  | not is32Bit+  -- Simpler memory load code on x86_64+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)++  | otherwise+  = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load)+  where+    format = cmmTypeFormat ty+    width = typeWidth ty++-- 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++getRegister' platform is32Bit (CmmLit lit) = do+  avx <- avxEnabled++  -- NB: it is important that the code produced here (to load a literal into+  -- a register) doesn't clobber any registers other than the destination+  -- register; the code for generating C calls relies on this property.+  --+  -- In particular, we have:+  --+  -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False+  --+  -- which means that we assume that loading a literal into a register+  -- will not clobber any other registers.++  -- TODO: this function mishandles floating-point negative zero,+  -- because -0.0 == 0.0 returns True and because we represent CmmFloat as+  -- Rational, which can't properly represent negative zero.++  if+    -- Zero: use XOR.+    | isZeroLit lit+    -> let code dst+             | isIntFormat fmt+             = let fmt'+                     | is32Bit+                     = fmt+                     | otherwise+                     -- x86_64: 32-bit xor is one byte shorter,+                     -- and zero-extends to 64 bits+                     = case fmt of+                         II64 -> II32+                         _ -> fmt+               in unitOL (XOR fmt' (OpReg dst) (OpReg dst))+             | avx+             = if float_or_floatvec+               then unitOL (VXOR fmt (OpReg dst) dst dst)+               else unitOL (VPXOR fmt dst dst dst)+             | otherwise+             = if float_or_floatvec+               then unitOL (XOR fmt (OpReg dst) (OpReg dst))+               else unitOL (PXOR fmt (OpReg dst) dst)+       in return $ Any fmt code++    -- Constant vector: use broadcast.+    | VecFormat l sFmt <- fmt+    , CmmVec (f:fs) <- lit+    , all (== f) fs+    -> do let w = scalarWidth sFmt+              broadcast = if isFloatScalarFormat sFmt+                          then MO_VF_Broadcast l w+                          else MO_V_Broadcast l w+          valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f])+          return $ Any fmt valCode++    -- 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.+    | not is32Bit, isWord64 cmmTy, not (isBigLit lit)+    -> let+          imm = litToImm lit+          code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+      in+          return (Any II64 code)++    -- Scalar integer: use an immediate.+    | isIntFormat fmt+    -> let imm = litToImm lit+           code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst))+       in return (Any fmt code)++    -- General case: load literal from data address.+    | otherwise+    -> do let w = formatToWidth fmt+          Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit+          loadAmode fmt addr addr_code++    where+      cmmTy = cmmLitType platform lit+      fmt = cmmTypeFormat cmmTy+      float_or_floatvec = isFloatOrFloatVecFormat fmt+      isZeroLit (CmmInt i _) = i == 0+      isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero+      isZeroLit (CmmVec fs) = all isZeroLit fs+      isZeroLit _ = False++      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 _ slot@(CmmStackSlot {}) =+  pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot)++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 :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = do+  config <- getConfig+  return (\dst -> fcode `snocOL` mkRegRegMoveInstr config 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 :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  config <- getConfig+  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` mkRegRegMoveInstr config 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 :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  r <- getRegister expr+  config <- getConfig+  let platform = ncgPlatform config+  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` mkRegRegMoveInstr config rep reg tmp)+        | otherwise ->+                return (reg, code)++--------------------------------------------------------------------------------++-- | 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 r n++      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse 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++      CmmLit lit@(CmmFloat {})+        -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address"+             (ppr lit)++      -- 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)+  | Just w <- isSuitableFloatingPointLit_maybe lit = do+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  | otherwise = do+    platform <- getPlatform+    if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 ty) else True)+      -- if 32bit and ty 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 ty 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) = case isSuitableFloatingPointLit_maybe lit of+    Just w -> do+        Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+        return (OpAddr addr, code)+    Nothing -> do+        platform <- getPlatform+        if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))+            then return (OpImm (litToImm lit), nilOL)+            else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem ty 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 (isIntFormat 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)++-- | Load the value at the given address into any register.+loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register+loadAmode fmt addr addr_code = do+  config <- getConfig+  let load dst = movInstr config fmt (OpAddr addr) (OpReg dst)+  return $ Any fmt (\ dst -> addr_code `snocOL` load dst)++-- 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 = isJust . isSuitableFloatingPointLit_maybe++isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width+isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0)+isSuitableFloatingPointLit_maybe _ = Nothing++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) 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)++{-  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.++    * Other comparisons:++    We first compare the low registers+    and use a subtraction with borrow to compare the high registers.++    For signed numbers the condition is determined by+    the sign and overflow flags agreeing or not+    and for unsigned numbers the condition is the carry flag.++-}++-- @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++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+condIntCode' platform cond x y+  | target32Bit platform && isWord64 (cmmExprType platform x) = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 x+  RegCode64 code2 r2hi r2lo <- iselExpr64 y++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode)++  where+    intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- These don't occur as argument of condIntCode'+        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 -> (EQQ, cmpExact)+        NE  -> (NE, cmpExact)+        -- [x >= y]+        GE  -> (GE, cmpGE)+        GEU -> (GEU, cmpGE)+        -- [x >  y]+        GTT -> (LTT, cmpLE)+        GU  -> (LU, cmpLE)+        -- [x <= y]+        LE  -> (GE, cmpLE)+        LEU -> (GEU, cmpLE)+        -- [x <  y]+        LTT -> (LTT, cmpGE)+        LU  -> (LU, cmpGE)+      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)+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            ]+        cmpLE = toOL+            [ MOV II32 (OpReg r2_hi) (OpReg tmp1)+            , CMP II32 (OpReg r1_lo) (OpReg r2_lo)+            , SBB II32 (OpReg r1_hi) (OpReg tmp1)+            ]++-- memory vs immediate+condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit)+ | is32BitLit platform lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat ty) (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 ty))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat ty) (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 ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_VecCode ::           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 ty addr (CmmMachOp op [CmmLoad addr2 _ _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, ty /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr ty (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 ty 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 ty 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 reg (CmmLoad src _ _) = do+  let ty = cmmTypeFormat $ cmmRegType reg+  load_code <- intLoadCode (MOV ty) 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 ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV ty (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))++-- Vector assignment to a register/temporary+assignMem_VecCode ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  config <- getConfig+  let+    code = src_code `appOL`+           addr_code `snocOL`+           movInstr config ty (OpReg src_reg) (OpAddr addr)+  return code++assignReg_VecCode reg src = do+  platform <- ncgPlatform <$> getConfig+  src_code <- getAnyReg src+  return (src_code (getRegisterReg platform reg))++genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> 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.+-}++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++genCondBranch' _ bid id false bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  if not is_float+    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_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE+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 mo)  [dst]  [addr]         = genAtomicRead w mo dst addr+genSimplePrim _   (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo 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 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 bid (MO_VS_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VS_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid MO_I64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y]+genSimplePrim bid MO_I64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxWord64X2") [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 loadIntoRegMightClobberOtherReg actuals = do+      regs_blks <- mapM evalArg actuals+      return (concatOL $ map fst regs_blks, map snd regs_blks)+  | otherwise = return (nilOL, actuals)+  where++    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++-- | Might the code to put this expression into a register+-- clobber any other registers?+loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool+loadIntoRegMightClobberOtherReg (CmmReg _)      = False+loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False+loadIntoRegMightClobberOtherReg (CmmLit _)      = False+  -- NB: this last 'False' is slightly risky, because the code for loading+  -- a literal into a register is not entirely trivial.+loadIntoRegMightClobberOtherReg _               = True++-- 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 ghcInternalUnitId 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 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 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@(ForeignConvention _ argHints _ _) dest_regs args = do+  platform <- getPlatform+  is32Bit <- is32BitPlatform+  let args_hints = zip args (argHints ++ repeat NoHint)+      prom_args = map (maybePromoteCArgToW32 platform) args_hints+  (instrs0, args') <- evalArgs bid prom_args+  instrs1 <- if is32Bit+    then genCCall32 addr conv dest_regs args'+    else genCCall64 addr conv dest_regs args'+  return (instrs0 `appOL` instrs1)++maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr+maybePromoteCArgToW32 platform (arg, hint)+ | wfrom < wto =+    -- As wto=W32, we only need to handle integer conversions,+    -- never Float -> Double.+    case hint of+      SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]+      _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   ty = cmmExprType platform arg+   wfrom = typeWidth ty+   wto = W32++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++            -- 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 || isVecType 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 = cmmTypeFormat arg_ty+                                      in++                                       movInstr config 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+            -- maintain. 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 args)+        delta <- getDeltaNat+        massert (delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        callinsns <-+          case addr of+            CmmLit (CmmLabel lbl)+               -> return $ unitOL (CALL (Left fn_imm) [])+               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) [] }+        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++            call = callinsns `appOL`+                   toOL (+                      (if tot_arg_size == 0 then [] else+                       [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isVecType ty+              = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_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+    config <- getConfig+    let platform = ncgPlatform config+        word_size = platformWordSizeInBytes platform+        wordFmt = archWordFormat (target32Bit platform)++    -- Compute the code for loading arguments into registers,+    -- returning the leftover arguments that will need to be passed on the stack.+    --+    -- NB: the code for loading references to data into registers is computed+    -- later (in 'pushArgs'), because we don't yet know where the data will be+    -- placed (due to alignment requirements).+    LoadArgs+      { stackArgs       = proper_stack_args+      , stackDataArgs   = stack_data_args+      , usedRegs        = arg_regs_used+      , assignArgsCode  = assign_args_code+      }+      <- loadArgs config args++    let++    -- Pad all arguments and data passed on stack to align them properly.+        (stk_args_with_padding, args_aligned_16) =+          padStackArgs platform (proper_stack_args, stack_data_args)++    -- 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+        need_realign_call = args_aligned_16+    align_call_code <-+      if need_realign_call+      then addStackPadding word_size+      else return nilOL++    -- Compute the code that pushes data to the stack, and also+    -- the code that loads references to that data into registers,+    -- when the data is passed by reference in a register.+    (load_data_refs, push_code) <-+      pushArgs config proper_stack_args stk_args_with_padding++    -- On Windows, leave stack space for the arguments that we are passing+    -- in registers (the so-called shadow space).+    let shadow_space =+          if platformOS platform == OSMinGW32+          then 8 * length (allArgRegs platform)+            -- NB: the shadow store is always 8 * 4 = 32 bytes large,+            -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs').+          else 0+    shadow_space_code <- addStackPadding shadow_space++    let total_args_size+          = shadow_space+          + sum (map (stackArgSpace platform) stk_args_with_padding)+        real_size =+          total_args_size + if need_realign_call then word_size else 0++    -- End of argument passing.+    --+    -- Next step: emit the appropriate call instruction.+    delta <- getDeltaNat++    let -- The System V AMD64 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.+        nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used+        assign_eax_sse_regs+          = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax))+          -- Note: we do this on Windows as well. It's not entirely clear why+          -- it's needed (the Windows X86_64 calling convention does not+          -- dictate it), but we get segfaults without it.+          --+          -- One test case exhibiting the issue is T20030_test1j;+          -- if you change this, make sure to run it in a loop for a while+          -- with at least -j8 to check.++        -- Live registers we are annotating the call instruction with+        arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <- case addr of+      CmmLit (CmmLabel lbl) ->+        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 call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall+                  (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] =+          unitOL $+            mkRegRegMoveInstr config fmt reg r_dest+          where+            reg = if isIntFormat fmt then rax else xmm0+            fmt = cmmTypeFormat rep+            rep = localRegType dest+            r_dest = getRegisterReg platform (CmmLocal dest)+        assign_code _many = panic "genForeignCall.assign_code many"++    return (align_call_code     `appOL`+            push_code           `appOL`+            assign_args_code    `appOL`+            load_data_refs      `appOL`+            shadow_space_code   `appOL`+            assign_eax_sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)++-- -----------------------------------------------------------------------------+-- Loading arguments into registers for 64-bit C calls.++-- | Information needed to know how to pass arguments in a C call,+-- and in particular how to load them into registers.+data LoadArgs+  = LoadArgs+  -- | Arguments that should be passed on the stack+  { stackArgs     :: [RawStackArg]+  -- | Additional values to store onto the stack.+  , stackDataArgs :: [CmmExpr]+  -- | Which registers are we using for argument passing?+  , usedRegs      :: [RegWithFormat]+  -- | The code to assign arguments to registers used for argument passing.+  , assignArgsCode :: InstrBlock+  }+instance Semigroup LoadArgs where+  LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2+    = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2)+instance Monoid LoadArgs where+  mempty = LoadArgs [] [] [] nilOL++-- | An argument passed on the stack, either directly or by reference.+--+-- The padding information hasn't yet been computed (see 'StackArg').+data RawStackArg+  -- | Pass the argument on the stack directly.+  = RawStackArg { stackArgExpr :: CmmExpr }+  -- | Pass the argument by reference.+  | RawStackArgRef+    { stackRef :: StackRef+       -- ^ is the reference passed in a register, or on the stack?+    , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+    }+  deriving ( Show )++-- | An argument passed on the stack, either directly or by reference,+-- with additional padding information.+data StackArg+  -- | Pass the argument on the stack directly.+  = StackArg+      { stackArgExpr :: CmmExpr+      , stackArgPadding :: Int+        -- ^ padding required (in bytes)+      }+  -- | Pass the argument by reference.+  | StackArgRef+     { stackRef :: StackRef+        -- ^ where the reference is passed+     , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+     , stackRefArgPadding :: Int+       -- ^ padding of the data pointed to+       -- (the reference itself never requires padding)+     }+  deriving ( Show )++-- | Where is a reference to data on the stack passed?+data StackRef+  -- | In a register.+  = InReg Reg+  -- | On the stack.+  | OnStack+  deriving ( Eq, Ord, Show )++newtype Padding = Padding { paddingBytes :: Int }+  deriving ( Show, Eq, Ord )++-- | How much space does this 'StackArg' take up on the stack?+--+-- Only counts the "reference" part for references, not the data it points to.+stackArgSpace :: Platform -> StackArg -> Int+stackArgSpace platform = \case+  StackArg arg padding ->+    argSize platform arg + padding+  StackArgRef { stackRef = ref } ->+    case ref of+      InReg   {} -> 0+      OnStack {} -> 8++-- | Pad arguments, assuming we start aligned to a 16-byte boundary.+--+-- Returns padded arguments, together with whether we end up aligned+-- to a 16-byte boundary.+padStackArgs :: Platform+             -> ([RawStackArg], [CmmExpr])+             -> ([StackArg], Bool)+padStackArgs platform (args0, data_args0) =+  let+    -- Pad the direct args+    (args, align_16_mid) = pad_args True args0++    -- Pad the data section+    (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0)++    -- Now figure out where the data is placed relative to the direct arguments,+    -- in order to resolve references.+    resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg]+    resolve_args [] _ = []+    resolve_args ((stk_arg, Padding pad):rest) pads =+      let (this_arg, pads') =+            case stk_arg of+              RawStackArg arg -> (StackArg arg pad, pads)+              RawStackArgRef ref size -> case pads of+                  Padding arg_pad : rest_pads ->+                    let arg = StackArgRef+                          { stackRef = ref+                          , stackRefArgSize = size+                          , stackRefArgPadding = arg_pad }+                    in (arg, rest_pads)+                  _ -> panic "padStackArgs: no padding info found for StackArgRef"+      in this_arg : resolve_args rest pads'++  in+    ( resolve_args args (fmap snd data_args) +++        [ case data_arg of+            RawStackArg arg -> StackArg arg pad+            RawStackArgRef {} -> panic "padStackArgs: reference in data section"+        | (data_arg, Padding pad) <- data_args+        ]+    , align_16_end )++  where+    pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool)+    pad_args aligned_16 [] = ([], aligned_16)+    pad_args aligned_16 (arg:args)+      | needed_alignment > 16+      -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32).+      -- This makes aligning the stack to a 32 or 64 byte boundary more+      -- complicated, in particular with DELTA.+      = sorry $ unlines+        [ "X86_86 C call: unsupported argument."+        , "  Alignment requirement: " ++ show needed_alignment ++ " bytes."+        , if platformOS platform == OSMinGW32+          then "  The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors."+          else "  The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls."+        , "  Please use the LLVM backend (-fllvm)." ]+      | otherwise+      = let ( rest, final_align_16 ) = pad_args next_aligned_16 args+        in  ( (arg, Padding padding) : rest, final_align_16 )++      where+        needed_alignment = case arg of+          RawStackArg arg   -> argSize platform arg+          RawStackArgRef {} -> platformWordSizeInBytes platform+        padding+          | needed_alignment < 16 || aligned_16+          = 0+          | otherwise+          = 8+        next_aligned_16 = not ( aligned_16 && needed_alignment < 16 )++-- | Load arguments into available registers.+loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs+loadArgs config args+  | platformOS platform == OSMinGW32+  = evalStateT (loadArgsWin config args) (allArgRegs platform)+  | otherwise+  = evalStateT (loadArgsSysV config args) (allIntArgRegs platform+                                          ,allFPArgRegs  platform)+  where+    platform = ncgPlatform config++-- | Load arguments into available registers (System V AMD64 ABI).+loadArgsSysV :: NCGConfig+             -> [CmmExpr]+             -> StateT ([Reg], [Reg]) NatM LoadArgs+loadArgsSysV _ [] = return mempty+loadArgsSysV config (arg:rest) = do+  (iregs, fregs) <- get+  -- No available registers: pass everything on the stack (shortcut).+  if null iregs && null fregs+  then return $+          LoadArgs+            { stackArgs       = map RawStackArg (arg:rest)+            , stackDataArgs   = []+            , assignArgsCode  = nilOL+            , usedRegs        = []+            }+  else do+    mbReg <-+      if+        | isIntFormat arg_fmt+        , ireg:iregs' <- iregs+        -> do put (iregs', fregs)+              return $ Just ireg+        | isFloatFormat arg_fmt || isVecFormat arg_fmt+        , freg:fregs' <- fregs+        -> do put (iregs, fregs')+              return $ Just freg+        | otherwise+        -> return Nothing+    this_arg <-+      case mbReg of+        Just reg -> do+          assign_code <- lift $ loadArgIntoReg arg reg+          return $+            LoadArgs+                { stackArgs       = [] -- passed in register+                , stackDataArgs   = []+                , assignArgsCode  = assign_code+                , usedRegs        = [RegWithFormat reg arg_fmt]+                }+        Nothing -> do+          return $+            -- No available register for this argument: pass it on the stack.+            LoadArgs+                { stackArgs       = [RawStackArg arg]+                , stackDataArgs   = []+                , assignArgsCode  = nilOL+                , usedRegs        = []+                }+    others <- loadArgsSysV config rest+    return $ this_arg S.<> others++  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat (cmmExprType platform arg)++-- | Compute all things that will need to be pushed to the stack.+--+-- On Windows, an argument passed by reference will require two pieces of data:+--+--  - the reference (returned in the first position)+--  - the actual data (returned in the second position)+computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr])+computeWinPushArgs platform = go+  where+    go :: [CmmExpr] -> ([RawStackArg], [CmmExpr])+    go [] = ([], [])+    go (arg:args) =+      let+        arg_size = argSize platform arg+        (this_arg, add_this_arg)+          | arg_size > 8+          = ( RawStackArgRef OnStack arg_size, (arg :) )+          | otherwise+          = ( RawStackArg arg, id )+        (stk_args, stk_data) = go args+      in+        (this_arg:stk_args, add_this_arg stk_data)++-- | Load arguments into available registers (Windows C X64 calling convention).+loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs+loadArgsWin _ [] = return mempty+loadArgsWin config (arg:rest) = do+  regs <- get+  case regs of+    reg:regs' -> do+      put regs'+      this_arg <- lift $ load_arg_win reg+      rest <- loadArgsWin config rest+      return $ this_arg S.<> rest+    [] -> do+      -- No more registers available: pass all (remaining) arguments on the stack.+      let (stk_args, data_args) = computeWinPushArgs platform (arg:rest)+      return $+        LoadArgs+          { stackArgs       = stk_args+          , stackDataArgs   = data_args+          , assignArgsCode  = nilOL+          , usedRegs        = []+          }+  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat $ cmmExprType platform arg+    load_arg_win (ireg, freg)+      | isVecFormat arg_fmt+       -- Vectors are passed by reference.+       -- See Note [The Windows X64 C calling convention].+      = do return $+             LoadArgs+                -- Pass the reference in a register,+                -- and the argument data on the stack.+                { stackArgs       = [RawStackArgRef (InReg ireg) (argSize platform arg)]+                , stackDataArgs   = [arg] -- we don't yet know where the data will reside,+                , assignArgsCode  = nilOL -- so we defer computing the reference and storing it+                                          -- in the register until later+                , usedRegs        = [RegWithFormat ireg II64]+                }+      | otherwise+      = do let arg_reg+                  | isFloatFormat arg_fmt+                  = freg+                  | otherwise+                  = ireg+           assign_code <- loadArgIntoReg arg arg_reg+           -- Recall that, for varargs, we must pass floating-point+           -- arguments in both fp and integer registers.+           let (assign_code', regs')+                | isFloatFormat arg_fmt =+                    ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg),+                      [ RegWithFormat freg FF64+                      , RegWithFormat ireg II64 ])+                | otherwise = (assign_code, [RegWithFormat ireg II64])+           return $+             LoadArgs+               { stackArgs       = [] -- passed in register+               , stackDataArgs   = []+               , assignArgsCode = assign_code'+               , usedRegs = regs'+               }++-- | Load an argument into a register.+--+-- Assumes that the expression does not contain any MachOps,+-- as per Note [Evaluate C-call arguments before placing in destination registers].+loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock+loadArgIntoReg arg reg = do+  when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do+    platform <- getPlatform+    massertPpr False $+      vcat [ text "loadArgIntoReg: arg might contain MachOp"+           , text "arg:" <+> pdoc platform arg ]+  arg_code <- getAnyReg arg+  return $ arg_code reg++-- -----------------------------------------------------------------------------+-- Pushing arguments onto the stack for 64-bit C calls.++-- | The size of an argument (in bytes).+--+-- Never smaller than the platform word width.+argSize :: Platform -> CmmExpr -> Int+argSize platform arg =+  max (platformWordSizeInBytes platform) $+    widthInBytes (typeWidth $ cmmExprType platform arg)++-- | Add the given amount of padding on the stack.+addStackPadding :: Int -- ^ padding (in bytes)+                -> NatM InstrBlock+addStackPadding pad_bytes+  | pad_bytes == 0+  = return nilOL+  | otherwise+  = do delta <- getDeltaNat+       setDeltaNat (delta - pad_bytes)+       return $+         toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp)+              , DELTA (delta - pad_bytes)+              ]++-- | Push one argument directly to the stack (by value).+--+-- Assumes the current stack pointer fulfills any necessary alignment requirements.+pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock+pushArgByValue config arg+   -- For 64-bit integer arguments, use PUSH II64.+   --+   -- Note: we *must not* do this for smaller arguments.+   -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@,+   -- we could end up reading unmapped memory and segfaulting.+   | isIntFormat fmt+   , formatInBytes fmt == 8+   = do+     (arg_op, arg_code) <- getOperand arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $+       arg_code `appOL` toOL+       [ PUSH II64 arg_op+       , DELTA (delta-arg_size) ]++   | otherwise+   = do+     (arg_reg, arg_code) <- getSomeReg arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $ arg_code `appOL` toOL+        [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp)+        , DELTA (delta-arg_size)+        , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ]++    where+      platform = ncgPlatform config+      arg_size = argSize platform arg+      arg_rep = cmmExprType platform arg+      fmt = cmmTypeFormat arg_rep++-- | Load an argument into a register or push it to the stack.+loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock)+loadOrPushArg config (stk_arg, mb_off) =+  case stk_arg of+    StackArg arg pad -> do+      push_code <- pushArgByValue config arg+      pad_code  <- addStackPadding pad+      return (nilOL, push_code `appOL` pad_code)+    StackArgRef { stackRef = ref } ->+      case ref of+        -- Pass the reference in a register+        InReg ireg ->+          return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL)+        -- Pass the reference on the stack+        OnStack {} -> do+          tmp <- getNewRegNat II64+          delta <- getDeltaNat+          setDeltaNat (delta-arg_ref_size)+          let push_code = toOL+                [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp)+                , DELTA (delta-arg_ref_size)+                , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp)+                , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ]+          return (nilOL, push_code)+      where off = expectJust mb_off+    where+      arg_ref_size = 8 -- passing a reference to the argument+      platform = ncgPlatform config++-- | Push arguments to the stack, right to left.+--+-- On Windows, some arguments may need to be passed by reference,+-- which requires separately passing the data and the reference.+-- See Note [The Windows X64 C calling convention].+pushArgs :: NCGConfig+         -> [RawStackArg]+            -- ^ arguments proper (i.e. don't include the data for arguments passed by reference)+         -> [StackArg]+            -- ^ arguments we are passing on the stack+         -> NatM (InstrBlock, InstrBlock)+pushArgs config proper_args all_stk_args+  = do { let+            vec_offs :: [Maybe Int]+            vec_offs+              | platformOS platform == OSMinGW32+              = go stack_arg_size all_stk_args+              | otherwise+              = repeat Nothing++    ---------------------+    -- Windows-only code++            -- Size of the arguments we are passing on the stack, counting only+            -- the reference part for arguments passed by reference.+            stack_arg_size = 8 * count not_in_reg proper_args+            not_in_reg (RawStackArg {}) = True+            not_in_reg (RawStackArgRef { stackRef = ref }) =+              case ref of+                InReg {} -> False+                OnStack {} -> True++            -- Check an offset is valid (8-byte aligned), for assertions.+            ok off = off `rem` 8 == 0++            -- Tricky code: compute the stack offset to the vector data+            -- for this argument.+            --+            -- If you're confused, Note [The Windows X64 C calling convention]+            -- contains a helpful diagram.+            go :: Int -> [StackArg] -> [Maybe Int]+            go _ [] = []+            go off (stk_arg:args) =+              assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $+              case stk_arg of+                StackArg {} ->+                  -- Only account for the stack pointer movement.+                  let off' = off - stackArgSpace platform stk_arg+                  in Nothing : go off' args+                StackArgRef+                  { stackRefArgSize    = data_size+                  , stackRefArgPadding = data_pad } ->+                  assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $+                  assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $+                  let off' = off+                        -- Next piece of data is after the data for this reference+                           + data_size + data_pad+                        -- ... and account for the stack pointer movement.+                           - stackArgSpace platform stk_arg+                  in Just (data_pad + off) : go off' args++    -- end of Windows-only code+    ----------------------------++         -- Push the stack arguments (right to left),+         -- including both the reference and the data for arguments passed by reference.+       ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs)+       ; return (load_regs, push_args) }+  where+    platform = ncgPlatform config++{- Note [The Windows X64 C calling convention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are a few facts about the Windows X64 C calling convention that+are important:++  - any argument larger than 8 bytes must be passed by reference,+    and arguments smaller than 8 bytes are padded to 8 bytes.++  - the first four arguments are passed in registers:+      - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3+      - other arguments are passed in %rcx, %rdx, %r8, %r9+        (this includes vector arguments, passed by reference)++    For variadic functions, it is additionally expected that floating point+    scalar arguments are copied to the corresponding integer register, e.g.+    the data in xmm2 should also be copied to r8.++    There is no requirement about setting %al like there is for the+    System V AMD64 ABI.++  - subsequent arguments are passed on the stack.++There are also alignment requirements:++  - the data for vectors must be aligned to the size of the vector,+    e.g. a 32 byte vector must be aligned on a 32 byte boundary,++  - the call instruction must be aligned to 16 bytes.+  (This differs from the System V AMD64 ABI, which mandates that the call+  instruction must be aligned to 32 bytes if there are any 32 byte vectors+  passed on the stack.)++This motivates our handling of vector values. Suppose we have a function call+with many arguments, several of them being vectors. We proceed as follows:++ - Add some padding, if necessary, to ensure the stack, when executing the call+    instruction, is 16-byte aligned. Whether this padding is necessary depends+    on what happens next. (Recall also that we start off at 8 (mod 16) alignment,+    as per Note [Stack Alignment on X86] in rts/StgCRun.c)+  - Push all the vectors to the stack first, adding padding after each one+    if necessary.+  - Then push the arguments:+      - for non-vectors, proceed as usual,+      - for vectors, push the address of the vector data we pushed above.+  - Then assign the registers:+      - for non-vectors, proceed as usual,+      - for vectors, store the address in a general-purpose register, as opposed+        to storing the data in an xmm register.++For a concrete example, suppose we have a call of the form:++  f x1 x2 x3 x4 x5 x6 x7++in which:++  - x2, x3, x5 and x7 are 16 byte vectors+  - the other arguments are all 8 byte wide++Now, x1, x2, x3, x4 will get passed in registers, except that we pass+x2 and x3 by reference, because they are vectors. We proceed as follows:++  - push the vectors to the stack: x7, x5, x3, x2 (in that order)+  - push the stack arguments in order: addr(x7), x6, addr(x5)+  - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1++The tricky part is to get the right offsets for the addresses of the vector+data. The following visualisation will hopefully clear things up:++                                  ┌──┐+                                  │▓▓│ ─── padding to align the call instruction+                      ╭─╴         ╞══╡     (ensures Sp, below, is 16-byte aligned)+                      │           │  │+                      │  x7  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x5  ───╴ │  │+                      │           ├──┤+     vector data  ────┤           │  │+(individually padded) │  x3  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x2  ───╴ │  │+                      │           ├┄┄┤+                      │           │▓▓│ ─── padding to align x2 to 16 bytes+               ╭─╴    ╰─╴         ╞══╡+               │    addr(x7) ───╴ │  │    ╭─ from here: x7 is +64+               │                  ├──┤ ╾──╯    = 64 (position of x5)+     stack  ───┤         x6  ───╴ │  │         + 16 (size of x5) + 0 (padding of x7)+   arguments   │                  ├──┤         - 2 * 8 (x7 is 2 arguments higher than x5)+               │    addr(x5) ───╴ │  │+               ╰─╴            ╭─╴ ╞══╡ ╾─── from here:+                              │   │  │       - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2)+                   shadow  ───┤   │  │       - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3)+                    space     │   │  │       - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5)+                              │   │  │+                              ╰─╴ └──┘ ╾─── Sp++This is all tested in the simd013 test.+-}++-- -----------------------------------------------------------------------------+-- 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))+                fmt = archWordFormat is32bit+                code = e_code `appOL` toOL+                    [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV fmt 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) (\op2 -> instr op2 . OpReg) a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Reg -> 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) dst+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op 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++-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@,+-- with 3 operands (FMA3 instruction set).+genFMA3Code :: Length+            -> Width+            -> FMASign+            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register+genFMA3Code l w signs x y z = do+  config <- getConfig+  -- For the FMA instruction, we want to compute x * y + z+  --+  -- There are three possible instructions we could emit:+  --+  --   - fmadd213 z y x, result in x, z can be a memory address+  --   - fmadd132 x z y, result in y, x can be a memory address+  --   - fmadd231 y x z, result in z, y can be a memory address+  --+  -- This suggests two possible optimisations:+  --+  --   - OPTIMISATION 1+  --     If one argument is an address, use the instruction that allows+  --     a memory address in that position.+  --+  --   - OPTIMISATION 2+  --     If one argument is in a fixed register, use the instruction that puts+  --     the result in that same register.+  --+  -- Currently we follow neither of these optimisations,+  -- opting to always use fmadd213 for simplicity.+  --+  -- We would like to compute the result directly into the requested register.+  -- To do so we must first compute `x` into the destination register. This is+  -- only possible if the other arguments don't use the destination register.+  -- We check for this and if there is a conflict we move the result only after+  -- the computation. See #24496 how this went wrong in the past.+  let rep+        | l == 1+        = floatFormat w+        | otherwise+        = vecFormat (cmmVec l $ cmmFloat w)+  (y_reg, y_code) <- getNonClobberedReg y+  (z_op, z_code) <- getNonClobberedOperand z+  x_code <- getAnyReg x+  x_tmp <- getNewRegNat rep+  let+     fma213 = FMA3 rep signs FMA213++     code, code_direct, code_mov :: Reg -> InstrBlock+     -- Ideal: Compute the result directly into dst+     code_direct dst = x_code dst `snocOL`+                       fma213 z_op y_reg dst+     -- Fallback: Compute the result into a tmp reg and then move it.+     code_mov dst    = x_code x_tmp `snocOL`+                       fma213 z_op y_reg x_tmp `snocOL`+                       mkRegRegMoveInstr config rep x_tmp dst++     code dst =+        y_code `appOL`+        z_code `appOL`+        ( if arg_regs_conflict then code_mov dst else code_direct dst )++      where++        arg_regs_conflict =+          y_reg == dst ||+          case z_op of+            OpReg z_reg -> z_reg == dst+            OpAddr amode -> dst `elem` addrModeRegs amode+            OpImm {} -> False++  -- NB: Computing the result into a desired register using Any can be tricky.+  -- So for now, we keep it simple. (See #24496).+  return (Any rep code)++-----------++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 -> Reg -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 ty instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat ty+++--------------------------------------------------------------------------------+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+      x@(VecFormat {}) -> 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)++needLlvm :: MachOp -> NatM a+needLlvm mop =+  sorry $ unlines [ "Unsupported vector instruction for the native code generator:"+                  , show mop+                  , "Please use -fllvm." ]++incorrectOperands :: NatM a+incorrectOperands = sorry "Incorrect number of operands"++invalidConversion :: Width -> Width -> NatM a+invalidConversion from to =+  sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to++-- | 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 = do+        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 = min 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 = min 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 threshold (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 threshold (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+        tmp <- getNewRegNat II32+        -- Swap the low and high halves of the register.+        --+        -- NB: if dst_hi == rhi, we must make sure to preserve the contents+        -- of rhi before writing to dst_hi (#25601).+        let shuffle = if dst_hi == rhi && dst_lo == rlo then+                        toOL [ MOV II32 (OpReg rhi) (OpReg tmp),+                               MOV II32 (OpReg rlo) (OpReg dst_hi),+                               MOV II32 (OpReg tmp) (OpReg dst_lo) ]+                      else if dst_hi == rhi then+                        toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo),+                               MOV II32 (OpReg rlo) (OpReg dst_hi) ]+                      else+                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+                               MOV II32 (OpReg rhi) (OpReg dst_lo) ]+        return $ vcode `appOL` shuffle `appOL`+                 toOL [ 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 -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width _mord dst addr = do+  let fmt = intFormat width+  load_code <- intLoadCode (MOV fmt) addr+  return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width mord addr val = do+  code <- assignMem_IntCode (intFormat width) addr val+  let needs_fence = case mord of+        MemOrderSeqCst  -> True+        MemOrderRelease -> False+        MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty+        MemOrderRelaxed -> False+  return $ if needs_fence then code `snocOL` MFENCE else code++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)]
+ GHC/CmmToAsm/X86/Cond.hs view
@@ -0,0 +1,91 @@+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
+ GHC/CmmToAsm/X86/Instr.hs view
@@ -0,0 +1,1533 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------++module GHC.CmmToAsm.X86.Instr+   ( Instr(..)+   , Operand(..)+   , PrefetchVariant(..)+   , FMAPermutation(..)+   , JumpDest(..)+   , getJumpDestBlockId+   , canShortcut+   , shortcutStatics+   , shortcutJump+   , allocMoreStack+   , maxSpillSlots+   , archWordFormat+   , takeRegRegMoveInstr+   , regUsageOfInstr+   , takeDeltaInstr+   , mkLoadInstr+   , mkJumpInstr+   , mkStackAllocInstr+   , mkStackDeallocInstr+   , mkSpillInstr+   , mkRegRegMoveInstr+   , movInstr+   , jumpDestsOfInstr+   , canFallthroughTo+   , patchRegsOfInstr+   , patchJumpInstr+   , isMetaInstr+   , isJumpishInstr+   , MinOrMax(..), MinMaxType(..)+   )+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.Reg.Target (targetClassOfReg)+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Unified++import GHC.CmmToAsm.Config++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Platform.Regs+import GHC.Cmm+import GHC.Utils.Constants ( debugIsOn )+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.DSM+import GHC.Types.Basic (Alignment)+import GHC.Cmm.DebugBlock (UnwindTable)+import GHC.Utils.Misc ( HasDebugCallStack )++import GHC.Data.Maybe++-- Format of an x86/x86_64 memory address, in bytes.+--+archWordFormat :: Bool -> Format+archWordFormat is32Bit+ | is32Bit   = II32+ | otherwise = II64++-- -----------------------------------------------------------------------------+-- Intel x86 instructions++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++        -- | X86 scalar move instruction.+        --+        -- When used at a vector format, only moves the lower 64 bits of data;+        -- the rest of the data in the destination may either be zeroed or+        -- preserved, depending on the specific format and operands.+        | MOV Format Operand Operand+             -- N.B. Due to AT&T assembler quirks, when used with 'II64'+             -- 'Format' immediate source and memory target operand, the source+             -- operand is interpreted to be a 32-bit sign-extended value.+             -- True 64-bit operands need to be either first moved to a register or moved+             -- with @MOVABS@; we currently do not use this instruction in GHC.+             -- See https://stackoverflow.com/questions/52434073/whats-the-difference-between-the-x86-64-att-instructions-movq-and-movabsq.++        -- | MOVD/MOVQ SSE2 instructions+        -- (bitcast between a general purpose register and a float register).+        | MOVD+           Format -- ^ input format+           Format -- ^ output format+           Operand Operand+           -- NB: MOVD stores both the input and output formats. This is because+           -- neither format fully determines the other, as either might be+           -- a vector format, and we need to know the exact format in order to+           -- correctly spill/unspill. See #25659.+        | 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+        -- | AVX bitwise logical XOR operation+        | VXOR        Format Operand Reg Reg+        | 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+        | SHRD        Format Operand{-amount-} Operand Operand+        | SHLD        Format Operand{-amount-} Operand 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 don't 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++        -- | FMA3 fused multiply-add operations.+        | FMA3         Format FMASign FMAPermutation Operand Reg Reg+          -- For the FMA213 permutation (the only one we use currently),+          -- this is: src3 (r/m), src2 (r), dst/src1 (r)+          -- (NB: this isexactly reversed from how Intel lists the arguments.)++        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands+        -- are  Operand Reg.++        -- SSE2 floating-point division:+        | FDIV          Format Operand Reg   -- 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 [RegWithFormat] -- 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+                      [RegWithFormat]  -- ^ 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++        -- Vector Instructions --+        -- NOTE: Instructions follow the AT&T syntax+        -- Constructors and deconstructors+        | VBROADCAST  Format Operand Reg+        | VPBROADCAST Format Format Operand Reg -- scalar format, vector format, source, destination+        | VEXTRACT    Format Imm Reg Operand+        | INSERTPS    Format Imm Operand Reg+        | VINSERTPS   Format Imm Operand Reg Reg+        | PINSR       Format Format Imm Operand Reg -- scalar format, vector format, offset, scalar src, vector+        | PEXTR       Format Format Imm Reg Operand -- scalar format, vector format, offset, vector src, scalar dst++        -- move operations++        -- | SSE2 unaligned move of floating-point vectors+        | MOVU        Format Operand Operand+        -- | AVX unaligned move of floating-point vectors+        | VMOVU       Format Operand Operand+        -- | SSE2 move between memory and low-part of an xmm register+        | MOVL        Format Operand Operand+        -- | SSE move between memory and high-part of an xmm register+        | MOVH        Format Operand Operand+        -- | SSE2 unaligned move of integer vectors+        | MOVDQU      Format Operand Operand+        -- | AVX unaligned move of integer vectors+        | VMOVDQU     Format Operand Operand+        -- | Alias for VMOVSS/VMOVSD, used to merge two vectors+        | VMOV_MERGE  Format Reg Reg Reg++        -- logic operations+        | PXOR        Format Operand Reg+        | VPXOR       Format Reg Reg Reg+        | PAND        Format Operand Reg+        | PANDN       Format Operand Reg+        | POR         Format Operand Reg++        -- Arithmetic+        | VADD       Format Operand Reg Reg+        | VSUB       Format Operand Reg Reg+        | VMUL       Format Operand Reg Reg+        | VDIV       Format Operand Reg Reg+        | PADD       Format Operand Reg+        | PSUB       Format Operand Reg+        | PMULL      Format Operand Reg+        | PMULUDQ    Format Operand Reg++        -- SIMD compare+        | PCMPGT     Format Operand Reg++        -- Shuffle+        | SHUF       Format Imm Operand Reg+        | VSHUF      Format Imm Operand Reg Reg+        | PSHUFB     Format Operand Reg+        | PSHUFLW    Format Imm Operand Reg+        | PSHUFHW    Format Imm Operand Reg+        | PSHUFD     Format Imm Operand Reg+        | VPSHUFD    Format Imm Operand Reg+        | BLEND      Format Imm Operand Reg+        | VBLEND     Format Imm Operand Reg Reg+        | PBLENDW    Format Imm Operand Reg++        -- | Move two 32-bit floats from the high part of an xmm register+        -- to the low part of another xmm register.+        --+        -- If the format is a vector format, the destination register is treated as the second source.+        -- If the format is FF32 or FF64, the destination register is not treated as a source.+        | MOVHLPS    Format Reg Reg+        | VMOVHLPS   Format Reg Reg Reg+        | MOVLHPS    Format Reg Reg+        | VMOVLHPS   Format Reg Reg Reg+        | UNPCKL     Format Operand Reg+        | VUNPCKL    Format Operand Reg Reg+        | UNPCKH     Format Operand Reg+        | VUNPCKH    Format Operand Reg Reg+        | PUNPCKLQDQ Format Operand Reg+        | PUNPCKLDQ  Format Operand Reg+        | PUNPCKLWD  Format Operand Reg+        | PUNPCKLBW  Format Operand Reg+        | PUNPCKHQDQ Format Operand Reg+        | PUNPCKHDQ  Format Operand Reg+        | PUNPCKHWD  Format Operand Reg+        | PUNPCKHBW  Format Operand Reg+        | PACKUSWB   Format Operand Reg++        -- Shift+        | PSLL       Format Operand Reg+        | PSLLDQ     Format Imm Reg+        | PSRL       Format Operand Reg+        | PSRLDQ     Format Imm Reg+        | PALIGNR    Format Imm Operand Reg++        -- min/max+        | MINMAX  MinOrMax MinMaxType Format Operand Reg+        | VMINMAX MinOrMax MinMaxType Format Operand Reg Reg++data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2++-- | 'MIN' or 'MAX'+data MinOrMax = Min | Max+  deriving ( Eq, Show )+-- | What kind of min/max operation: signed or unsigned vector integer min/max,+-- or (scalar or vector) floating point min/max?+data MinMaxType =+  IntVecMinMax { minMaxSigned :: Bool } | FloatMinMax+  deriving ( Eq, Show )++data Operand+        = OpReg  Reg            -- register+        | OpImm  Imm            -- immediate value+        | OpAddr AddrMode       -- memory reference++-- NB: As of 2023 we only use the FMA213 permutation.+data FMAPermutation = FMA132 | FMA213 | FMA231++-- | Returns which registers are read and written as a (read, written)+-- pair.+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr+ = case instr of+    MOV fmt src dst+      -- MOVSS/MOVSD preserve the upper half of vector registers,+      -- but only for reg-2-reg moves+      | VecFormat _ sFmt <- fmt+      , isFloatScalarFormat sFmt+      , OpReg {} <- src+      , OpReg {} <- dst+      -> usageRM fmt src dst+      -- other MOV instructions zero any remaining upper part of the destination+      -- (largely to avoid partial register stalls)+      | otherwise+      -> usageRW fmt src dst+    MOVD fmt1 fmt2 src dst    ->+      -- NB: MOVD and MOVQ always zero any remaining upper part of destination,+      -- so the destination is "written" not "modified".+      usageRW' fmt1 fmt2 src dst+    CMOV _ fmt src dst    -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    MOVZxL fmt src dst    -> usageRW fmt src dst+    MOVSxL fmt src dst    -> usageRW fmt src dst+    LEA    fmt src dst    -> usageRW fmt src dst+    ADD    fmt src dst    -> usageRM fmt src dst+    ADC    fmt src dst    -> usageRM fmt src dst+    SUB    fmt src dst    -> usageRM fmt src dst+    SBB    fmt src dst    -> usageRM fmt src dst+    IMUL   fmt src dst    -> usageRM fmt src dst++    -- Result of IMULB will be in just in %ax+    IMUL2  II8 src       -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax]+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and+    -- %ax/%eax/%rax.+    IMUL2  fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx]++    MUL    fmt src dst    -> usageRM fmt src dst+    MUL2   fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx]+    DIV    fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    IDIV   fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    ADD_CC fmt src dst    -> usageRM fmt src dst+    SUB_CC fmt src dst    -> usageRM fmt src dst+    AND    fmt src dst    -> usageRM fmt src dst+    OR     fmt src dst    -> usageRM fmt src dst++    XOR    fmt (OpReg src) (OpReg dst)+      | src == dst+      -> mkRU [] [mk fmt dst]+    XOR    fmt src dst+      -> usageRM fmt src dst+    VXOR fmt (OpReg src1) src2 dst+      | src1 == src2, src1 == dst+      -> mkRU [] [mk fmt dst]+    VXOR fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]++    NOT    fmt op         -> usageM fmt op+    BSWAP  fmt reg        -> mkRU [mk fmt reg] [mk fmt reg]+    NEGI   fmt op         -> usageM fmt op+    SHL    fmt imm dst    -> usageRM fmt imm dst+    SAR    fmt imm dst    -> usageRM fmt imm dst+    SHR    fmt imm dst    -> usageRM fmt imm dst+    SHLD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    SHRD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    BT     fmt _   src    -> mkRUR (use_R fmt src [])++    PUSH   fmt op         -> mkRUR (use_R fmt op [])+    POP    fmt op         -> mkRU [] (def_W fmt op)+    TEST   fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    CMP    fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    SETCC  _ op         -> mkRU [] (def_W II8 op)+    JXX    _ _          -> mkRU [] []+    JXX_GBL _ _         -> mkRU [] []+    JMP     op regs     -> mkRU (use_R addrFmt op regs) []+    JMP_TBL op _ _ _    -> mkRU (use_R addrFmt op []) []+    CALL (Left _)  params   -> mkRU params (map mkFmt $ callClobberedRegs platform)+    CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform)+    CLTD   fmt          -> mkRU [mk fmt eax] [mk fmt edx]+    NOP                 -> mkRU [] []++    X87Store _fmt  dst -> mkRUR (use_EA dst [])++    CVTSS2SD   src dst  -> mkRU [mk FF32 src] [mk FF64 dst]+    CVTSD2SS   src dst  -> mkRU [mk FF64 src] [mk FF32 dst]+    CVTTSS2SIQ fmt src dst -> mkRU (use_R FF32 src []) [mk fmt dst]+    CVTTSD2SIQ fmt src dst -> mkRU (use_R FF64 src []) [mk fmt dst]+    CVTSI2SS   fmt src dst -> mkRU (use_R fmt src []) [mk FF32 dst]+    CVTSI2SD   fmt src dst -> mkRU (use_R fmt src []) [mk FF64 dst]+    FDIV fmt     src dst  -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    SQRT fmt src dst      -> mkRU (use_R fmt src []) [mk fmt dst]++    FETCHGOT reg        -> mkRU [] [mk addrFmt reg]+    FETCHPC  reg        -> mkRU [] [mk addrFmt reg]++    COMMENT _           -> noUsage+    LOCATION{}          -> noUsage+    UNWIND{}            -> noUsage+    DELTA   _           -> noUsage++    POPCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    LZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    TZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSF    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSR    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]++    PDEP   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst]+    PEXT   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst]++    FMA3 fmt _ _ src3 src2 dst -> usageFMA fmt src3 src2 dst++    -- note: might be a better way to do this+    PREFETCH _  fmt src -> mkRU (use_R fmt src []) []+    LOCK i              -> regUsageOfInstr platform i+    XADD fmt src dst      -> usageMM fmt src dst+    CMPXCHG fmt src dst   -> usageRMM fmt src dst (OpReg eax)+    XCHG fmt src dst      -> usageMM fmt src (OpReg dst)+    MFENCE -> noUsage++    -- vector instructions+    VBROADCAST fmt src dst   -> mkRU (use_R fmt src []) [mk fmt dst]+    VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst]+    VEXTRACT     fmt _off src dst -> usageRW fmt (OpReg src) dst+    INSERTPS     fmt (ImmInt off) src dst+      -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]+        where+          -- Compute whether the instruction reads the destination register or not.+          -- Immediate bits: ss_dd_zzzz s = src pos, d = dst pos, z = zeroed components.+          doesNotReadDst = and [ testBit off i | i <- [0, 1, 2, 3], i /= pos ]+            -- Check whether the positions in which we are not inserting+            -- are being zeroed.+            where pos = ( off `shiftR` 4 ) .&. 0b11+    INSERTPS fmt _off src dst+      -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]+    VINSERTPS fmt _imm src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PINSR sFmt vFmt _off src dst+      -> mkRU (use_R sFmt src [mk vFmt dst]) [mk vFmt dst]+    PEXTR sFmt vFmt _off src dst+      -> usageRW' vFmt sFmt (OpReg src) dst++    VMOVU        fmt src dst   -> usageRW fmt src dst+    MOVU         fmt src dst   -> usageRW fmt src dst+    MOVL         fmt src dst   -> usageRM fmt src dst+    MOVH         fmt src dst   -> usageRM fmt src dst+    MOVDQU       fmt src dst   -> usageRW fmt src dst+    VMOVDQU      fmt src dst   -> usageRW fmt src dst+    VMOV_MERGE   fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]++    PXOR fmt (OpReg src) dst+      | src == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]++    VPXOR        fmt s1 s2 dst+      | s1 == s2, s1 == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt s1, mk fmt s2] [mk fmt dst]++    PAND         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PANDN        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    POR          fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    VADD         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VSUB         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VMUL         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VDIV         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    PADD         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PSUB         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULL        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULUDQ      fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    PCMPGT       fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    SHUF fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VSHUF fmt _mask src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]+    PSHUFB fmt mask dst+      -> mkRU (use_R fmt mask [mk fmt dst]) [mk fmt dst]+    PSHUFLW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    PSHUFHW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    PSHUFD fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    VPSHUFD fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    BLEND fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VBLEND fmt _mask src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PBLENDW fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    PSLL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSLLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PSRL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSRLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PALIGNR fmt _off src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    MOVHLPS    fmt src dst+      -> case fmt of+           VecFormat {} -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+           -- MOVHLPS moves the high 64 bits of src to the low 64 bits of dst,+           -- keeping the high 64 bits of dst intact.+           -- If we only care about the lower 64 bits of the result,+           -- dst is only written to, not read.+           FF64 -> mkRU [mk (VecFormat 2 FmtDouble) src] [mk fmt dst]+           FF32 -> mkRU [mk (VecFormat 4 FmtFloat) src] [mk fmt dst]+           _ -> pprPanic "regUsage: invalid format for MOVHLPS" (ppr fmt)+    VMOVHLPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]+    MOVLHPS    fmt src dst+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+    VMOVLHPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]+    UNPCKL fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKL fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    UNPCKH fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKH fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PUNPCKLQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PACKUSWB fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    MINMAX _ _ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VMINMAX _ _ fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]+    _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 :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRW fmt op (OpReg reg)      = mkRU (use_R fmt op []) [mk fmt reg]+    usageRW fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRW _ _ _                   = panic "X86.RegInfo.usageRW: no match"++    usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage+    usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg]+    usageRW' fmt1 _    op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea [])+    usageRW' _  _ _ _                 = panic "X86.RegInfo.usageRW: no match"++    -- 2 operand form; first operand Read; second Modified+    usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRM fmt op (OpReg reg)      = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg]+    usageRM fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRM _ _ _                   = panic "X86.RegInfo.usageRM: no match"++    -- 2 operand form; first operand Modified; second Modified+    usageMM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageMM fmt (OpReg src) (OpReg dst) = mkRU [mk fmt src, mk fmt dst] [mk fmt src, mk fmt dst]+    usageMM fmt (OpReg src) (OpAddr ea) = mkRU (use_EA ea [mk fmt src]) [mk fmt src]+    usageMM fmt (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [mk fmt dst]) [mk fmt dst]+    usageMM _ _ _                       = panic "X86.RegInfo.usageMM: no match"++    -- 3 operand form; first operand Read; second Modified; third Modified+    usageRMM :: HasDebugCallStack => Format -> Operand -> Operand -> Operand -> RegUsage+    usageRMM fmt (OpReg src) (OpReg dst) (OpReg reg) = mkRU [mk fmt src, mk fmt dst, mk fmt reg] [mk fmt dst, mk fmt reg]+    usageRMM fmt (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [mk fmt src, mk fmt reg]) [mk fmt reg]+    usageRMM _ _ _ _                                 = panic "X86.RegInfo.usageRMM: no match"++    -- 3 operand form of FMA instructions.+    usageFMA :: HasDebugCallStack => Format -> Operand -> Reg -> Reg -> RegUsage+    usageFMA fmt (OpReg src1) src2 dst =+      mkRU [mk fmt src1, mk fmt src2, mk fmt dst] [mk fmt dst]+    usageFMA fmt (OpAddr ea1) src2 dst+      = mkRU (use_EA ea1 [mk fmt src2, mk fmt  dst]) [mk fmt dst]+    usageFMA _ _ _ _+      = panic "X86.RegInfo.usageFMA: no match"++    -- 1 operand form; operand Modified+    usageM :: HasDebugCallStack => Format -> Operand -> RegUsage+    usageM fmt (OpReg reg) =+      let r' = mk fmt reg+      in mkRU [r'] [r']+    usageM _ (OpAddr ea) = mkRUR (use_EA ea [])+    usageM _ _ = panic "X86.RegInfo.usageM: no match"++    -- Registers defd when an operand is written.+    def_W fmt (OpReg reg)         = [mk fmt reg]+    def_W _   (OpAddr _ )         = []+    def_W _   _                   = panic "X86.RegInfo.def_W: no match"++    -- Registers used when an operand is read.+    use_R :: HasDebugCallStack => Format -> Operand -> [RegWithFormat] -> [RegWithFormat]+    use_R fmt (OpReg reg)  tl = mk fmt 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 = mk addrFmt r : tl+              use_base _              tl = tl+              use_index EAIndexNone   tl = tl+              use_index (EAIndex i _) tl = mk addrFmt i : tl++    mkRUR :: [RegWithFormat] -> RegUsage+    mkRUR src = mkRU src []++    mkRU :: [RegWithFormat] -> [RegWithFormat] -> RegUsage+    mkRU src dst = src' `seq` dst' `seq` RU src' dst'+        where src' = filter (interesting platform . regWithFormat_reg) src+              dst' = filter (interesting platform . regWithFormat_reg) dst++    addrFmt = archWordFormat (target32Bit platform)+    mk :: Format -> Reg -> RegWithFormat+    mk fmt r = RegWithFormat r fmt++    mkFmt :: Reg -> RegWithFormat+    mkFmt r = RegWithFormat r $ case targetClassOfReg platform r of+      RcInteger -> addrFmt+      RcFloatOrVector -> FF64++-- | 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 :: HasDebugCallStack => Platform -> Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr platform instr env+  = case instr of+    MOV fmt src dst      -> MOV fmt (patchOp src) (patchOp dst)+    MOVD fmt1 fmt2 src dst -> patch2 (MOVD fmt1 fmt2) 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+    VXOR fmt src1 src2 dst -> VXOR fmt (patchOp src1) (env src2) (env 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+    SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2+    SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2+    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++    FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3++    -- 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) (env 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+    LDATA {}            -> instr+    NEWBLOCK {}         -> 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 platform 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++    -- vector instructions+    VBROADCAST   fmt src dst   -> VBROADCAST fmt (patchOp src) (env dst)+    VPBROADCAST  fmt1 fmt2 src dst+      -> VPBROADCAST fmt1 fmt2 (patchOp src) (env dst)+    VEXTRACT     fmt off src dst+      -> VEXTRACT fmt off (env src) (patchOp dst)+    INSERTPS    fmt off src dst+      -> INSERTPS fmt off (patchOp src) (env dst)+    VINSERTPS   fmt off src2 src1 dst+      -> VINSERTPS fmt off (patchOp src2) (env src1) (env dst)+    PINSR       fmt1 fmt2 off src dst+      -> PINSR fmt1 fmt2 off (patchOp src) (env dst)+    PEXTR       fmt1 fmt2 off src dst+      -> PEXTR fmt1 fmt2 off (env src) (patchOp dst)++    VMOVU      fmt src dst   -> VMOVU fmt (patchOp src) (patchOp dst)+    MOVU       fmt src dst   -> MOVU  fmt (patchOp src) (patchOp dst)+    MOVL       fmt src dst   -> MOVL  fmt (patchOp src) (patchOp dst)+    MOVH       fmt src dst   -> MOVH  fmt (patchOp src) (patchOp dst)+    MOVDQU     fmt src dst   -> MOVDQU  fmt (patchOp src) (patchOp dst)+    VMOVDQU    fmt src dst   -> VMOVDQU fmt (patchOp src) (patchOp dst)+    VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst)++    PXOR       fmt src dst   -> PXOR fmt (patchOp src) (env dst)+    VPXOR      fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst)+    PAND       fmt src dst   -> PAND fmt (patchOp src) (env dst)+    PANDN      fmt src dst   -> PANDN fmt (patchOp src) (env dst)+    POR        fmt src dst   -> POR fmt (patchOp src) (env dst)++    VADD       fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst)+    VSUB       fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst)+    VMUL       fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst)+    VDIV       fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst)+    PADD       fmt src dst   -> PADD fmt (patchOp src) (env dst)+    PSUB       fmt src dst   -> PSUB fmt (patchOp src) (env dst)+    PMULL      fmt src dst   -> PMULL fmt (patchOp src) (env dst)+    PMULUDQ    fmt src dst   -> PMULUDQ fmt (patchOp src) (env dst)++    PCMPGT     fmt src dst   -> PCMPGT fmt (patchOp src) (env dst)++    SHUF      fmt off src dst+      -> SHUF fmt off (patchOp src) (env dst)+    VSHUF      fmt off src1 src2 dst+      -> VSHUF fmt off (patchOp src1) (env src2) (env dst)+    PSHUFB       fmt mask dst+      -> PSHUFB fmt (patchOp mask) (env dst)+    PSHUFLW      fmt off src dst+      -> PSHUFLW fmt off (patchOp src) (env dst)+    PSHUFHW      fmt off src dst+      -> PSHUFHW fmt off (patchOp src) (env dst)+    PSHUFD       fmt off src dst+      -> PSHUFD  fmt off (patchOp src) (env dst)+    VPSHUFD      fmt off src dst+      -> VPSHUFD fmt off (patchOp src) (env dst)+    BLEND        fmt mask src dst+      -> BLEND   fmt mask (patchOp src) (env dst)+    VBLEND       fmt mask src2 src1 dst+      -> VBLEND  fmt mask (patchOp src2) (env src1) (env dst)+    PBLENDW      fmt mask src dst+      -> PBLENDW fmt mask (patchOp src) (env dst)++    PSLL         fmt off dst+      -> PSLL    fmt (patchOp off) (env dst)+    PSLLDQ       fmt off dst+      -> PSLLDQ  fmt off (env dst)+    PSRL         fmt off dst+      -> PSRL    fmt (patchOp off) (env dst)+    PSRLDQ       fmt off dst+      -> PSRLDQ  fmt off (env dst)+    PALIGNR      fmt off src dst+      -> PALIGNR fmt off (patchOp src) (env dst)++    MOVHLPS    fmt src dst+      -> MOVHLPS fmt (env src) (env dst)+    VMOVHLPS   fmt src2 src1 dst+      -> VMOVHLPS fmt (env src2) (env src1) (env dst)+    MOVLHPS    fmt src dst+      -> MOVLHPS fmt (env src) (env dst)+    VMOVLHPS   fmt src2 src1 dst+      -> VMOVLHPS fmt (env src2) (env src1) (env dst)+    UNPCKL fmt src dst+      -> UNPCKL fmt (patchOp src) (env dst)+    VUNPCKL fmt src2 src1 dst+      -> VUNPCKL fmt (patchOp src2) (env src1) (env dst)+    UNPCKH fmt src dst+      -> UNPCKH fmt (patchOp src) (env dst)+    VUNPCKH fmt src2 src1 dst+      -> VUNPCKH fmt (patchOp src2) (env src1) (env dst)+    PUNPCKLQDQ fmt src dst+      -> PUNPCKLQDQ fmt (patchOp src) (env dst)+    PUNPCKLDQ fmt src dst+      -> PUNPCKLDQ fmt (patchOp src) (env dst)+    PUNPCKLWD fmt src dst+      -> PUNPCKLWD fmt (patchOp src) (env dst)+    PUNPCKLBW fmt src dst+      -> PUNPCKLBW fmt (patchOp src) (env dst)+    PUNPCKHQDQ fmt src dst+      -> PUNPCKHQDQ fmt (patchOp src) (env dst)+    PUNPCKHDQ fmt src dst+      -> PUNPCKHDQ fmt (patchOp src) (env dst)+    PUNPCKHWD fmt src dst+      -> PUNPCKHWD fmt (patchOp src) (env dst)+    PUNPCKHBW fmt src dst+      -> PUNPCKHBW fmt (patchOp src) (env dst)+    PACKUSWB fmt src dst+      -> PACKUSWB fmt (patchOp src) (env dst)++    MINMAX minMax ty fmt src dst+      -> MINMAX minMax ty fmt (patchOp src) (env dst)+    VMINMAX minMax ty fmt src1 src2 dst+      -> VMINMAX minMax ty fmt (patchOp src1) (env src2) (env dst)++  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+    patch3 :: (Operand -> Reg -> Reg -> a) -> Operand -> Reg -> Reg -> a+    patch3 insn src1 src2 dst = ((insn $! patchOp src1) $! env src2) $! env 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++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid+  = case insn of+    JXX _ target          -> bid == target+    JMP_TBL _ targets _ _ -> all isTargetBid targets+    _                     -> False+  where+    isTargetBid target = case target of+      Nothing                      -> True+      Just (DestBlockId target) -> target == bid+      _                  -> 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+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat -- register to spill+    -> Int       -- current stack delta+    -> Int       -- spill slot to use+    -> [Instr]++mkSpillInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpReg reg) (OpAddr (spRel platform off)) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+      -- Spill the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta++-- | Make a spill reload instruction.+mkLoadInstr+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat      -- register to load+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> [Instr]++mkLoadInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpAddr (spRel platform off)) (OpReg reg) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+        -- Load the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta++-- | A move instruction for moving the entire contents of an operand+-- at the given 'Format'.+movInstr :: HasDebugCallStack => NCGConfig -> Format -> (Operand -> Operand -> Instr)+movInstr config fmt =+  case fmt of+    VecFormat _ sFmt ->+      case formatToWidth fmt of+        W512 ->+          if avx512f+          then avx_move sFmt+          else sorry "512-bit wide vectors require -mavx512f"+        W256 ->+          if avx2+          then avx_move sFmt+          else sorry "256-bit wide vectors require -mavx2"+        W128 ->+          if avx+            -- Prefer AVX instructions over SSE when available+            -- (usually results in better performance).+          then avx_move sFmt+          else sse_move sFmt+        w -> sorry $ "Unhandled SIMD vector width: " ++ show w ++ " bits"+    _ -> MOV fmt+  where++    assertCompatibleRegs :: ( Operand -> Operand -> Instr ) -> Operand -> Operand -> Instr+    assertCompatibleRegs f+      | debugIsOn+      = \ op1 op2 ->+          if | OpReg r1 <- op1+             , OpReg r2 <- op2+             , targetClassOfReg plat r1 /= targetClassOfReg plat r2+             -> assertPpr False+                  ( vcat [ text "movInstr: move between incompatible registers"+                         , text "fmt:" <+> ppr fmt+                         , text "r1:" <+> ppr r1+                         , text "r2:" <+> ppr r2 ]+                  ) f op1 op2+             | otherwise+             -> f op1 op2+      | otherwise+      = f++    plat    = ncgPlatform config+    avx     = ncgAvxEnabled config+    avx2    = ncgAvx2Enabled config+    avx512f = ncgAvx512fEnabled config+    avx_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           VMOVU   fmt+      else VMOVDQU fmt+    sse_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           MOVU   fmt+      else MOVDQU fmt+    -- NB: we are using {V}MOVU and not {V}MOVA, because we have no guarantees+    -- about the stack being sufficiently aligned (even for even numbered stack slots).+    --+    -- (Ben Gamari told me that using MOVA instead of MOVU does not make a+    -- difference in practice when moving between registers.)++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+    :: HasDebugCallStack+    => NCGConfig+    -> Format+    -> Reg+    -> Reg+    -> Instr+mkRegRegMoveInstr config fmt src dst =+  movInstr config fmt' (OpReg src) (OpReg dst)+    -- Move the platform word size, at a minimum.+    --+    -- This ensures the upper part of the register is properly cleared+    -- and avoids partial register stalls.+    --+    -- See also the 'ArithInt8' and 'ArithWord8' tests,+    -- which fail without this logic.+  where+    platform = ncgPlatform config+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt++scalarMoveFormat :: Platform -> Format -> Format+scalarMoveFormat platform fmt+  | isFloatFormat fmt+  = FF64+  | II64 <- fmt+  = II64+  | otherwise+  = archWordFormat (target32Bit platform)++-- | 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+        :: Platform+        -> Instr+        -> Maybe (Reg,Reg)++takeRegRegMoveInstr platform = \case+  MOV fmt (OpReg r1) (OpReg r2)+    -- When used with vector registers, MOV only moves the lower part,+    -- so it is not a real move. For example, MOVSS/MOVSD between xmm registers+    -- preserves the upper half, and MOVQ between xmm registers zeroes the upper half.+    | not $ isVecFormat fmt+    -- Don't eliminate a move between e.g. RAX and XMM:+    -- even though we might be using XMM to store a scalar integer value,+    -- some instructions only support XMM registers.+    , targetClassOfReg platform r1 == targetClassOfReg platform r2+    -> Just (r1, r2)+  MOVD {}+    -- MOVD moves between xmm registers and general-purpose registers,+    -- and we don't want to eliminate those moves (as noted for MOV).+    -> Nothing++  -- SSE2/AVX move instructions always move the full register.+  MOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  MOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)++  -- TODO: perhaps we can eliminate MOVZxL in certain situations?+  MOVZxL {} -> Nothing+  MOVSxL {} -> Nothing++  -- MOVL, MOVH and MOVHLPS preserve some part of the destination register,+  -- so are not simple moves.+  MOVL {} -> Nothing+  MOVH {} -> Nothing+  MOVHLPS {} -> Nothing++  -- Other instructions are not moves.+  _ -> 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_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_64 | needs_probe_call platform amount ->+                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)+                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [RegWithFormat rax II64]+                           , 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+  -> UniqDSM (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++    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++    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++      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"++-- Implementations of the methods of 'NgcImpl'++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 emptyUniqueSet 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)+        -> UniqueSet+        -> BlockId+        -> CLabel++shortBlockId fn seen blockid =+  case (memberUniqueSet uq seen, fn blockid) of+    (True, _)    -> blockLbl blockid+    (_, Nothing) -> blockLbl blockid+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (insertUniqueSet uq seen) blockid'+    (_, Just (DestImm (ImmCLbl lbl))) -> lbl+    (_, _other) -> panic "shortBlockId"+  where uq = getUnique blockid
+ GHC/CmmToAsm/X86/Ppr.hs view
@@ -0,0 +1,1562 @@++{-# 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.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.List ( intersperse )+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 entry_lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config+      top_info_table = topInfoTable proc+      -- we need a label to delimit the proc code (e.g. in debug builds). When+      -- we have an info table, we reuse the info table label. Otherwise we use+      -- the entry label.+      proc_lbl = case top_info_table of+        Just (CmmStaticsRaw info_lbl _) -> info_lbl+        Nothing                         -> entry_lbl++      -- handle subsections_via_symbols when enabled and when we have an+      -- info-table to link to. See Note [Subsections Via Symbols]+      (sub_via_sym_label,sub_via_sym_offset)+        | platformHasSubsectionsViaSymbols platform+        , Just (CmmStaticsRaw info_lbl _) <- top_info_table+        , info_dsp_lbl <- pprAsmLabel platform (mkDeadStripPreventer info_lbl)+        = ( line (info_dsp_lbl <> colon)+          , line $ text "\t.long " <+> pprAsmLabel platform info_lbl <+> char '-' <+> info_dsp_lbl+          )+        | otherwise = (empty,empty)++  in vcat+    [ -- section directive. Requires proc_lbl when split-section is enabled to+      -- use as a subsection name.+      pprSectionAlign config (Section Text proc_lbl)++      -- section alignment. Note that when there is an info table, we align the+      -- info table and not the entry code!+    , pprProcAlignment config++      -- Special label when ncgExposeInternalSymbols is enabled. See Note+      -- [Internal proc labels] in GHC.Cmm.Label+    , pprExposedInternalProcLabel config entry_lbl++      -- Subsections-via-symbols label. See Note [Subsections Via Symbols]+    , sub_via_sym_label++      -- We need to print a label indicating the beginning of the entry code:+      -- 1. Without tables-next-to-code, we just print it here+      -- 2. With tables-next-to-code, the proc_lbl is the info-table label and it+      -- will be printed in pprBasicBlock after the info-table itself.+    , case top_info_table of+        Nothing -> pprLabel platform proc_lbl+        Just _  -> empty++      -- Proc's basic blocks+    , vcat (map (pprBasicBlock config top_info) blocks)+      -- Note that even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.++      -- Print the proc end label when debugging is enabled+    , ppWhen (ncgDwarfEnabled config) $ line (pprProcEndLabel platform proc_lbl)++      -- Subsections-via-symbols offset. See Note [Subsections Via Symbols]+    , sub_via_sym_offset++      -- ELF .size directive (size of the entry code function)+    , pprSizeDecl platform proc_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.+pprExposedInternalProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc+pprExposedInternalProcLabel 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 block_label $$+    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 block_label) $$+      line (pprProcEndLabel platform block_label)+    )+  where+    block_label = 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 (pprBlockEndLabel platform infoLbl))++    -- 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 (VirtualRegD    u) -> text "%vD_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegV128 u) -> text "%vV128_" <> 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 fmt   = ppr32_reg_long fmt++    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 fmt 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 fmt 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 fmt   = ppr64_reg_quad fmt++    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 fmt 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 fmt i+      }++ppr_reg_float :: IsLine doc => Format -> Int -> doc+ppr_reg_float fmt i+  | W256 <- size+  = case i of+        16 -> text "%ymm0" ;   17 -> text "%ymm1"+        18 -> text "%ymm2" ;   19 -> text "%ymm3"+        20 -> text "%ymm4" ;   21 -> text "%ymm5"+        22 -> text "%ymm6" ;   23 -> text "%ymm7"+        24 -> text "%ymm8" ;   25 -> text "%ymm9"+        26 -> text "%ymm10";   27 -> text "%ymm11"+        28 -> text "%ymm12";   29 -> text "%ymm13"+        30 -> text "%ymm14";   31 -> text "%ymm15"+        _  -> text "very naughty x86 register"+  | W512 <- size+  = case i of+        16 -> text "%zmm0" ;   17 -> text "%zmm1"+        18 -> text "%zmm2" ;   19 -> text "%zmm3"+        20 -> text "%zmm4" ;   21 -> text "%zmm5"+        22 -> text "%zmm6" ;   23 -> text "%zmm7"+        24 -> text "%zmm8" ;   25 -> text "%zmm9"+        26 -> text "%zmm10";   27 -> text "%zmm11"+        28 -> text "%zmm12";   29 -> text "%zmm13"+        30 -> text "%zmm14";   31 -> text "%zmm15"+        _  -> text "very naughty x86 register"+  | otherwise+  = 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"+  where size = formatToWidth fmt++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)+  VecFormat _ FmtFloat  -> text "ps"+  VecFormat _ FmtDouble -> text "pd"+  -- TODO: this is shady because it only works for certain instructions+  VecFormat _ FmtInt8   -> text "b"+  VecFormat _ FmtInt16  -> text "w"+  VecFormat _ FmtInt32  -> text "d"+  VecFormat _ FmtInt64  -> text "q"++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 :: forall doc. IsDoc doc => NCGConfig -> CmmLit -> doc+pprDataItem config lit =+  let (itemFmt, items) = itemFormatAndItems (cmmTypeFormat $ cmmLitType platform lit)+  in line $ itemFmt <> hsep (punctuate comma (items lit))+    where+        platform = ncgPlatform config++        pprLitImm, pprII64AsII32x2 :: CmmLit -> [Line doc]+        pprLitImm = (:[]) . pprImm platform . litToImm+        pprII64AsII32x2 (CmmInt x _)+          = [ int (fromIntegral (fromIntegral x :: Word32))+            , int (fromIntegral (fromIntegral (x `shiftR` 32) :: Word32)) ]+        pprII64AsII32x2 x+          = pprPanic "X86 pprDataItem II64" (ppr x)++        itemFormatAndItems :: Format -> (Line doc, CmmLit -> [Line doc])+        itemFormatAndItems = \case+          II8  -> ( text "\t.byte\t", pprLitImm )+          II16 -> ( text "\t.word\t", pprLitImm )+          II32 -> ( text "\t.long\t", pprLitImm )+          II64 ->+            case platformOS platform of+              OSDarwin+                | target32Bit platform+                -> ( text "\t.long\t", pprII64AsII32x2 )+              _ -> ( text "\t.quad\t", pprLitImm )+          FF32 -> ( text "\t.float\t", pprLitImm )+          FF64 -> ( text "\t.double\t", pprLitImm )+          VecFormat _ sFmt ->+            let (fmtTxt, pprElt) = itemFormatAndItems (scalarFormatFormat sFmt)+            in (fmtTxt, \ case { CmmVec elts -> pprElt =<< elts+                               ; x -> pprPanic "X86 pprDataItem VecFormat" (ppr x)+                               })++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 fmt src dst+     -> pprFormatOpOp (text "mov") fmt' src dst+       where+          fmt' = case fmt of+            VecFormat _l sFmt -> scalarFormatFormat sFmt+            _ -> fmt++   CMOV cc format src dst+     -> pprCondOpReg (text "cmov") format cc src dst++   MOVD format1 format2 src dst+     -> pprMovdOpOp (text "mov") format1 format2 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@(VecFormat _ sfmt) src dst | isIntScalarFormat sfmt+       -> pprOpOp (text "pxor") format src dst++   XOR format src dst+      -> pprFormatOpOp (text "xor") format src dst++   VXOR fmt src1 src2 dst+      -> pprVxor fmt src1 src2 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++   SHLD format src dst1 dst2+      -> pprShift2 (text "shld") format src dst1 dst2++   SHRD format src dst1 dst2+      -> pprShift2 (text "shrd") format src dst1 dst2++   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+      -> pprFormatOpReg (text "div") format op1 op2++   FMA3 format var perm op1 op2 op3+      -> let mnemo = case var of+               FMAdd  -> text "vfmadd"+               FMSub  -> text "vfmsub"+               FNMAdd -> text "vfnmadd"+               FNMSub -> text "vfnmsub"+         in pprFormatOpRegReg (mnemo <> pprFMAPermutation perm) format op1 op2 op3++   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++   -- Vector Instructions+   VADD format s1 s2 dst+     -> pprFormatOpRegReg (text "vadd") format s1 s2 dst+   VSUB format s1 s2 dst+     -> pprFormatOpRegReg (text "vsub") format s1 s2 dst+   VMUL format s1 s2 dst+     -> pprFormatOpRegReg (text "vmul") format s1 s2 dst+   VDIV format s1 s2 dst+     -> pprFormatOpRegReg (text "vdiv") format s1 s2 dst+   PADD format src dst+     -> pprFormatOpReg (text "padd") format src dst+   PSUB format src dst+     -> pprFormatOpReg (text "psub") format src dst+   PMULL format src dst+     -> pprFormatOpReg (text "pmull") format src dst+   PMULUDQ format src dst+     -> pprOpReg (text "pmuludq") format src dst+   PCMPGT format src dst+     -> pprFormatOpReg (text "pcmpgt") format src dst+   VBROADCAST format@(VecFormat _ sFmt) from to+     -> pprBroadcast (text "vbroadcast") (scalarFormatFormat sFmt) format from to+   VBROADCAST format _ _+     -> pprPanic "VBROADCAST: expected vector format" (ppr format)+   VPBROADCAST scalarFormat format from to+     -> pprBroadcast (text "vpbroadcast") scalarFormat format from to+   VMOVU format from to+     -> pprFormatOpOp (text "vmovu") format from to+   MOVU format from to+     -> pprFormatOpOp (text "movu") format from to+   MOVL format from to+     -> pprFormatOpOp (text "movl") format from to+   MOVH format from to+     -> pprFormatOpOp (text "movh") format from to++   MOVDQU  format from to+     -> pprOpOp (text "movdqu") format from to+   VMOVDQU format from to+     -> pprOpOp vmovdqu_op format from to+     where+      vmovdqu_op = case format of+        VecFormat 8  FmtInt64 -> text "vmovdqu64"+        VecFormat 16 FmtInt32 -> text "vmovdqu32"+        VecFormat 32 FmtInt16 -> text "vmovdqu32" -- NB: not using vmovdqu16/8, as they+        VecFormat 64 FmtInt8  -> text "vmovdqu32" -- require the additional AVX512BW extension+        _ -> text "vmovdqu"+   VMOV_MERGE format src2 src1 dst+     -> pprRegRegReg instr format src2 src1 dst+     where instr = case format of+             VecFormat _ FmtFloat -> text "vmovss"+             VecFormat _ FmtDouble -> text "vmovsd"+             _ -> pprPanic "invalid format for VMOV_MERGE" (ppr format)++   PXOR format src dst+     -> pprPXor (text "pxor") format src dst+   VPXOR format s1 s2 dst+     -> pprXor (text "vpxor") format s1 s2 dst+   PAND format src dst+     -> pprOpReg (text "pand") format src dst+   PANDN format src dst+     -> pprOpReg (text "pandn") format src dst+   POR format src dst+     -> pprOpReg (text "por") format src dst+   VEXTRACT format offset from to+     -> pprFormatImmRegOp (text "vextract") format offset from to+   INSERTPS format offset addr dst+     -> pprInsert (text "insertps") format offset addr dst+   VINSERTPS format offset src2 src1 dst+     -> pprImmOpRegReg (text "vinsertps") format offset src2 src1 dst+   PINSR scalarFormat vectorFormat offset src dst+     -> pprPinsr (text "pinsr") scalarFormat vectorFormat offset src dst+   PEXTR scalarFormat vectorFormat offset src dst+     -> pprPextr (text "pextr") scalarFormat vectorFormat offset src dst++   SHUF format offset src dst+     -> pprShuf (text "shuf" <> pprFormat format) format offset src dst+   VSHUF format offset src1 src2 dst+     -> pprVShuf (text "vshuf" <> pprFormat format) format offset src1 src2 dst+   PSHUFB format mask dst+     -> pprOpReg (text "pshufb") format mask dst+   PSHUFLW format offset src dst+     -> pprShuf (text "pshuflw") format offset src dst+   PSHUFHW format offset src dst+     -> pprShuf (text "pshufhw") format offset src dst+   PSHUFD format offset src dst+     -> pprShuf (text "pshufd") format offset src dst+   VPSHUFD format offset src dst+     -> pprShuf (text "vpshufd") format offset src dst+   BLEND format mask src dst+     -> pprFormatImmOpReg (text "blend") format mask src dst+   VBLEND format mask src2 src1 dst+     -> pprFormatImmOpRegReg (text "vblend") format mask src2 src1 dst+   PBLENDW format mask src dst+     -> pprShuf (text "pblendw") format mask src dst++   PSLL format offset dst+     -> pprFormatOpReg (text "psll") format offset dst+   PSLLDQ format offset dst+     -> pprDoubleShift (text "pslldq") format offset dst+   PSRL format offset dst+     -> pprFormatOpReg (text "psrl") format offset dst+   PSRLDQ format offset dst+     -> pprDoubleShift (text "psrldq") format offset dst+   PALIGNR format offset src dst+     -> pprImmOpReg (text "palignr") format offset src dst++   MOVHLPS format from to+     -> pprOpReg (text "movhlps") format (OpReg from) to+   VMOVHLPS format src2 src1 dst+     -> pprRegRegReg (text "vmovhlps") format src2 src1 dst+   MOVLHPS format from to+     -> pprOpReg (text "movlhps") format (OpReg from) to+   VMOVLHPS format src2 src1 dst+     -> pprRegRegReg (text "vmovlhps") format src2 src1 dst+   UNPCKL format src dst+     -> pprFormatOpReg (text "unpckl") format src dst+   VUNPCKL format src2 src1 dst+     -> pprFormatOpRegReg (text "vunpckl") format src2 src1 dst+   UNPCKH format src dst+     -> pprFormatOpReg (text "unpckh") format src dst+   VUNPCKH format src2 src1 dst+     -> pprFormatOpRegReg (text "vunpckh") format src2 src1 dst+   PUNPCKLQDQ format from to+     -> pprOpReg (text "punpcklqdq") format from to+   PUNPCKLDQ format from to+     -> pprOpReg (text "punpckldq") format from to+   PUNPCKLWD format from to+     -> pprOpReg (text "punpcklwd") format from to+   PUNPCKLBW format from to+     -> pprOpReg (text "punpcklbw") format from to+   PUNPCKHQDQ format from to+     -> pprOpReg (text "punpckhqdq") format from to+   PUNPCKHDQ format from to+     -> pprOpReg (text "punpckhdq") format from to+   PUNPCKHWD format from to+     -> pprOpReg (text "punpckhwd") format from to+   PUNPCKHBW format from to+     -> pprOpReg (text "punpckhbw") format from to+   PACKUSWB format from to+     -> pprOpReg (text "packuswb") format from to++   MINMAX minMax ty fmt src dst+     -> pprMinMax False minMax ty fmt [src, OpReg dst]+   VMINMAX minMax ty fmt src1 src2 dst+     -> pprMinMax True minMax ty fmt [src1, OpReg src2, OpReg 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+++   pprGenMnemonic  :: Line doc -> Format -> Line doc+   pprGenMnemonic name _ =+      char '\t' <> name <> text "" <> space++   pprBroadcastMnemonic  :: Line doc -> Format -> Line doc+   pprBroadcastMnemonic name format =+      char '\t' <> name <> pprBroadcastFormat format <> space++   pprBroadcastFormat :: Format -> Line doc+   pprBroadcastFormat (VecFormat _ f)+     = case f of+         FmtFloat  -> text "ss"+         FmtDouble -> text "sd"+         FmtInt8   -> text "b"+         FmtInt16  -> text "w"+         FmtInt32  -> text "d"+         FmtInt64  -> text "q"+   pprBroadcastFormat _ = panic "Scalar Format invading vector operation"++   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+       ]++   pprMovdOpOp :: Line doc -> Format -> Format -> Operand -> Operand -> doc+   pprMovdOpOp name format1 format2 op1 op2+     = let instr = case (format1, format2) of+             -- bitcasts to/from a general purpose register to a floating point+             -- register require II32 or II64.+             (II32, _) -> text "d"+             (II64, _) -> text "q"+             (_, II32) -> text "d"+             (_, II64) -> text "q"+             _ -> panic "X86.Ppr.pprMovdOpOp: improper format for movd/movq."+       in line $ hcat [+           char '\t' <> name <> instr <> space,+           pprOperand platform format1 op1,+           comma,+           pprOperand platform format2 op2+           ]++   pprFormatImmRegOp :: Line doc -> Format -> Imm -> Reg -> Operand -> doc+   pprFormatImmRegOp name format off reg1 op2+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm off,+           comma,+           pprReg platform format reg1,+           comma,+           pprOperand platform format op2+       ]++   pprFormatOpRegReg :: Line doc -> Format -> Operand -> Reg -> Reg -> doc+   pprFormatOpRegReg name format op1 reg2 reg3+     = line $ hcat [+           pprMnemonic name format,+           pprOperand platform format op1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]++   pprFMAPermutation :: FMAPermutation -> Line doc+   pprFMAPermutation FMA132 = text "132"+   pprFMAPermutation FMA213 = text "213"+   pprFMAPermutation FMA231 = text "231"++   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+       ]++   pprRegRegReg :: Line doc -> Format -> Reg -> Reg -> Reg -> doc+   pprRegRegReg name format reg1 reg2 reg3+     = line $ hcat [+           pprMnemonic_ name,+           pprReg platform format reg1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]++   pprOpReg :: Line doc -> Format -> Operand -> Reg -> doc+   pprOpReg name format op reg+     = line $ hcat [+           pprMnemonic_ name,+           pprOperand platform format op,+           comma,+           pprReg platform (archWordFormat (target32Bit platform)) reg+       ]+++   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+       ]++   pprShift2 :: Line doc -> Format -> Operand -> Operand -> Operand -> doc+   pprShift2 name format src dest1 dest2+     = line $ hcat [+           pprMnemonic name format,+           pprOperand platform II8 src,  -- src is 8-bit sized+           comma,+           pprOperand platform format dest1,+           comma,+           pprOperand platform format dest2+       ]+++   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]++   -- Custom pretty printers+   -- These instructions currently don't follow a uniform suffix pattern+   -- in their names, so we have custom pretty printers for them.+   pprBroadcast :: Line doc -> Format -> Format -> Operand -> Reg -> doc+   pprBroadcast name scalarFormat vectorFormat op dst+     = line $ hcat [+           pprBroadcastMnemonic name vectorFormat,+           pprOperand platform scalarFormat op,+           comma,+           pprReg platform vectorFormat dst+       ]++   pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc+   pprXor name format reg1 reg2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprReg platform format reg1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]++   pprPXor :: Line doc -> Format -> Operand -> Reg -> doc+   pprPXor name format src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprVxor :: Format -> Operand -> Reg -> Reg -> doc+   pprVxor fmt src1 src2 dst+     = line $ hcat [+           pprGenMnemonic mem fmt,+           pprOperand platform fmt src1,+           comma,+           pprReg platform fmt src2,+           comma,+           pprReg platform fmt dst+       ]+     where+      mem = case fmt of+        FF32 -> text "vxorps"+        FF64 -> text "vxorpd"+        VecFormat _ FmtFloat -> text "vxorps"+        VecFormat _ FmtDouble -> text "vxorpd"+        _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVxor: element type must be Float or Double"+              (ppr fmt)++   pprInsert :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprInsert name format off src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm off,+           comma,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprPinsr :: Line doc -> Format -> Format -> Imm -> Operand -> Reg -> doc+   pprPinsr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprOperand platform scalarFormat src,+           comma,+           pprReg platform vectorFormat dst+       ]++   pprPextr :: Line doc -> Format -> Format -> Imm -> Reg -> Operand -> doc+   pprPextr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprReg platform vectorFormat src,+           comma,+           pprOperand platform scalarFormat dst+       ]++   pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprShuf name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprVShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprVShuf name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprDoubleShift :: Line doc -> Format -> Imm -> Reg -> doc+   pprDoubleShift name format off reg+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm off,+           comma,+           pprReg platform format reg+       ]++   pprImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprFormatImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprFormatImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprFormatImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprFormatImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc+   pprMinMax wantV minOrMax mmTy fmt regs+     = line $ hcat ( instr : intersperse comma ( map ( pprOperand platform fmt ) regs ) )+      where+        instr =  (if wantV then text "v" else empty)+              <> (case mmTy of { IntVecMinMax {} -> text "p"; FloatMinMax -> empty })+              <> (case minOrMax of { Min -> text "min"; Max -> text "max" })+              <> (case mmTy of { IntVecMinMax wantSigned -> if wantSigned then text "s" else text "u"; FloatMinMax -> empty })+              <> pprFormat fmt+              <> space
+ GHC/CmmToAsm/X86/RegInfo.hs view
@@ -0,0 +1,70 @@++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+        -- On X86, we pass 32-bit floats in the same registers as 64-bit floats.+        FF64    -> VirtualRegD u+        -- SIMD NCG TODO: add support for 256 and 512-wide vectors.+        VecFormat {} -> VirtualRegV128 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"]+
+ GHC/CmmToAsm/X86/Regs.hs view
@@ -0,0 +1,409 @@+++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,++        -- 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,+        intregnos, xmmregnos,++        ripRel,+        allFPArgRegs,++        allocatableRegs+)++where++import GHC.Prelude+import GHC.Data.FastString++import GHC.Platform.Regs+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Unified++import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.Utils.Panic+import GHC.Platform++-- | 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++        RcFloatOrVector+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegV128{}        -> 1+                _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++        RcFloatOrVector+         -> case rr of+                RealRegSingle regNo+                        | regNo >= firstxmm  -> 1+                        | otherwise     -> 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 -> RcFloatOrVector+            | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"++-- 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 support Float, Doubles and vectors of those, as well+as vectors of integer values.+-}+++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)+
+ GHC/CmmToC.hs view
@@ -0,0 +1,1593 @@+{-# 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.Graph+import GHC.Cmm.Dataflow.Label+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)+                | CmmNeverReturns <- ret ->+                    pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"+                | not (isLibcFun 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 (PrimTarget MO_ReleaseFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_RELEASE);"+    CmmUnsafeForeignCall (PrimTarget MO_AcquireFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_ACQUIRE);"+    CmmUnsafeForeignCall (PrimTarget MO_SeqCstFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_SEQ_CST);"++    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    -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w]+      where w = cmmRegWidth reg++    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 (MO_RelaxedRead w) [x]+  = pprExpr platform (CmmLoad x (cmmBits w) NaturallyAligned)++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++    -- ternary+    args@[_,_,_] ->+      let (_fixity, op) = pprMachOp_for_C platform mop+      in op <> parens (pprWithCommas pprArg args)++    -- dyadic+    args@[x,y] ->+      let (fixity, op) = pprMachOp_for_C platform mop+      in case fixity of+            Infix -> pprArg x <+> op <+> pprArg y+            Prefix -> op <> parens (pprWithCommas pprArg args)++    -- unary+    [x]   ->+      let (_fixity, op) = pprMachOp_for_C platform mop+      in op <> 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.+--++data Fixity = Prefix | Infix+  deriving ( Eq, Show )++pprMachOp_for_C :: Platform -> MachOp -> (Fixity, SDoc)++pprMachOp_for_C platform mop = case mop of++        -- Integer operations+        MO_Add          _ -> (Infix, char '+')+        MO_Sub          _ -> (Infix, char '-')+        MO_Eq           _ -> (Infix, text "==")+        MO_Ne           _ -> (Infix, text "!=")+        MO_Mul          _ -> (Infix, char '*')++        MO_S_Quot       _ -> (Infix, char '/')+        MO_S_Rem        _ -> (Infix, char '%')+        MO_S_Neg        _ -> (Infix, char '-')++        MO_U_Quot       _ -> (Infix, char '/')+        MO_U_Rem        _ -> (Infix, char '%')++        -- Floating-point operations+        MO_F_Add        _ -> (Infix, char '+')+        MO_F_Sub        _ -> (Infix, char '-')+        MO_F_Neg        _ -> (Infix, char '-')+        MO_F_Mul        _ -> (Infix, char '*')+        MO_F_Quot       _ -> (Infix, char '/')+        MO_F_Min        _ -> (Prefix, text "fmin")+        MO_F_Max        _ -> (Prefix, text "fmax")++        -- Floating-point fused multiply-add operations+        MO_FMA FMAdd 1 w ->+          case w of+            W32 -> (Prefix, text "fmaf")+            W64 -> (Prefix, text "fma")+            _   ->+              pprTrace "offending mop:"+                (text "FMAdd")+                (panic $ "PprC.pprMachOp_for_C: FMAdd unsupported"+                       ++ "at width " ++ show w)+        MO_FMA var l width+          | l == 1+          -> pprTrace "offending mop:"+              (text $ "FMA " ++ show var)+              (panic $ "PprC.pprMachOp_for_C: should have been handled earlier!")+          | otherwise+          -> pprTrace "offending mop:"+              (text $ "FMA " ++ show var ++ " " ++ show l ++ " " ++ show width)+              (panic $ "PprC.pprMachOp_for_C: unsupported vector operation")++        -- Signed comparisons+        MO_S_Ge         _ -> (Infix, text ">=")+        MO_S_Le         _ -> (Infix, text "<=")+        MO_S_Gt         _ -> (Infix, char '>')+        MO_S_Lt         _ -> (Infix, char '<')++        -- & Unsigned comparisons+        MO_U_Ge         _ -> (Infix, text ">=")+        MO_U_Le         _ -> (Infix, text "<=")+        MO_U_Gt         _ -> (Infix, char '>')+        MO_U_Lt         _ -> (Infix, char '<')++        -- & Floating-point comparisons+        MO_F_Eq         _ -> (Infix, text "==")+        MO_F_Ne         _ -> (Infix, text "!=")+        MO_F_Ge         _ -> (Infix, text ">=")+        MO_F_Le         _ -> (Infix, text "<=")+        MO_F_Gt         _ -> (Infix, char '>')+        MO_F_Lt         _ -> (Infix, char '<')++        -- Bitwise operations.  Not all of these may be supported at all+        -- sizes, and only integral MachReps are valid.+        MO_And          _ -> (Infix, char '&')+        MO_Or           _ -> (Infix, char '|')+        MO_Xor          _ -> (Infix, char '^')+        MO_Not          _ -> (Infix, char '~')+        MO_Shl          _ -> (Infix, text "<<")+        MO_U_Shr        _ -> (Infix, text ">>") -- unsigned shift right+        MO_S_Shr        _ -> (Infix, 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++-- bitcasts, in the C backend these are performed with __builtin_memcpy.+-- See rts/include/stg/Prim.h++        MO_FW_Bitcast W32 -> (Prefix, text "hs_bitcastfloat2word")+        MO_FW_Bitcast W64 -> (Prefix, text "hs_bitcastdouble2word64")++        MO_WF_Bitcast W32 -> (Prefix, text "hs_bitcastword2float")+        MO_WF_Bitcast W64 -> (Prefix, text "hs_bitcastword642double")++        MO_FW_Bitcast w -> pprTrace "offending mop:"+                                (text "MO_FW_Bitcast")+                                (panic $ "PprC.pprMachOp_for_C: MO_FW_Bitcast"+                                      ++ " called with improper width!"+                                      ++ show w)++        MO_WF_Bitcast w -> pprTrace "offending mop:"+                                (text "MO_WF_Bitcast")+                                (panic $ "PprC.pprMachOp_for_C: MO_WF_Bitcast"+                                      ++ " called with improper width!"+                                      ++ show w)+++-- noop casts+        MO_UU_Conv from to | from == to -> (Prefix, empty)+        MO_UU_Conv _from to -> (Prefix, parens (machRep_U_CType platform to))++        MO_SS_Conv from to | from == to -> (Prefix, empty)+        MO_SS_Conv _from to -> (Prefix, parens (machRep_S_CType platform to))++        MO_XX_Conv from to | from == to -> (Prefix, empty)+        MO_XX_Conv _from to -> (Prefix,parens (machRep_U_CType platform to))++        MO_FF_Conv from to | from == to -> (Prefix, empty)+        MO_FF_Conv _from to -> (Prefix,parens (machRep_F_CType to))++        MO_SF_Round    _from to -> (Prefix,parens (machRep_F_CType to))+        MO_FS_Truncate _from to -> (Prefix,parens (machRep_S_CType platform to))++        MO_RelaxedRead _ -> pprTrace "offending mop:"+                                (text "MO_RelaxedRead")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")++        MO_S_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_S_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")++        MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend"++-- SIMD vector instructions: currently unsupported+        MO_V_Shuffle {} -> pprTrace "offending mop:"+                                (text "MO_V_Shuffle")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Shuffle"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Shuffle {} -> pprTrace "offending mop:"+                                (text "MO_VF_Shuffle")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Shuffle"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Insert {}    -> pprTrace "offending mop:"+                                (text "MO_V_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Extract {}   -> pprTrace "offending mop:"+                                (text "MO_V_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Add {}       -> pprTrace "offending mop:"+                                (text "MO_V_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Sub {}       -> pprTrace "offending mop:"+                                (text "MO_V_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Mul {}       -> pprTrace "offending mop:"+                                (text "MO_V_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"+                                      ++ "unsupported by the unregisterised backend")+        MO_VS_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"+                                      ++ "unsupported by the unregisterised backend")+        MO_V_Broadcast {} -> pprTrace "offending mop:"+                                 (text "MO_V_Broadcast")+                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Broadcast"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Broadcast {} -> pprTrace "offending mop:"+                                 (text "MO_VF_Broadcast")+                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Broadcast"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Insert {}   -> pprTrace "offending mop:"+                                (text "MO_VF_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Extract {}  -> pprTrace "offending mop:"+                                (text "MO_VF_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Add {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Sub {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Mul {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VF_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"+                                      ++ "unsupported by the unregisterised backend")+        MO_VU_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VU_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Max"+                                      ++ "unsupported by the unregisterised backend")+        MO_VS_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VS_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Max"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Min {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Min")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Min"+                                      ++ "unsupported by the unregisterised backend")+        MO_VF_Max {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Max")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Max"+                                      ++ "unsupported by the 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_Round _ _) = 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_AcquireFence -> unsupported+        MO_ReleaseFence -> unsupported+        MO_SeqCstFence  -> unsupported+        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)+        -- TODO: handle orderings+        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_VS_Quot    {} -> unsupported+        MO_VS_Rem     {} -> unsupported+        MO_VU_Quot    {} -> unsupported+        MO_VU_Rem     {} -> unsupported+        MO_I64X2_Min     -> unsupported+        MO_I64X2_Max     -> unsupported+        MO_W64X2_Min     -> unsupported+        MO_W64X2_Max     -> 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 =+            case r1 of+              CmmGlobal (GlobalRegUse BaseReg _) ->+                text "ASSIGN_BaseReg" <> parens x <> semi+              _ -> 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 (GlobalRegUse 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 (GlobalRegUse (VanillaReg _) ty)) = isGcPtrType ty -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal (GlobalRegUse 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 (GlobalRegUse 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 (GlobalRegUse CCCS _)) = Just (text "struct CostCentreStack_ *")+strangeRegType (CmmGlobal (GlobalRegUse CurrentTSO _)) = Just (text "struct StgTSO_ *")+strangeRegType (CmmGlobal (GlobalRegUse CurrentNursery _)) = Just (text "struct bdescr_ *")+strangeRegType (CmmGlobal (GlobalRegUse 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 (GlobalRegUse global _ ) -> pprGlobalReg global++pprAsPtrReg :: CmmReg -> SDoc+pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg n) ty))+  = warnPprTrace (not $ isGcPtrType ty) "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+  | 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'++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__((" <> text attribute <> text "))"+    <> text "void _hs_" <> text suffix <> text "()"+    <> braces body+  where+    body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]+    (attribute, suffix) = case initOrFini of+                  IsInitArray+                    -- See Note [JSFFI initialization] for details+                    | ArchWasm32 <- platformArch platform -> ("constructor(101)", "constructor")+                    | otherwise -> ("constructor", "constructor")+                  IsFiniArray -> ("destructor", "destructor")
+ GHC/CmmToLlvm.hs view
@@ -0,0 +1,289 @@+{-# 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++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.CmmToLlvm.Version++import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream )+import GHC.Cmm+import GHC.Cmm.Dataflow.Label++import GHC.Types.Unique.DSM+import GHC.Utils.BufHandle+import GHC.Driver.DynFlags+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.Maybe ( fromMaybe, catMaybes, isNothing )+import System.IO++-- -----------------------------------------------------------------------------+-- | Top-level of the LLVM Code generator+--+llvmCodeGen :: Logger -> LlvmCgConfig -> Handle+            -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream.+                           -- See Note [Deterministic Uniques in the CG]+            -> CgStream RawCmmGroup a+            -> IO a+llvmCodeGen logger cfg h dus 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..."++       when (isNothing mb_ver) $ do+         let doWarn = llvmCgDoWarn cfg+         when doWarn $ putMsg logger $+           "Failed to detect LLVM version!" $$+           "Make sure LLVM is installed correctly." $$+           "We will try though..."++       -- 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 dus $+         llvmCodeGen' cfg cmm_stream++       bFlush bufh++       return a++llvmCodeGen' :: LlvmCgConfig+             -> CgStream RawCmmGroup a -> LlvmM a+llvmCodeGen' cfg cmm_stream+  = do  -- Preamble+        renderLlvm (llvmHeader cfg) (llvmHeader cfg)+        ghcInternalFunctions+        cmmMetaLlvmPrelude++        -- Procedures+        a <- Stream.consume cmm_stream (GHC.CmmToLlvm.Base.liftUDSMT) (llvmGroupLlvmGens)++        -- Declare aliases for forward references+        decls <- generateExternDecls+        renderLlvm (pprLlvmData cfg decls)+                   (pprLlvmData cfg decls)++        -- Postamble+        cmmUsedLlvmGens++        return a++llvmHeader :: IsDoc doc => LlvmCgConfig -> doc+llvmHeader cfg =+  let target  = llvmCgLlvmTarget cfg+      llvmCfg = llvmCgLlvmConfig cfg+  in lines_+      [ text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\""+      , text "target triple = \"" <> text target <> text "\"" ]+  where+    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)+{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> SDoc #-}+{-# SPECIALIZE llvmHeader :: LlvmCgConfig -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++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))+                  (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 - print as we go, since we produce HDocs, we know+    -- no nesting state needs to be maintained for the SDocs.+    forM_ llvmBC (\decl -> do+        (hdoc, sdoc) <- pprLlvmCmmDecl decl+        renderLlvm (hdoc $$ empty) (sdoc $$ empty)+      )++cmmLlvmGen _ = return ()++-- -----------------------------------------------------------------------------+-- | Generate meta data nodes+--++cmmMetaLlvmPrelude :: LlvmM ()+cmmMetaLlvmPrelude = do+  tbaa_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 ]++  platform <- getPlatform+  cfg <- getConfig+  let stack_alignment_metas =+          case platformArch platform of+            ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32]+            _                                 -> []+  let codel_model_metas =+          case platformArch platform of+            -- FIXME: We should not rely on LLVM+            ArchLoongArch64 -> [mkCodeModelMeta CMMedium]+            _                                 -> []+  module_flags_metas <- mkModuleFlagsMeta (stack_alignment_metas ++ codel_model_metas)+  let metas = tbaa_metas ++ module_flags_metas+  cfg <- getConfig+  renderLlvm (ppLlvmMetas cfg metas)+             (ppLlvmMetas cfg metas)++mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl]+mkNamedMeta name exprs = do+    (ids, decls) <- unzip <$> mapM f exprs+    return $ decls ++ [MetaNamed name ids]+  where+    f expr = do+      i <- getMetaUniqueId+      return (i, MetaUnnamed i expr)++mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl]+mkModuleFlagsMeta =+    mkNamedMeta "llvm.module.flags" . map moduleFlagToMetaExpr++mkStackAlignmentMeta :: Integer -> ModuleFlag+mkStackAlignmentMeta alignment =+    ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32)++-- LLVM's @LLVM::CodeModel::Model@ enumeration+data CodeModel = CMMedium++-- Pass -mcmodel=medium option to LLVM on LoongArch64+mkCodeModelMeta :: CodeModel -> ModuleFlag+mkCodeModelMeta codemodel =+    ModuleFlag MFBError "Code Model" (MetaLit $ LMIntLit n i32)+  where+    n = case codemodel of CMMedium -> 3 -- as of LLVM 8++-- -----------------------------------------------------------------------------+-- | 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 do+      cfg <- getConfig+      renderLlvm (pprLlvmData cfg ([lmUsed], []))+                 (pprLlvmData cfg ([lmUsed], []))
+ GHC/CmmToLlvm/Base.hs view
@@ -0,0 +1,637 @@+{-# 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, LiveGlobalRegUses,+        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, liftUDSMT,++        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,+        llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,++        lookupRegUse,++        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.CmmToLlvm.Version++import GHC.Cmm.CLabel+import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )+import GHC.Driver.DynFlags+import GHC.Data.FastString+import GHC.Cmm              hiding ( succ )+import GHC.Cmm.Utils (globalRegsOverlap)+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 qualified GHC.Types.Unique.DSM as DSM+import GHC.Utils.Logger++import Control.Monad.Trans.State (StateT (..))+import Control.Applicative (Alternative((<|>)))+import Data.Maybe (fromJust, mapMaybe)++import Data.List (find, isPrefixOf)+import qualified Data.List.NonEmpty as NE+import Data.Ord (comparing)+import qualified Control.Monad.IO.Class as IO++-- ----------------------------------------------------------------------------+-- * Some Data Types+--++type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)+type LlvmBasicBlock = GenBasicBlock LlvmStatement++-- | Global registers live on proc entry+type LiveGlobalRegs = [GlobalReg]+type LiveGlobalRegUses = [GlobalRegUse]++-- | 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 :: LiveGlobalRegUses -> LlvmM LlvmType+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible++-- | Llvm Function signature+llvmFunSig :: LiveGlobalRegUses ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig live lbl link = do+  lbl' <- strCLabel_llvm lbl+  llvmFunSig' live lbl' link++llvmFunSig' :: LiveGlobalRegUses -> 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 -> LiveGlobalRegUses -> [LlvmVar]+llvmFunArgs platform live =+    map (lmGlobalRegArg platform) (mapMaybe isPassed allRegs)+    where allRegs = activeStgRegs platform+          paddingRegs = padLiveArgs platform live+          isLive :: GlobalReg -> Maybe GlobalRegUse+          isLive r =+            lookupRegUse r (alwaysLive platform)+              <|>+            lookupRegUse r live+              <|>+            lookupRegUse r paddingRegs+          isPassed r =+            if not (isFPR r)+            then Just $ GlobalRegUse r (globalRegSpillType platform r)+            else isLive r++lookupRegUse :: GlobalReg -> [GlobalRegUse] -> Maybe GlobalRegUse+lookupRegUse r = find ((== r) . globalRegUse_reg)++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 -> LiveGlobalRegUses -> LiveGlobalRegUses+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 . globalRegUse_reg) 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 = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers+    norm x = globalRegUse_reg (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 :: [GlobalRegUse]+    padded      = concatMap padClass classes++    padClass :: NE.NonEmpty GlobalRegUse -> [GlobalRegUse]+    padClass rs = go (NE.toList sortedRs) 1+      where+         sortedRs = NE.sortBy (comparing (fpr_num . globalRegUse_reg)) rs+         maxr     = NE.last sortedRs+         ctor     = fpr_ctor maxr++         go [] _ = []+         go (GlobalRegUse c1 _: GlobalRegUse 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 (cu@(GlobalRegUse c _):cs) f+            | fpr_num c == f = go cs (f+1)                 -- already covered by a real register+            | otherwise      = ctor f : go (cu:cs) (f + 1) -- add padding register++    fpr_ctor :: GlobalRegUse -> Int -> GlobalRegUse+    fpr_ctor (GlobalRegUse r fmt) i =+      case r of+        FloatReg _  -> GlobalRegUse (FloatReg  i) fmt+        DoubleReg _ -> GlobalRegUse (DoubleReg i) fmt+        XmmReg _    -> GlobalRegUse (XmmReg    i) fmt+        YmmReg _    -> GlobalRegUse (YmmReg    i) fmt+        ZmmReg _    -> GlobalRegUse (ZmmReg    i) fmt+        _           -> 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+  , envTag       :: !Char            -- ^ Tag 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 :: [GlobalRegUse]   -- ^ 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 -> DSM.UniqDSMT IO (a, LlvmEnv) }+    deriving stock (Functor)+    deriving (Applicative, Monad) via StateT LlvmEnv (DSM.UniqDSMT 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)+++-- This instance uses a deterministic unique supply from UniqDSMT, so new+-- uniques within LlvmM will be sampled deterministically.+instance DSM.MonadGetUnique LlvmM where+  getUniqueM = do+    tag <- getEnv envTag+    liftUDSMT $! do+      uq <- DSM.getUniqueM+      return (newTagUnique uq tag)++-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.+liftIO :: IO a -> LlvmM a+liftIO m = LlvmM $ \env -> do x <- IO.liftIO m+                              return (x, env)++-- | Lifting of UniqDSMT actions. Gives access to the deterministic unique supply being threaded through by LlvmM.+liftUDSMT :: DSM.UniqDSMT IO a -> LlvmM a+liftUDSMT m = LlvmM $ \env -> do x <- m+                                 return (x, env)++-- | Get initial Llvm environment.+runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> DSM.DUniqSupply -> LlvmM a -> IO (a, DSM.DUniqSupply)+runLlvm logger cfg ver out us m = do+    ((a, _), us') <- DSM.runUDSMT us $ runLlvmM m env+    return (a, us')+  where env = LlvmEnv { envFunMap    = emptyUFM+                      , envVarMap    = emptyUFM+                      , envStackRegs = []+                      , envUsedVars  = []+                      , envAliases   = emptyUniqSet+                      , envVersion   = ver+                      , envConfig    = cfg+                      , envLogger    = logger+                      , envOutput    = out+                      , envTag       = '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 :: GlobalRegUse -> LlvmM ()+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }++-- | Check whether a register is allocated on the stack+checkStackReg :: GlobalReg -> LlvmM (Maybe CmmType)+checkStackReg r = do+  stack_regs <- getEnv envStackRegs+  return $ fmap globalRegUse_type $ lookupRegUse r stack_regs++-- | 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.HDoc -> Outp.SDoc -> LlvmM ()+renderLlvm hdoc sdoc = do++    -- Write to output+    ctx <- llvmCgContext <$> getConfig+    out <- getEnv envOutput+    liftIO $ Outp.bPutHDoc out ctx hdoc++    -- 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 #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) (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.
+ GHC/CmmToLlvm/CodeGen.hs view
@@ -0,0 +1,2450 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs, MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}++-- | 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.Llvm.Types+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.Label++import GHC.Data.FastString+import GHC.Data.Maybe (expectJust)+import GHC.Data.OrdList++import GHC.Types.ForeignCall+import GHC.Types.Unique.DSM+import GHC.Types.Unique++import GHC.Utils.Outputable+import qualified GHC.Utils.Panic as Panic+import GHC.Utils.Misc++import Control.Applicative (Alternative((<|>)))+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer+import Control.Monad++import qualified Data.Semigroup as Semigroup+import Data.Foldable ( toList )+import Data.List ( nub )+import qualified Data.List as List+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import Data.Maybe ( catMaybes )++type Atomic = Maybe MemoryOrdering+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)+  | Just blocks <- nonEmpty $ toBlockListEntryFirstFalseFallthrough graph = do+    (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+--++-- | Unreachable basic block+--+-- See Note [Unreachable block as default destination in Switch]+newtype UnreachableBlockId = UnreachableBlockId BlockId++-- | 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 :: LiveGlobalRegUses -> NonEmpty CmmBlock+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])+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)++       -- allocate one unreachable basic block that can be used as a default+       -- destination in exhaustive switches.+       --+       -- See Note [Unreachable block as default destination in Switch]+       ubid@(UnreachableBlockId ubid') <- UnreachableBlockId <$> newBlockId+       let ubblock = BasicBlock ubid' [Unreachable]++       -- Generate code+       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) $ toList cmmBlocks++       -- Compose+       return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)+++-- | Generate code for one block+basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )+basicBlockCodeGen ubid block+  = do let (_, nodes, tail)  = blockSplit block+           id = entryLabel block+       (mid_instrs, top) <- stmtsToInstrs ubid $ blockToList nodes+       (tail_instrs, top')  <- stmtToInstrs ubid 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 :: UnreachableBlockId -> [CmmNode e x] -> LlvmM StmtData+stmtsToInstrs ubid stmts+   = do (instrss, topss) <- fmap unzip $ mapM (stmtToInstrs ubid) stmts+        return (concatOL instrss, concat topss)+++-- | Convert a CmmStmt to a list of LlvmStatement's+stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData+stmtToInstrs ubid 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 ubid 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++-- | 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_AcquireFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncAcquire+genCall (PrimTarget MO_ReleaseFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncRelease+genCall (PrimTarget MO_SeqCstFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncSeqCst++genCall (PrimTarget MO_Touch) _ _ =+    return (nilOL, [])++genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do+    (dstV, ty) <- getCmmRegW (CmmLocal dst)+    let 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 Clz, Ctz, BRev, BSwap, Pdep, Pext, and PopCnt that need to only+-- convert arg and return types+genCall (PrimTarget op@(MO_Clz w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Ctz w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_BRev w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_BSwap w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Pdep w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_Pext w)) [dst] args =+    genCallSimpleCast w op dst args+genCall (PrimTarget op@(MO_PopCnt w)) [dst] args =+    genCallSimpleCast w op dst 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, _dst_ty) <- 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 _ mem_ord)) [dst] [addr] = runStmtsDecls $ do+    (dstV, _dst_ty) <- getCmmRegW (CmmLocal dst)+    v1 <- genLoadW (Just mem_ord) 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, _dst_ty) <- 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, _dst_ty) <- getCmmRegW (CmmLocal dst)+    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 mem_ord)) [] [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+    let ordering = convertMemoryOrdering mem_ord+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar ordering++-- 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, _dstL_ty) <- getCmmRegW (CmmLocal dstL)+    (dstRegH, _dstH_ty) <- 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, _dstL_ty) <- getCmmRegW (CmmLocal dstL)+    (dstRegH, _dstH_ty) <- getCmmRegW (CmmLocal dstH)+    (dstRegC, _dstC_ty) <- 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, _dstQ_ty) <- lift $ getCmmReg (CmmLocal dstQ)+    (dstRegR, _dstR_ty) <- 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]++genCall (PrimTarget (MO_VS_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SDiv lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VS_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_SRem lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VU_Quot l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_UDiv lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++genCall (PrimTarget (MO_VU_Rem l w)) [dst] [lhs, rhs] = runStmtsDecls $ do+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    result <- doExprW (LMVector l (widthToLlvmInt w)) (LlvmOp LM_MO_URem lhsVar rhsVar)+    (dstReg, _dstTy) <- lift $ getCmmReg (CmmLocal dst)+    statement $ Store result dstReg Nothing []++-- 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  -> panic "GHC.CmmToLlvm.CodeGen.genCall: StdCallConv"+                 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, ty) <- getCmmRegW (CmmLocal creg)+            if retTy == ty+            then do+                statement $ Store v1 vreg Nothing []+                doReturn+            else do+                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+                            ]+    Panic.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, _dstV_ty) <- getCmmReg (CmmLocal dstV)+    (dstRegO, _dstO_ty) <- 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 -> CallishMachOp -> CmmFormal -> [CmmActual]+                  -> LlvmM StmtData+genCallSimpleCast specW op dst args = do+    let width   = widthToLlvmInt specW+        argsW   = const width <$> args+        dstType = cmmToLlvmType $ localRegType dst+        signage = cmmPrimOpRetValSignage op++    fname                 <- cmmPrimOpFunctions op+    (fptr, _, top3)       <- getInstrinct fname width argsW+    (dstV, _dst_ty)       <- getCmmReg (CmmLocal dst)+    let (_, arg_hints)     = foreignTargetHints $ PrimTarget op+    let args_hints         = zip args arg_hints+    (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])+    (argsV', stmts4)      <- castVars signage $ zip argsV argsW+    (retV, s1)            <- doExpr width $ Call StdCall fptr argsV' []+    (retV', stmts5)       <- castVar signage retV dstType+    let s2                 = Store retV' dstV Nothing []++    let stmts = stmts2 `appOL` stmts4 `snocOL`+                s1 `snocOL` stmts5 `snocOL` s2+    return (stmts, top2 ++ top3)++-- | 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+    -- Some bit-wise operations /must/ always treat the input and output values+    -- as 'Unsigned' in order to return the expected result values when pre/post-+    -- operation bit-width truncation and/or extension occur. For example,+    -- consider the Bit-Reverse operation:+    --+    -- If the result of a Bit-Reverse is treated as signed,+    -- an positive input can result in an negative output, i.e.:+    --+    --   identity(0x03) = 0x03 = 00000011+    --   breverse(0x03) = 0xC0 = 11000000+    --+    -- Now if an extension is performed after the operation to+    -- promote a smaller bit-width value into a larger bit-width+    -- type, it is expected that the /bit-wise/ operations will+    -- not be treated /numerically/ as signed.+    --+    -- To illustrate the difference, consider how a signed extension+    -- for the type i16 to i32 differs for out values above:+    --   ext_zeroed(i32, breverse(0x03)) = 0x00C0 = 0000000011000000+    --   ext_signed(i32, breverse(0x03)) = 0xFFC0 = 1111111111000000+    --+    -- Here we can see that the former output is the expected result+    -- of a bit-wise operation which needs to be promoted to a larger+    -- bit-width type. The latter output is not desirable when we must+    -- constraining a value into a range of i16 within an i32 type.+    --+    -- Hence we always treat the "signage" as unsigned for Bit-Reverse!+    --+    -- The same reasoning applied to Bit-Reverse above applies to the other+    -- bit-wise operations; do not sign extend a possibly negated number!+    MO_BRev   _ -> Unsigned+    MO_BSwap  _ -> Unsigned+    MO_Clz    _ -> Unsigned+    MO_Ctz    _ -> Unsigned+    MO_Pdep   _ -> Unsigned+    MO_Pext   _ -> Unsigned+    MO_PopCnt _ -> Unsigned++    -- All other cases, default to preserving the numeric sign when extending.+    _           -> 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_VS_Quot {} -> unsupported+    MO_VS_Rem {}  -> unsupported+    MO_VU_Quot {} -> unsupported+    MO_VU_Rem {}  -> unsupported+    MO_I64X2_Min  -> unsupported+    MO_I64X2_Max  -> unsupported+    MO_W64X2_Min  -> unsupported+    MO_W64X2_Max  -> unsupported++    MO_ReleaseFence  -> unsupported+    MO_AcquireFence  -> unsupported+    MO_SeqCstFence   -> 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 -> LiveGlobalRegUses -> 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, ty) <- getCmmReg reg+    (vval, stmts2, top2) <- exprToVar val+    let stmts = stmts2+    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 -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec+              -> LlvmM StmtData+genStore_fast addr r n val alignment+  = do platform <- getPlatform+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+       meta          <- getTBAARegMeta (globalRegUse_reg 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 = mkStore vval ptr alignment meta+                         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 = mkStore vval ptr' alignment meta+                         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 = mkStore v vaddr alignment meta+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)++        LMPointer _ -> do+            let s1 = mkStore vval vaddr alignment meta+            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 = mkStore vval vptr alignment meta+            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 -> [MetaAnnot] -> LlvmStatement+mkStore vval vptr alignment metas =+    Store vval vptr align metas+  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 :: UnreachableBlockId -> CmmExpr -> SwitchTargets -> LlvmM StmtData+genSwitch (UnreachableBlockId ubid) cond ids = do+    (vc, stmts, top) <- exprToVar cond+    let ty = getVarType vc++    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)+                 | (ix, b) <- switchTargetsCases ids ]+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l+               | otherwise                          = blockIdToLlvm ubid+                 -- switch to an unreachable basic block for exhaustive+                 -- switches. See Note [Unreachable block as default destination+                 -- in Switch]++    let s1 = Switch vc defLbl labels+    return $ (stmts `snocOL` s1, top)+++-- Note [Unreachable block as default destination in Switch]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- LLVM IR requires a default destination (a block label) for its Switch+-- operation, even if the switch is exhaustive. An LLVM switch is considered+-- exhausitve (e.g. to omit range checks for bit tests [1]) if the default+-- destination is unreachable.+--+-- When we codegen a Cmm function, we always reserve an unreachable basic block+-- that is used as a default destination for exhaustive Cmm switches in+-- genSwitch. See #24717+--+-- [1] https://reviews.llvm.org/D68131++++-- -----------------------------------------------------------------------------+-- * 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 Nothing 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+        -> exprToVar $ expandCmmReg (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_Round    _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp+    MO_FS_Truncate _ 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_WF_Bitcast w -> fiConv (widthToLlvmFloat w) LM_Bitcast+    MO_FW_Bitcast w -> fiConv (widthToLlvmInt w)   LM_Bitcast++    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_V_Broadcast  l w -> genBroadcastOp l w x+    MO_VF_Broadcast l w -> genBroadcastOp l w x++    MO_RelaxedRead w -> exprToVar (CmmLoad x (cmmBits w) NaturallyAligned)++    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_Min        _ -> panicOp+    MO_F_Max        _ -> panicOp++    MO_FMA _ _ _      -> 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_Min     _ _ -> panicOp+    MO_VS_Max     _ _ -> panicOp++    MO_VU_Min     _ _ -> panicOp+    MO_VU_Max     _ _ -> panicOp++    MO_VF_Insert  _ _ -> panicOp+    MO_VF_Extract _ _ -> panicOp++    MO_V_Shuffle {} -> panicOp+    MO_VF_Shuffle {} -> panicOp++    MO_VF_Add     _ _ -> panicOp+    MO_VF_Sub     _ _ -> panicOp+    MO_VF_Mul     _ _ -> panicOp+    MO_VF_Quot    _ _ -> panicOp+    MO_VF_Min     _ _ -> panicOp+    MO_VF_Max     _ _ -> 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 -> GlobalRegUse -> 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_FMA _ _ _ -> panicOp++    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_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_Round    _ _ -> panicOp+    MO_FS_Truncate _ _ -> panicOp+    MO_SS_Conv _ _ -> panicOp+    MO_UU_Conv _ _ -> panicOp+    MO_XX_Conv _ _ -> panicOp+    MO_FF_Conv _ _ -> panicOp++    MO_WF_Bitcast _to ->  panicOp+    MO_FW_Bitcast _to ->  panicOp++    MO_VS_Neg {} -> panicOp++    MO_VF_Broadcast {} -> panicOp+    MO_V_Broadcast {} -> panicOp+    MO_V_Insert  {} -> panicOp+    MO_VF_Insert  {} -> panicOp++    MO_V_Shuffle _ _ is -> genShuffleOp is x y+    MO_VF_Shuffle _ _ is -> genShuffleOp is x y++    MO_VF_Neg {} -> panicOp++    -- Min/max+    MO_F_Min  {} -> genMinMaxOp "minnum" x y+    MO_F_Max  {} -> genMinMaxOp "maxnum" x y+    MO_VF_Min {} -> genMinMaxOp "minnum" x y+    MO_VF_Max {} -> genMinMaxOp "maxnum" x y+    MO_VU_Min {} -> genMinMaxOp "umin"   x y+    MO_VU_Max {} -> genMinMaxOp "umax"   x y+    MO_VS_Min {} -> genMinMaxOp "smin"   x y+    MO_VS_Max {} -> genMinMaxOp "smax"   x y++    MO_RelaxedRead {} -> panicOp++    MO_AlignmentCheck {} -> panicOp++    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)++        genMinMaxOp intrin x y = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            let tx = getVarType vx+                ty = getVarType vy+                fname = "llvm." ++ intrin ++ "." ++ ppLlvmTypeShort ty+            Panic.massertPpr+              (tx == ty)+              (vcat [ text (fname ++ ": mismatched arg types")+                    , ppLlvmType tx, ppLlvmType ty ])+            fptr <- liftExprData $ getInstrinct (fsLit fname) ty [tx, ty]+            doExprW tx $ Call StdCall fptr [vx, vy] [ReadNone, NoUnwind]++        -- 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: non-binary op encountered "+                       ++ "with two arguments! (" ++ show op ++ ")"++genMachOp_slow _opt op [x, y, z] = do+  let+    panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered "+                   ++ "with three arguments! (" ++ show op ++ ")"+  case op of+    MO_FMA var lg width ->+      case var of+        -- LLVM only has the fmadd variant.+        FMAdd   -> genFmaOp x y z+        -- Other fused multiply-add operations are implemented in terms of fmadd+        -- This is sound: it does not lose any precision.+        FMSub   -> genFmaOp x y (neg z)+        FNMAdd  -> genFmaOp (neg x) y z+        FNMSub  -> genFmaOp (neg x) y (neg z)+      where+        neg x+          | lg == 1+          = CmmMachOp (MO_F_Neg width) [x]+          | otherwise+          = CmmMachOp (MO_VF_Neg lg width) [x]+    _ -> panicOp++-- More than three expressions, invalid!+genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!"++genBroadcastOp :: Int -> Width -> CmmExpr -> LlvmM ExprData+genBroadcastOp lg _width x = runExprData $ do+  -- To broadcast a scalar x as a vector v:+  --   1. insert x at the 0 position of the zero vector+  --   2. shuffle x into all positions+  var_x <- exprToVarW x+  let tx = getVarType var_x+      tv = LMVector lg tx+      z = if isFloat tx+          then LMFloatLit 0 tx+          else LMIntLit   0 tx+      zs = LMLitVar $ LMVectorLit $ replicate lg z+  w <- doExprW tv $ Insert zs var_x (LMLitVar $ LMIntLit 0 (LMInt 32))+  doExprW tv $ Shuffle w w (replicate lg 0)++genShuffleOp :: [Int] -> CmmExpr -> CmmExpr -> LlvmM ExprData+genShuffleOp is x y = runExprData $ do+  vx <- exprToVarW x+  vy <- exprToVarW y+  let tx = getVarType vx+      ty = getVarType vy+  Panic.massertPpr+    (tx == ty)+    (vcat [ text "shuffle: mismatched arg types"+          , ppLlvmType tx, ppLlvmType ty ])+  doExprW tx $ Shuffle vx vy is++-- | Generate code for a fused multiply-add operation.+genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData+genFmaOp x y z = runExprData $ do+  vx <- exprToVarW x+  vy <- exprToVarW y+  vz <- exprToVarW z+  let tx = getVarType vx+      ty = getVarType vy+      tz = getVarType vz+  Panic.massertPpr+    (tx == ty && tx == tz)+    (vcat [ text "fma: mismatched arg types"+          , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ])+  let fname = case tx of+        LMFloat  -> fsLit "llvm.fma.f32"+        LMDouble -> fsLit "llvm.fma.f64"+        LMVector 4 LMFloat -> fsLit "llvm.fma.v4f32"+        LMVector 8 LMFloat -> fsLit "llvm.fma.v8f32"+        LMVector 16 LMFloat -> fsLit "llvm.fma.v16f32"+        LMVector 2 LMDouble -> fsLit "llvm.fma.v2f64"+        LMVector 4 LMDouble -> fsLit "llvm.fma.v4f64"+        LMVector 8 LMDouble -> fsLit "llvm.fma.v8f64"+        _ -> pprPanic "CmmToLlvm.genFmaOp: unsupported type" (ppLlvmType tx)+  fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]+  doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind]++-- | 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 -> GlobalRegUse -> Int -> CmmType+             -> AlignmentSpec -> LlvmM ExprData+genLoad_fast atomic e r n ty align = do+    platform <- getPlatform+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+    meta          <- getTBAARegMeta (globalRegUse_reg 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+  | Just mem_ord <- atomic+                = ALoad (convertMemoryOrdering mem_ord) 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, LlvmType)+getCmmReg (CmmLocal (LocalReg un _))+  = do exists <- varLookup un+       case exists of+         Just ety -> return (LMLocalVar un $ pLift ety, 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 (GlobalRegUse reg _reg_ty))+  = do onStack  <- checkStackReg reg+       platform <- getPlatform+       case onStack of+          Just stack_ty -> do+            let var = lmGlobalRegVar platform (GlobalRegUse reg stack_ty)+            return (var, pLower $ getVarType var)+          Nothing ->+            pprPanic "getCmmReg: Cmm register " $+              ppr reg <> 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 gu@(GlobalRegUse g _) -> do+      onStack <- checkStackReg g+      platform <- getPlatform+      case onStack of+        Just {} ->+          loadFromStack+        Nothing -> do+          let r = lmGlobalRegArg platform gu+          return (r, getVarType r, nilOL)+    _ -> loadFromStack+ where+    loadFromStack = do+      platform <- getPlatform+      (ptr, stack_reg_ty) <- getCmmReg reg+      let reg_ty = case reg of+            CmmGlobal g -> pLower $ getVarType $ lmGlobalRegVar platform g+            CmmLocal {} -> stack_reg_ty+      if reg_ty /= stack_reg_ty+      then do+        (v1, s1) <- doExpr stack_reg_ty (Load ptr Nothing)+        (v2, s2) <- doExpr reg_ty (Cast LM_Bitcast v1 reg_ty)+        return (v2, reg_ty, toOL [s1, s2])+      else do+        (v, s) <- doExpr reg_ty (Load ptr Nothing)+        return (v, reg_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 W32)+  = return (LMLitVar $ LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32),+              nilOL, [])++genLit _ (CmmFloat r W64)+  = return (LMLitVar $ LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64),+              nilOL, [])++genLit _ (CmmFloat _r _w)+  = panic "genLit (CmmLit:CmmFloat), unsupported float lit"++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+--++convertMemoryOrdering :: MemoryOrdering -> LlvmSyncOrdering+convertMemoryOrdering MemOrderRelaxed = SyncMonotonic+convertMemoryOrdering MemOrderAcquire = SyncAcquire+convertMemoryOrdering MemOrderRelease = SyncRelease+convertMemoryOrdering MemOrderSeqCst  = SyncSeqCst++-- | 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 :: LiveGlobalRegUses -> NonEmpty CmmBlock -> LlvmM StmtData+funPrologue live cmmBlocks = do+  platform <- getPlatform++  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+      mbLive r     =+        lookupRegUse r (alwaysLive platform) <|> lookupRegUse r 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 ru@(GlobalRegUse r ty0) -> do+        let reg   = lmGlobalRegVar platform ru+            ty    = (pLower . getVarType) reg+            trash = LMLitVar $ LMUndefLit ty+            rval  = case mbLive r of+              Just (GlobalRegUse _ ty') ->+                lmGlobalRegArg platform (GlobalRegUse r ty')+              _ -> trash+            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1+        markStackReg ru+        case mbLive r of+          Just (GlobalRegUse _ ty')+            | let llvm_ty  = cmmToLlvmType ty0+                  llvm_ty' = cmmToLlvmType ty'+            , llvm_ty /= llvm_ty'+            -> do castV <- mkLocalVar (pLift llvm_ty')+                  return $+                    toOL [ alloc+                         , Assignment castV $ Cast LM_Bitcast reg (pLift llvm_ty')+                         , Store rval castV Nothing []+                         ]+          _ ->+            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 :: LiveGlobalRegUses -> 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+      | Just ru <- lookupRegUse r (alwaysLive platform)+      -> loadExpr ru+      | Just ru <- lookupRegUse r live+      -> loadExpr ru+      -- load all non Floating-Point Registers+      | not (isFPR r)+      -> loadUndef (GlobalRegUse r (globalRegSpillType platform r))+      -- load padding Floating-Point Registers+      | Just ru <- lookupRegUse r paddingRegs+      -> loadUndef ru+      | 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 :: LiveGlobalRegUses -> 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 :: (CmmReg, Int) -> CmmExpr+expandCmmReg (reg, off)+  = let width = typeWidth (cmmRegType 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 =+    List.singleton . MetaAnnot tbaa . MetaNode . expectJust <$> getUniqMeta u++-- | 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, LlvmType)+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
+ GHC/CmmToLlvm/Config.hs view
@@ -0,0 +1,82 @@+-- | Llvm code generator configuration+module GHC.CmmToLlvm.Config+  ( LlvmCgConfig(..)+  , LlvmConfig(..)+  , LlvmTarget(..)+  , initLlvmConfig+  )+where++import GHC.Prelude+import GHC.Platform++import GHC.Utils.Outputable+import GHC.Settings.Utils+import GHC.Utils.Panic+import GHC.CmmToLlvm.Version.Type (LlvmVersion)++import System.FilePath++data LlvmCgConfig = LlvmCgConfig+  { llvmCgPlatform          :: !Platform     -- ^ Target platform+  , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation+  , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values+  , llvmCgSplitSection      :: !Bool         -- ^ Split sections+  , llvmCgAvxEnabled        :: !Bool+  , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions+  , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using+  , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version+  , llvmCgLlvmTarget        :: !String       -- ^ target triple passed to LLVM+  , llvmCgLlvmConfig        :: !LlvmConfig   -- ^ Supported LLVM configurations.+                                             -- see Note [LLVM configuration]+  }++data LlvmTarget = LlvmTarget+  { lDataLayout :: String+  , lCPU        :: String+  , lAttributes :: [String]+  }++-- Note [LLVM configuration]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain+-- information needed by the LLVM backend to invoke `llc` and `opt`.+-- Specifically:+--+--  * llvm-targets maps autoconf host triples to the corresponding LLVM+--    `data-layout` declarations. This information is extracted from clang using+--    the script in utils/llvm-targets/gen-data-layout.sh and should be updated+--    whenever we target a new version of LLVM.+--+--  * llvm-passes maps GHC optimization levels to sets of LLVM optimization+--    flags that GHC should pass to `opt`.+--+-- This information is contained in files rather the GHC source to allow users+-- to add new targets to GHC without having to recompile the compiler.+--++initLlvmConfig :: FilePath -> IO LlvmConfig+initLlvmConfig top_dir+  = do+      targets <- readAndParse "llvm-targets"+      passes <- readAndParse "llvm-passes"+      return $ LlvmConfig+        { llvmTargets = fmap mkLlvmTarget <$> targets+        , llvmPasses = passes+        }+  where+    readAndParse :: Read a => String -> IO a+    readAndParse name = do+      let f = top_dir </> name+      llvmConfigStr <- readFile f+      case maybeReadFuzzy llvmConfigStr of+        Just s -> return s+        Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f)++    mkLlvmTarget :: (String, String, String) -> LlvmTarget+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)++data LlvmConfig = LlvmConfig+  { llvmTargets :: [(String, LlvmTarget)]+  , llvmPasses  :: [(Int, String)]+  }
+ GHC/CmmToLlvm/Data.hs view
@@ -0,0 +1,244 @@++-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmData to LLVM code.+--++module GHC.CmmToLlvm.Data (+        genLlvmData, genData+    ) where++import GHC.Prelude++import GHC.Llvm+import GHC.Llvm.Types (widenFp)+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+                            Section Data _    -> Just $ platformWordSizeInBytes platform+                            _                 -> 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 Appending 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 W32)+    = return $ LMStaticLit (LMFloatLit (widenFp (fromRational r :: Float)) (widthToLlvmFloat W32))++genStaticLit (CmmFloat r W64)+    = return $ LMStaticLit (LMFloatLit (fromRational r :: Double) (widthToLlvmFloat W64))++genStaticLit (CmmFloat _r _w)+    = panic "genStaticLit (CmmLit:CmmFloat), unsupported float lit"++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!"
+ GHC/CmmToLlvm/Mangler.hs view
@@ -0,0 +1,169 @@+-- -----------------------------------------------------------------------------+-- | 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, rewriteJump]++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))++-- | This rewrites bl and b jump inst to avoid creating PLT entries for+-- functions on loongarch64, because there is no separate call instruction+-- for function calls in loongarch64. Also, this replacement will load+-- the function address from the GOT, which is resolved to point to the+-- real address of the function.+rewriteJump :: Rewrite+rewriteJump platform l+  | not isLoongArch64 = Nothing+  | isBL l            = Just $ replaceJump "bl" "$ra" "$ra" l+  | isB l             = Just $ replaceJump "b" "$zero" "$t0" l+  | otherwise         = Nothing+  where+    isLoongArch64 = platformArch platform == ArchLoongArch64+    isBL = B.isPrefixOf (B.pack "bl\t")+    isB = B.isPrefixOf (B.pack "b\t")++    replaceJump jump rd rj l =+        appendInsn ("jirl" ++ "\t" ++ rd ++ ", " ++ rj ++ ", 0") $ removeBracket $+        replaceOnce (B.pack (jump ++ "\t%plt(")) (B.pack ("la\t" ++ rj ++ ", ")) l+      where+        removeBracket = replaceOnce (B.pack ")") (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
+ GHC/CmmToLlvm/Ppr.hs view
@@ -0,0 +1,108 @@+++-- ----------------------------------------------------------------------------+-- | 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 :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc+pprLlvmData cfg (globals, types) =+    let ppLlvmTys (LMAlias    a) = line $ ppLlvmAlias a+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f+        ppLlvmTys _other         = empty++        types'   = vcat $ map ppLlvmTys types+        globals' = ppLlvmGlobals cfg globals+    in types' $$ globals'+{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc #-}+{-# SPECIALIZE pprLlvmData :: LlvmCgConfig -> LlvmData -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+++-- | Pretty print LLVM code+-- The HDoc we return is used to produce the final LLVM file, with the+-- SDoc being returned alongside for use when @Opt_D_dump_llvm@ is set+-- as we can't (currently) dump HDocs.+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (HDoc, SDoc)+pprLlvmCmmDecl (CmmData _ lmdata) = do+  opts <- getConfig+  return ( vcat $ map (pprLlvmData opts) lmdata+         , 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 ( vcat [line $ ppLlvmGlobal cfg alias, ppLlvmFunction cfg fun']+              , vcat [line $ 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"
+ GHC/CmmToLlvm/Regs.hs view
@@ -0,0 +1,151 @@+++--------------------------------------------------------------------------------+-- | 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.CmmToAsm.Format+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 -> GlobalRegUse -> LlvmVar+lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"++-- | Get the LlvmVar function argument storing the real register+lmGlobalRegArg :: Platform -> GlobalRegUse -> 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 -> GlobalRegUse -> LlvmVar+lmGlobalReg platform suf (GlobalRegUse reg ty)+  = 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+        fmt = cmmTypeFormat ty+        xmmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt)+        ymmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt)+        zmmGlobal    name = LMNLocalVar (fsLit name) (formatLlvmType fmt)++formatLlvmType :: Format -> LlvmType+formatLlvmType II8 = LMInt 8+formatLlvmType II16 = LMInt 16+formatLlvmType II32 = LMInt 32+formatLlvmType II64 = LMInt 64+formatLlvmType FF32 = LMFloat+formatLlvmType FF64 = LMDouble+formatLlvmType (VecFormat l sFmt) = LMVector l (formatLlvmType $ scalarFormatFormat sFmt)++-- | A list of STG Registers that should always be considered alive+alwaysLive :: Platform -> [GlobalRegUse]+alwaysLive platform =+  [ GlobalRegUse r (globalRegSpillType platform r)+  | r <- [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
+ GHC/CmmToLlvm/Version.hs view
@@ -0,0 +1,43 @@+module GHC.CmmToLlvm.Version+  ( LlvmVersion(..)+  , supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  , parseLlvmVersion+  , llvmVersionSupported+  , llvmVersionStr+  , llvmVersionList+  )+where++import GHC.Prelude++import GHC.CmmToLlvm.Version.Type+import GHC.CmmToLlvm.Version.Bounds++import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE++parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+  where+    go vs s+      | null ver_str+      = reverse vs+      | '.' : rest' <- rest+      = go (read ver_str : vs) rest'+      | otherwise+      = reverse (read ver_str : vs)+      where+        (ver_str, rest) = span isDigit s++llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported v =+  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr = intercalate "." . map show . llvmVersionList++llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE
+ GHC/CmmToLlvm/Version/Bounds.hs view
@@ -0,0 +1,19 @@+module GHC.CmmToLlvm.Version.Bounds+  ( supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  )+where++import GHC.Prelude ()++import GHC.CmmToLlvm.Version.Type++import qualified Data.List.NonEmpty as NE++-- | The (inclusive) lower bound on the LLVM Version that is currently supported.+supportedLlvmVersionLowerBound :: LlvmVersion+supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| [])++-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.+supportedLlvmVersionUpperBound :: LlvmVersion+supportedLlvmVersionUpperBound = LlvmVersion (21 NE.:| [])
+ GHC/CmmToLlvm/Version/Type.hs view
@@ -0,0 +1,11 @@+module GHC.CmmToLlvm.Version.Type+  ( LlvmVersion(..)+  )+where++import GHC.Prelude++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)
+ GHC/Core.hs view
@@ -0,0 +1,2438 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE NoPolyKinds #-}++-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection+module GHC.Core (+        -- * Main data types+        Expr(..), Alt(..), Bind(..), AltCon(..), Arg,+        CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,+        TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,++        -- * In/Out type synonyms+        InId, InBind, InExpr, InAlt, InArg, InType, InKind,+               InBndr, InVar, InCoercion, InTyVar, InCoVar, InTyCoVar,+        OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind,+               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,+               OutTyCoVar, MOutCoercion,++        -- ** 'Expr' construction+        mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,+        mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg,++        mkIntLit, mkIntLitWrap,+        mkWordLit, mkWordLitWrap,+        mkWord8Lit,+        mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64,+        mkCharLit, mkStringLit,+        mkFloatLit, mkFloatLitFloat,+        mkDoubleLit, mkDoubleLitDouble,++        mkConApp, mkConApp2, mkTyBind, mkCoBind,+        varToCoreExpr, varsToCoreExprs,++        mkBinds,++        isId, cmpAltCon, cmpAlt, ltAlt,++        -- ** Simple 'Expr' access functions and predicates+        bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts,+        foldBindersOfBindStrict, foldBindersOfBindsStrict,+        collectBinders, collectTyBinders, collectTyAndValBinders,+        collectNBinders, collectNValBinders_maybe,+        collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds,+        collectFunSimple,++        exprToType,+        wrapLamBody,++        isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount,+        isRuntimeArg, isRuntimeVar,++        -- * Unfolding data types+        Unfolding(..),  UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..),++        -- ** Constructing 'Unfolding's+        noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,+        unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,++        -- ** Predicates and deconstruction on 'Unfolding'+        expandUnfolding_maybe,+        maybeUnfoldingTemplate, otherCons,+        isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,+        isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,+        isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,+        isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan,+        hasCoreUnfolding, hasSomeUnfolding,+        canUnfold, neverUnfoldGuidance, isStableSource,++        -- * Annotated expression data types+        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..),++        -- ** Operations on annotated expressions+        collectAnnArgs, collectAnnArgsTicks,++        -- ** Operations on annotations+        deAnnotate, deAnnotate', deAnnAlt, deAnnBind,+        collectAnnBndrs, collectNAnnBndrs,++        -- * Orphanhood+        IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,++        -- * Core rule data types+        CoreRule(..),+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,++        -- ** Operations on 'CoreRule's+        ruleArity, ruleName, ruleIdName, ruleActivation,+        setRuleIdName, ruleModule,+        isBuiltinRule, isLocalRule, isAutoRule,+    ) where++import GHC.Prelude+import GHC.Platform++import GHC.Types.Var.Env( InScopeSet )+import GHC.Types.Var+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Rules.Config ( RuleOpts )+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Core.DataCon+import GHC.Unit.Module+import GHC.Types.Basic+import GHC.Types.Unique.Set++import GHC.Utils.Binary+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Data hiding (TyCon)+import Data.Int+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE+import Data.Word++import Control.DeepSeq++infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`+-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)++{-+************************************************************************+*                                                                      *+\subsection{The main data types}+*                                                                      *+************************************************************************++These data types are the heart of the compiler+-}++-- | This is the data type that represents GHCs core intermediate language. Currently+-- GHC uses System FC <https://www.microsoft.com/en-us/research/publication/system-f-with-type-equality-coercions/> for this purpose,+-- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.+--+-- We get from Haskell source to this Core language in a number of stages:+--+-- 1. The source code is parsed into an abstract syntax tree, which is represented+--    by the data type 'GHC.Hs.Expr.HsExpr' with the names being 'GHC.Types.Name.Reader.RdrNames'+--+-- 2. This syntax tree is /renamed/, which attaches a 'GHC.Types.Unique.Unique' to every 'GHC.Types.Name.Reader.RdrName'+--    (yielding a 'GHC.Types.Name.Name') to disambiguate identifiers which are lexically identical.+--    For example, this program:+--+-- @+--      f x = let f x = x + 1+--            in f (x - 2)+-- @+--+--    Would be renamed by having 'Unique's attached so it looked something like this:+--+-- @+--      f_1 x_2 = let f_3 x_4 = x_4 + 1+--                in f_3 (x_2 - 2)+-- @+--    But see Note [Shadowing in Core] below.+--+-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating+--    type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names.+--+-- 4. Finally the syntax tree is /desugared/ from the expressive 'GHC.Hs.Expr.HsExpr' type into+--    this 'Expr' type, which has far fewer constructors and hence is easier to perform+--    optimization, analysis and code generation on.+--+-- The type parameter @b@ is for the type of binders in the expression tree.+--+-- The language consists of the following elements:+--+-- *  Variables+--    See Note [Variable occurrences in Core]+--+-- *  Primitive literals+--+-- *  Applications: note that the argument may be a 'Type'.+--    See Note [Representation polymorphism invariants]+--+-- *  Lambda abstraction+--    See Note [Representation polymorphism invariants]+--+-- *  Recursive and non recursive @let@s. Operationally+--    this corresponds to allocating a thunk for the things+--    bound and then executing the sub-expression.+--+--    See Note [Core letrec invariant]+--    See Note [Core let-can-float invariant]+--    See Note [Representation polymorphism invariants]+--    See Note [Core type and coercion invariant]+--+-- *  Case expression. Operationally this corresponds to evaluating+--    the scrutinee (expression examined) to weak head normal form+--    and then examining at most one level of resulting constructor (i.e. you+--    cannot do nested pattern matching directly with this).+--+--    The binder gets bound to the value of the scrutinee,+--    and the 'Type' must be that of all the case alternatives+--+--    IMPORTANT: see Note [Case expression invariants]+--+-- *  Cast an expression to a particular type.+--    This is used to implement @newtype@s (a @newtype@ constructor or+--    destructor just becomes a 'Cast' in Core) and GADTs.+--+-- *  Ticks. These are used to represent all the source annotation we+--    support: profiling SCCs, HPC ticks, and GHCi breakpoints.+--+-- *  A type: this should only show up at the top level of an Arg+--+-- *  A coercion++{- Note [Why does Case have a 'Type' field?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The obvious alternative is+   exprType (Case scrut bndr alts)+     | (_,_,rhs1):_ <- alts+     = exprType rhs1++But caching the type in the Case constructor+  exprType (Case scrut bndr ty alts) = ty+is better for at least three reasons:++* It works when there are no alternatives (see case invariant 1 above)++* It might be faster in deeply-nested situations.++* It might not be quite the same as (exprType rhs) for one+  of the RHSs in alts. Consider a phantom type synonym+       type S a = Int+   and we want to form the case expression+        case x of { K (a::*) -> (e :: S a) }+   Then exprType of the RHS is (S a), but we cannot make that be+   the 'ty' in the Case constructor because 'a' is simply not in+   scope there. Instead we must expand the synonym to Int before+   putting it in the Case constructor.  See GHC.Core.Utils.mkSingleAltCase.++   So we'd have to do synonym expansion in exprType which would+   be inefficient.++* The type stored in the case is checked with lintInTy. This checks+  (among other things) that it does not mention any variables that are+  not in scope. If we did not have the type there, it would be a bit+  harder for Core Lint to reject case blah of Ex x -> x where+      data Ex = forall a. Ex a.+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Expr b+  = Var   Id+  | Lit   Literal+  | App   (Expr b) (Arg b)+  | Lam   b (Expr b)+  | Let   (Bind b) (Expr b)+  | Case  (Expr b) b Type [Alt b]   -- See Note [Case expression invariants]+                                    -- and Note [Why does Case have a 'Type' field?]+  | Cast  (Expr b) CoercionR        -- The Coercion has Representational role+  | Tick  CoreTickish (Expr b)+  | Type  Type+  | Coercion Coercion+  deriving Data++-- | Type synonym for expressions that occur in function argument positions.+-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not+type Arg b = Expr b++-- | A case split alternative. Consists of the constructor leading to the alternative,+-- the variables bound from the constructor, and the expression to be executed given that binding.+-- The default alternative is @(DEFAULT, [], rhs)@++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Alt b+    = Alt AltCon [b] (Expr b)+    deriving (Data)++-- | A case alternative constructor (i.e. pattern match)++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data AltCon+  = DataAlt DataCon   --  ^ A plain data constructor: @case e of { Foo x -> ... }@.+                      -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@++  | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@+                      -- Invariant: always an *unlifted* literal+                      -- See Note [Literal alternatives]++  | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@+   deriving (Eq, Data)++-- This instance is a bit shady. It can only be used to compare AltCons for+-- a single type constructor. Fortunately, it seems quite unlikely that we'll+-- ever need to compare AltCons for different type constructors.+-- The instance adheres to the order described in Note [Case expression invariants]+instance Ord AltCon where+  compare (DataAlt con1) (DataAlt con2) =+    assert (dataConTyCon con1 == dataConTyCon con2) $+    compare (dataConTag con1) (dataConTag con2)+  compare (DataAlt _) _ = GT+  compare _ (DataAlt _) = LT+  compare (LitAlt l1) (LitAlt l2) = compare l1 l2+  compare (LitAlt _) DEFAULT = GT+  compare DEFAULT DEFAULT = EQ+  compare DEFAULT _ = LT++-- | Binding, used for top level bindings in a module and local bindings in a @let@.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Bind b = NonRec b (Expr b)+            | Rec [(b, (Expr b))]+  deriving Data++-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for+-- instance.+--+--   * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive+--     bindings with all the rhs/lhs pairs in @binds@+--   * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding+--     for each rhs/lhs pairs in @binds@+mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b]+mkBinds Recursive binds = [Rec binds]+mkBinds NonRecursive binds = map (uncurry NonRec) binds++{-+Note [Literal alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Literal alternatives (LitAlt lit) are always for *un-lifted* literals.+We have one literal, a literal Integer, that is lifted, and we don't+allow in a LitAlt, because LitAlt cases don't do any evaluation. Also+(see #5603) if you say+    case 3 of+      IS x -> ...+      IP _ -> ...+      IN _ -> ...+(where IS, IP, IN are the constructors for Integer) we don't want the+simplifier calling findAlt with argument (LitAlt 3).  No no.  Integer+literals are an opaque encoding of an algebraic data type, not of+an unlifted literal, like all the others.++Also, we do not permit case analysis with literal patterns on floating-point+types. See #9238 and Note [Rules for floating-point comparisons] in+GHC.Core.Opt.ConstantFold for the rationale for this restriction.++-------------------------- GHC.Core INVARIANTS ---------------------------++Note [Variable occurrences in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Variable /occurrences/ are never CoVars, though /bindings/ can be.+All CoVars appear in Coercions.++For example+  \(c :: Age~#Int) (d::Int). d |> (sym c)+Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in+a Coercion, (sym c).++Note [Shadowing in Core]+~~~~~~~~~~~~~~~~~~~~~~~~+You might wonder if there is an invariant that a Core expression has no+"shadowing".  For example, is this illegal?+     \x. \x. blah     -- x is shadowed+Answer; no!  Core does /not/ have a no-shadowing invariant.++Neither the simplifier nor any other pass GUARANTEES that shadowing is+avoided. Thus, all passes SHOULD work fine even in the presence of+arbitrary shadowing in their inputs.++So the Unique in a Var is not really unique at all.  Still, it's very+useful to give a constant-time equality/ordering for Vars, and to give+a key that can be used to make sets of Vars (VarSet), or mappings from+Vars to other things (VarEnv).   Moreover, if you do want to eliminate+shadowing, you can give a new Unique to an Id without changing its+printable name, which makes debugging easier.++It would in many ways be easier to have a no-shadowing invariant.  And the+Simplifier does its best to clone variables that are shadowed.  But it is+extremely difficult to GUARANTEE it:++* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques+  that are locally-unique (enough for the purpose) but not globally unique.+  It is convenient not to have to plumb a unique supply to these functions.++* It is very difficult for the Simplifier to gurantee a no-shadowing result.+  See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration.++* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE++* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr++Note [Core letrec invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Core letrec invariant:++  The right hand sides of all /top-level/ or /recursive/+  bindings must be of lifted type++See "Type#type_classification" in GHC.Core.Type+for the meaning of "lifted" vs. "unlifted".++For the non-top-level, non-recursive case see+Note [Core let-can-float invariant].++At top level, however, there are two exceptions to this rule:++(TL1) A top-level binding is allowed to bind primitive string literal,+      (which is unlifted).  See Note [Core top-level string literals].++(TL2) In Core, we generate a top-level binding for every non-newtype data+constructor worker or wrapper+      e.g.   data T = MkT Int+      we generate+             MkT :: Int -> T+             MkT = \x. MkT x+      (This binding looks recursive, but isn't; it defines a top-level, curried+      function whose body just allocates and returns the data constructor.)++      But if (a) the data constructor is nullary and (b) the data type is unlifted,+      this binding is unlifted.+      e.g.   data S :: UnliftedType where { S1 :: S, S2 :: S -> S }+      we generate+             S1 :: S   -- A top-level unlifted binding+             S1 = S1+      We allow this top-level unlifted binding to exist.++Note [Core let-can-float invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The let-can-float invariant:++    The right hand side of a /non-top-level/, /non-recursive/ binding+    may be of unlifted type, but only if+    the expression is ok-for-speculation+    or the 'Let' is for a join point.++    (For top-level or recursive lets see Note [Core letrec invariant].)++This means that the let can be floated around+without difficulty. For example, this is OK:++   y::Int# = x +# 1#++But this is not, as it may affect termination if the+expression is floated out:++   y::Int# = fac 4#++In this situation you should use @case@ rather than a @let@. The function+'GHC.Core.Utils.needsCaseBinding' can help you determine which to generate, or+alternatively use 'GHC.Core.Make.mkCoreLet' rather than this constructor directly,+which will generate a @case@ if necessary++The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make.++Historical Note [The let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules+to the argument of an application, as well as to the RHS of a let.  This made some+kind of sense, because 'let' can always be encoded as application:+   let x=rhs in b   =    (\x.b) rhs++But the let/app invariant got in the way of RULES; see #19313.  For example+  up :: Int# -> Int#+  {-# RULES "up/down" forall x. up (down x) = x #-}+The LHS of this rule doesn't satisfy the let/app invariant.++Indeed RULES is a big reason that GHC doesn't use ANF, where the argument of an+application is always a variable or a constant.  To allow RULES to work nicely+we need to allow lots of things in the arguments of a call.++TL;DR: we relaxed the let/app invariant to become the let-can-float invariant.++Note [Core top-level string literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As an exception to the usual rule that top-level binders must be lifted,+we allow binding primitive string literals (of type Addr#) at the+top level. This allows us to share string literals earlier in the pipeline and+crucially allows other optimizations in the Core2Core pipeline to fire.+Consider,++  f n = let a::Addr# = "foo"#+        in \x -> blah++In order to be able to inline `f`, we would like to float `a` to the top.+Another option would be to inline `a`, but that would lead to duplicating string+literals, which we want to avoid. See #8472.++The solution is simply to allow top-level unlifted binders. We can't allow+arbitrary unlifted expression at the top-level though, unlifted binders cannot+be thunks, so we just allow string literals.++We allow the top-level primitive string literals to be wrapped in Ticks+in the same way they can be wrapped when nested in an expression.+CoreToSTG currently discards Ticks around top-level primitive string literals.+See #14779.++Also see Note [Compilation plan for top-level string literals].++Note [Compilation plan for top-level string literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is a summary on how top-level string literals are handled by various+parts of the compilation pipeline.++* In the source language, there is no way to bind a primitive string literal+  at the top level.++* In Core, we have a special rule that permits top-level Addr# bindings. See+  Note [Core top-level string literals]. Core-to-core passes may introduce+  new top-level string literals.++  See GHC.Core.Utils.exprIsTopLevelBindable, and exprIsTickedString++* In STG, top-level string literals are explicitly represented in the syntax+  tree.++* A top-level string literal may end up exported from a module. In this case,+  in the object file, the content of the exported literal is given a label with+  the _bytes suffix.++Note [NON-BOTTOM-DICTS invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is a global invariant (not checkable by Lint) that++     every non-newtype dictionary-typed expression is non-bottom.++These conditions are captured by GHC.Core.Type.isTerminatingType.++How are we so sure about this?  Dictionaries are built by GHC in only two ways:++* A dictionary function (DFun), arising from an instance declaration.+  DFuns do no computation: they always return a data constructor immediately.+  See DFunUnfolding in GHC.Core.  So the result of a call to a DFun is always+  non-bottom.++  Exception: newtype dictionaries.++  Plus: see the Very Nasty Wrinkle in Note [Speculative evaluation]+  in GHC.CoreToStg.Prep++* A superclass selection from some other dictionary. This is harder to guarantee:+  see Note [Recursive superclasses] and Note [Solving superclass constraints]+  in GHC.Tc.TyCl.Instance.++A bad Core-to-Core pass could invalidate this reasoning, but that's too bad.+It's still an invariant of Core programs generated by GHC from Haskell, and+Core-to-Core passes maintain it.++Why is it useful to know that dictionaries are non-bottom?++1. It justifies the use of `-XDictsStrict`;+   see `GHC.Core.Types.Demand.strictifyDictDmd`++2. It means that (eq_sel d) is ok-for-speculation and thus+     case (eq_sel d) of _ -> blah+   can be discarded by the Simplifier.  See these Notes:+   Note [exprOkForSpeculation and type classes] in GHC.Core.Utils+   Note[Speculative evaluation] in GHC.CoreToStg.Prep++Note [Case expression invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case expressions are one of the more complicated elements of the Core+language, and come with a number of invariants.  All of them should be+checked by Core Lint.++1. The list of alternatives may be empty;+   See Note [Empty case alternatives]++2. The 'DEFAULT' case alternative must be first in the list,+   if it occurs at all.  Checked in GHC.Core.Lint.checkCaseAlts.++3. The remaining cases are in order of (strictly) increasing+     tag  (for 'DataAlts') or+     lit  (for 'LitAlts').+   This makes finding the relevant constructor easy, and makes+   comparison easier too.   Checked in GHC.Core.Lint.checkCaseAlts.++4. The list of alternatives must be exhaustive. An /exhaustive/ case+   does not necessarily mention all constructors:++   @+        data Foo = Red | Green | Blue+        ... case x of+              Red   -> True+              other -> f (case x of+                              Green -> ...+                              Blue  -> ... ) ...+   @++   The inner case does not need a @Red@ alternative, because @x@+   can't be @Red@ at that program point.++   This is not checked by Core Lint -- it's very hard to do so.+   E.g. suppose that inner case was floated out, thus:+         let a = case x of+                   Green -> ...+                   Blue  -> ... )+         case x of+           Red   -> True+           other -> f a+   Now it's really hard to see that the Green/Blue case is+   exhaustive.  But it is.++   If you have a case-expression that really /isn't/ exhaustive,+   we may generate seg-faults.  Consider the Green/Blue case+   above.  Since there are only two branches we may generate+   code that tests for Green, and if not Green simply /assumes/+   Blue (since, if the case is exhaustive, that's all that+   remains).  Of course, if it's not Blue and we start fetching+   fields that should be in a Blue constructor, we may die+   horribly. See also Note [Core Lint guarantee] in GHC.Core.Lint.++5. Floating-point values must not be scrutinised against literals.+   See #9238 and Note [Rules for floating-point comparisons]+   in GHC.Core.Opt.ConstantFold for rationale.  Checked in lintCaseExpr;+   see the call to isFloatingPrimTy.++6. The 'ty' field of (Case scrut bndr ty alts) is the type of the+   /entire/ case expression.  Checked in lintAltExpr.+   See also Note [Why does Case have a 'Type' field?].++7. The type of the scrutinee must be the same as the type+   of the case binder, obviously.  Checked in lintCaseExpr.++8. The multiplicity of the binders in constructor patterns must be the+   multiplicity of the corresponding field /scaled by the multiplicity of the+   case binder/. Checked in lintCoreAlt.++Note [Core type and coercion invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow a /non-recursive/, /non-top-level/ let to bind type and+coercion variables.  These can be very convenient for postponing type+substitutions until the next run of the simplifier.++* A type variable binding must have a RHS of (Type ty)++* A coercion variable binding must have a RHS of (Coercion co)++  It is possible to have terms that return a coercion, but we use+  case-binding for those; e.g.+     case (eq_sel d) of (co :: a ~# b) -> blah+  where eq_sel :: (a~b) -> (a~#b)++  Or even+      case (df @Int) of (co :: a ~# b) -> blah+  Which is very exotic, and I think never encountered; but see+  Note [Equality superclasses in quantified constraints]+  in GHC.Tc.Solver.Dict++Note [Representation polymorphism invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC allows us to abstract over calling conventions using **representation polymorphism**.+For example, we have:++  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b++In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`,+where the type variable `r :: RuntimeRep` abstracts over the runtime representation+of values of type `b`.++To ensure that programs containing representation-polymorphism remain compilable,+we enforce the following representation-polymorphism invariants:++The paper "Levity Polymorphism" [PLDI'17] states the first two invariants:++  I1. The type of a bound variable must have a fixed runtime representation+      (except for join points: See Note [Invariants on join points])+  I2. The type of a function argument must have a fixed runtime representation.++Example of I1:++  \(r::RuntimeRep). \(a::TYPE r). \(x::a). e++    This contravenes I1 because x's type has kind (TYPE r), which has 'r' free.+    We thus wouldn't know how to compile this lambda abstraction.++Example of I2:++  f (undefined :: (a :: TYPE r))++    This contravenes I2: we are applying the function `f` to a value+    with an unknown runtime representation.++Note that these two invariants require us to check other types than just the+types of bound variables and types of function arguments, due to transformations+that GHC performs. For example, the definition++  myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b+  myCoerce = coerce++is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId).+So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing+an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate):++  myCoerce = \ (x :: TYPE r) -> coerce x++However, this transformation would be invalid, because now the binding of x+in the lambda abstraction would violate I1.++See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete+and Note [Linting representation-polymorphic builtins] in GHC.Core.Lint for+more details.++Note that we currently require something slightly stronger than a fixed runtime+representation: we check whether bound variables and function arguments have a+/fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+See Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete+for an overview of how we enforce these invariants in the typechecker.++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The alternatives of a case expression should be exhaustive.  But+this exhaustive list can be empty!++* A case expression can have empty alternatives if (and only if) the+  scrutinee is bound to raise an exception or diverge. When do we know+  this?  See Note [Bottoming expressions] in GHC.Core.Utils.++* The possibility of empty alternatives is one reason we need a type on+  the case expression: if the alternatives are empty we can't get the+  type from the alternatives!++* In the case of empty types (see Note [Bottoming expressions]), say+    data T+  we do NOT want to replace+    case (x::T) of Bool {}   -->   error Bool "Inaccessible case"+  because x might raise an exception, and *that*'s what we want to see!+  (#6067 is an example.) To preserve semantics we'd have to say+     x `seq` error Bool "Inaccessible case"+  but the 'seq' is just such a case, so we are back to square 1.++* We can use the empty-alternative construct to coerce error values from+  one type to another.  For example++    f :: Int -> Int+    f n = error "urk"++    g :: Int -> (# Char, Bool #)+    g x = case f x of { 0 -> ..., n -> ... }++  Then if we inline f in g's RHS we get+    case (error Int "urk") of (# Char, Bool #) { ... }+  and we can discard the alternatives since the scrutinee is bottom to give+    case (error Int "urk") of (# Char, Bool #) {}++  This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #),+  if for no other reason that we don't need to instantiate the (~) at an+  unboxed type.++* We treat a case expression with empty alternatives as trivial iff+  its scrutinee is (see GHC.Core.Utils.exprIsTrivial).  This is actually+  important; see Note [Empty case is trivial] in GHC.Core.Utils++* We lower empty cases in GHC.CoreToStg.coreToStgExpr to an eval on the+  scrutinee.++Historical Note: We used to lower EmptyCase in CorePrep by way of an+unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when+we were beginning to eta expand in arguments, plus required to mess with+heterogenously-kinded coercions. It's simpler to stick to it just a bit longer.++Note [Join points]+~~~~~~~~~~~~~~~~~~+In Core, a *join point* is a specially tagged function whose only occurrences+are saturated tail calls. A tail call can appear in these places:++  1. In the branches (not the scrutinee) of a case+  2. Underneath a let (value or join point)+  3. Inside another join point++We write a join-point declaration as+  join j @a @b x y = e1 in e2,+like a let binding but with "join" instead (or "join rec" for "let rec"). Note+that we put the parameters before the = rather than using lambdas; this is+because it's relevant how many parameters the join point takes *as a join+point.* This number is called the *join arity,* distinct from arity because it+counts types as well as values. Note that a join point may return a lambda! So+  join j x = x + 1+is different from+  join j = \x -> x + 1+The former has join arity 1, while the latter has join arity 0.++The identifier for a join point is called a join id or a *label.* An invocation+is called a *jump.* We write a jump using the jump keyword:++  jump j 3++The words *label* and *jump* are evocative of assembly code (or Cmm) for a+reason: join points are indeed compiled as labeled blocks, and jumps become+actual jumps (plus argument passing and stack adjustment). There is no closure+allocated and only a fraction of the function-call overhead. Hence we would+like as many functions as possible to become join points (see OccurAnal) and+the type rules for join points ensure we preserve the properties that make them+efficient.++In the actual AST, a join point is indicated by the IdDetails of the binder: a+local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its+join arity.++For more details, see the paper:++  Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling+  without continuations." Submitted to PLDI'17.++  https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/++Note [Invariants on join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points must follow these invariants:++  1. All occurrences must be tail calls. Each of these tail calls must pass the+     same number of arguments, counting both types and values; we call this the+     "join arity" (to distinguish from regular arity, which only counts values).++     See Note [Join points are less general than the paper]++  2. For join arity n, the right-hand side must begin with at least n lambdas.+     No ticks, no casts, just lambdas!  C.f. GHC.Core.Utils.joinRhsArity.++     2a. Moreover, this same constraint applies to any unfolding of+         the binder.  Reason: if we want to push a continuation into+         the RHS we must push it into the unfolding as well.++     2b. The Arity (in the IdInfo) of a join point varies independently of the+         join-arity. For example, we could have+             j x = case x of { T -> \y.y; F -> \y.3 }+         Its join-arity is 1, but its idArity is 2; and we do not eta-expand+         join points: see Note [Do not eta-expand join points] in+                          GHC.Core.Opt.Simplify.Utils.++         Allowing the idArity to be bigger than the join-arity is+         important in arityType; see GHC.Core.Opt.Arity+         Note [Arity for recursive join bindings]++         Historical note: see #17294.++  3. If the binding is recursive, then all other bindings in the recursive group+     must also be join points.++  4. The binding's type must not be polymorphic in its return type (as defined+     in Note [The polymorphism rule of join points]).++However, join points have simpler invariants in other ways++  5. A join point can have an unboxed type without the RHS being+     ok-for-speculation (i.e. drop the let-can-float invariant)+     e.g.  let j :: Int# = factorial x in ...++  6. The RHS of join point is not required to have a fixed runtime representation,+     e.g.  let j :: r :: TYPE l = fail (##) in ...+     This happened in an intermediate program #13394++Examples:++  join j1  x = 1 + x in jump j (jump j x)  -- Fails 1: non-tail call+  join j1' x = 1 + x in if even a+                          then jump j1 a+                          else jump j1 a b -- Fails 1: inconsistent calls+  join j2  x = flip (+) x in j2 1 2        -- Fails 2: not enough lambdas+  join j2' x = \y -> x + y in j3 1         -- Passes: extra lams ok+  join j @a (x :: a) = x                   -- Fails 4: polymorphic in ret type++Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join+point must have an exact call as its LHS.++Strictly speaking, invariant 3 is redundant, since a call from inside a lazy+binding isn't a tail call. Since a let-bound value can't invoke a free join+point, then, they can't be mutually recursive. (A Core binding group *can*+include spurious extra bindings if the occurrence analyser hasn't run, so+invariant 3 does still need to be checked.) For the rigorous definition of+"tail call", see Section 3 of the paper (Note [Join points]).++Invariant 4 is subtle; see Note [The polymorphism rule of join points].++Invariant 6 is to enable code like this:++  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"++Core Lint will check these invariants, anticipating that any binder whose+OccInfo is marked AlwaysTailCalled will become a join point as soon as the+simplifier (or simpleOptPgm) runs.++Note [Join points are less general than the paper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the paper "Compiling without continuations", this expression is+perfectly valid:++    join { j = \_ -> e }+    in (case blah of       )+       (  True  -> j void# ) arg+       (  False -> blah    )++assuming 'j' has arity 1.   Here the call to 'j' does not look like a+tail call, but actually everything is fine. See Section 3, "Managing \Delta"+in the paper.++In GHC, however, we adopt a slightly more restrictive subset, in which+join point calls must be tail calls.  I think we /could/ loosen it up, but+in fact the simplifier ensures that we always get tail calls, and it makes+the back end a bit easier I think.  Generally, just less to think about;+nothing deeper than that.++Note [The type of a join point]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point has the same type it would have as a function. That is, if it takes+an Int and a Bool and its body produces a String, its type is `Int -> Bool ->+String`. Natural as this may seem, it can be awkward. A join point shouldn't be+thought to "return" in the same sense a function does---a jump is one-way. This+is crucial for understanding how case-of-case interacts with join points:++  case (join+          j :: Int -> Bool -> String+          j x y = ...+        in+          jump j z w) of+    "" -> True+    _  -> False++The simplifier will pull the case into the join point (see Note [Join points+and case-of-case] in GHC.Core.Opt.Simplify):++  join+    j :: Int -> Bool -> Bool -- changed!+    j x y = case ... of "" -> True+                        _  -> False+  in+    jump j z w++The body of the join point now returns a Bool, so the label `j` has to+have its type updated accordingly, which is done by+GHC.Core.Opt.Simplify.Env.adjustJoinPointType. Inconvenient though+this may be, it has the advantage that 'GHC.Core.Utils.exprType' can+still return a type for any expression, including a jump.++Relationship to the paper++This plan differs from the paper (see Note [Invariants on join+points]). In the paper, we instead give j the type `Int -> Bool ->+forall a. a`. Then each jump carries the "return type" as a parameter,+exactly the way other non-returning functions like `error` work:++  case (join+          j :: Int -> Bool -> forall a. a+          j x y = ...+        in+          jump j z w @String) of+    "" -> True+    _  -> False++Now we can move the case inward and we only have to change the jump:++  join+    j :: Int -> Bool -> forall a. a+    j x y = case ... of "" -> True+                        _  -> False+  in+    jump j z w @Bool++(Core Lint would still check that the body of the join point has the right type;+that type would simply not be reflected in the join id.)++Note [The polymorphism rule of join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant 4 of Note [Invariants on join points] forbids a join point to be+polymorphic in its return type. That is, if its type is++  forall a1 ... ak. t1 -> ... -> tn -> r++where its join arity is k+n, none of the type parameters ai may occur free in r.++In some way, this falls out of the fact that given++  join+     j @a1 ... @ak x1 ... xn = e1+  in e2++then all calls to `j` are in tail-call positions of `e`, and expressions in+tail-call positions in `e` have the same type as `e`.+Therefore the type of `e1` -- the return type of the join point -- must be the+same as the type of e2.+Since the type variables aren't bound in `e2`, its type can't include them, and+thus neither can the type of `e1`.++This unfortunately prevents the `go` in the following code from being a+join-point:++  iter :: forall a. Int -> (a -> a) -> a -> a+  iter @a n f x = go @a n f x+    where+      go :: forall a. Int -> (a -> a) -> a -> a+      go @a 0 _ x = x+      go @a n f x = go @a (n-1) f (f x)++In this case, a static argument transformation would fix that (see+ticket #14620):++  iter :: forall a. Int -> (a -> a) -> a -> a+  iter @a n f x = go' @a n f x+    where+      go' :: Int -> (a -> a) -> a -> a+      go' 0 _ x = x+      go' n f x = go' (n-1) f (f x)++In general, loopification could be employed to do that (see #14068.)++Can we simply drop the requirement, and allow `go` to be a join-point? We+could, and it would work. But we could not longer apply the case-of-join-point+transformation universally. This transformation would do:++  case (join go @a n f x = case n of 0 -> x+                                     n -> go @a (n-1) f (f x)+        in go @Bool n neg True) of+    True -> e1; False -> e2++ ===>++  join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2+                               n -> go @a (n-1) f (f x)+  in go @Bool n neg True++but that is ill-typed, as `x` is type `a`, not `Bool`.+++This also justifies why we do not consider the `e` in `e |> co` to be in+tail position: A cast changes the type, but the type must be the same. But+operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for+ideas how to fix this.++Note [Strict fields in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, evaluating a data constructor worker evaluates its strict fields.++In other words, let's say we have the following data type++  data T a b = MkT !a b++Now if `xs` reduces to `error "boom"`, then `MkT xs b` will throw that error.+Consequently, it is sound to seq the field before the call to the constructor,+e.g., with `case xs of xs' { __DEFAULT -> MkT xs' b }`.+Let's call this transformation "field eval insertion".++Note in particular that the data constructor application `MkT xs b` above is+*not* a value, unless `xs` is!++This has pervasive effect on the Core pipeline:++(SFC1) `exprIsHNF`/`exprIsConLike`/`exprOkForSpeculation` need to assert that the+    strict arguments of a DataCon worker are values/ok-for-spec themselves.++(SFC2) `exprIsConApp_maybe` inserts field evals in the `FloatBind`s it returns, so+    that the Simplifier, Constant-folding, the pattern-match checker, etc. all+    see the inserted field evals when they match on strict workers.++    For example,+      exprIsConApp_maybe (MkT e1 e2)+        = Just ([FloatCase e1 x], MkT, [x,e2])+    Meaning that (MkT e1 e2) is indeed a data constructor application, but if+    you want to decompose it (which is the purpose of exprIsConApp_maybe) you+    must evaluate e1 first.+    In case of case-of-known constructor, we get the rewrite+      case MkT e1 e2 of MkT xs' b' -> b'+      ==>+      case e1 of xs' { __DEFAULT -> e2 }+    which crucially retains the eval on e1.++(SFC3) The demand signature of a data constructor is strict in strict field+    position and lazy in non-strict fields. Likewise the demand *transformer*+    of a DataCon worker can stricten up demands on strict field args.+    See Note [Demand transformer for data constructors].++(SFC4) In the absence of `-fpedantic-bottoms`, it is still possible that some seqs+    are ultimately dropped or delayed due to eta-expansion.+    See Note [Dealing with bottom].++Strict field semantics is exploited and lowered in STG during EPT enforcement;+see Note [EPT enforcement lowers strict constructor worker semantics] for the+connection.++It might be tempting to think that strict fields could be implemented in terms+of unlifted fields. However, unlifted fields behave differently when the data+constructor is partially applied; see Note [exprIsHNF for function applications]+for an example.++Historical Note:+The delightfully simple description of strict field semantics is the result of+a long saga (#20749, the bits about strict data constructors in #21497, #22475),+where we tried a more lenient (but actually not) semantics first that would+allow both strict and lazy implementations of DataCon workers. This was favoured+because the "pervasive effect" throughout the compiler was deemed too large+(when it really turned out to be quite modest).+Alas, this semantics would require us to implement `exprIsHNF` in *exactly* the+same way as above, otherwise the analysis would not be conservative wrt. the+lenient semantics (which includes the strict one). It is also much harder to+explain and maintain, as it turned out.++************************************************************************+*                                                                      *+            In/Out type synonyms+*                                                                      *+********************************************************************* -}++{- 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 -}++-- Pre-cloning or substitution+type InBndr     = CoreBndr+type InType     = Type+type InKind     = Kind+type InBind     = CoreBind+type InExpr     = CoreExpr+type InAlt      = CoreAlt+type InArg      = CoreArg+type InCoercion = Coercion++-- Post-cloning or substitution+type OutBndr     = CoreBndr+type OutType     = Type+type OutKind     = Kind+type OutCoercion = Coercion+type OutBind     = CoreBind+type OutExpr     = CoreExpr+type OutAlt      = CoreAlt+type OutArg      = CoreArg+type MOutCoercion = MCoercion+++{-+************************************************************************+*                                                                      *+                Orphans+*                                                                      *+************************************************************************+-}++-- | Is this instance an orphan?  If it is not an orphan, contains an 'OccName'+-- witnessing the instance's non-orphanhood.+-- See Note [Orphans]+data IsOrphan+  = IsOrphan+  | NotOrphan !OccName -- The OccName 'n' witnesses the instance's non-orphanhood+                      -- In that case, the instance is fingerprinted as part+                      -- of the definition of 'n's definition+    deriving Data++-- | Returns true if 'IsOrphan' is orphan.+isOrphan :: IsOrphan -> Bool+isOrphan IsOrphan = True+isOrphan _ = False++-- | Returns true if 'IsOrphan' is not an orphan.+notOrphan :: IsOrphan -> Bool+notOrphan NotOrphan{} = True+notOrphan _ = False++chooseOrphanAnchor :: NameSet -> IsOrphan+-- Something (rule, instance) is relate to all the Names in this+-- list. Choose one of them to be an "anchor" for the orphan.  We make+-- the choice deterministic to avoid gratuitous changes in the ABI+-- hash (#4012).  Specifically, use lexicographic comparison of+-- OccName rather than comparing Uniques+--+-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically+--+chooseOrphanAnchor local_names = case nonEmpty $ nonDetEltsUniqSet local_names of+    Nothing -> IsOrphan+    Just local_names -> NotOrphan (minimum (NE.map nameOccName local_names))+    -- It's OK to use nonDetEltsUFM here, see comments above++instance Binary IsOrphan where+    put_ bh IsOrphan = putByte bh 0+    put_ bh (NotOrphan n) = do+        putByte bh 1+        put_ bh n+    get bh = do+        h <- getByte bh+        case h of+            0 -> return IsOrphan+            _ -> do+                n <- get bh+                return $ NotOrphan n++instance NFData IsOrphan where+  rnf IsOrphan = ()+  rnf (NotOrphan n) = rnf n++{-+Note [Orphans]+~~~~~~~~~~~~~~+Class instances, rules, and family instances are divided into orphans+and non-orphans.  Roughly speaking, an instance/rule is an orphan if+its left hand side mentions nothing defined in this module.  Orphan-hood+has two major consequences++ * A module that contains orphans is called an "orphan module".  If+   the module being compiled depends (transitively) on an orphan+   module M, then M.hi is read in regardless of whether M is otherwise+   needed. This is to ensure that we don't miss any instance decls in+   M.  But it's painful, because it means we need to keep track of all+   the orphan modules below us.++ * The "visible orphan modules" are all the orphan module in the transitive+   closure of the imports of this module.++ * During instance lookup, we filter orphan instances depending on+   whether or not the instance is in a visible orphan module.++ * A non-orphan is not finger-printed separately.  Instead, for+   fingerprinting purposes it is treated as part of the entity it+   mentions on the LHS.  For example+      data T = T1 | T2+      instance Eq T where ....+   The instance (Eq T) is incorporated as part of T's fingerprint.++   In contrast, orphans are all fingerprinted together in the+   mi_orph_hash field of the ModIface.++   See GHC.Iface.Recomp.addFingerprints.++Orphan-hood is computed+  * For class instances:+    when we make a ClsInst in GHC.Core.InstEnv.mkLocalClsInst+      (because it is needed during instance lookup)+    See Note [When exactly is an instance decl an orphan?]+        in GHC.Core.InstEnv++  * For rules+    when we generate a CoreRule (GHC.Core.Rules.mkRule)++  * For family instances:+    when we generate an IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)++Orphan-hood is persisted into interface files, in ClsInst, FamInst,+and CoreRules.++-}++{-+************************************************************************+*                                                                      *+\subsection{Rewrite rules}+*                                                                      *+************************************************************************++The CoreRule type and its friends are dealt with mainly in GHC.Core.Rules, but+GHC.Core.FVs, GHC.Core.Subst, GHC.Core.Ppr, GHC.Core.Tidy also inspect the+representation.+-}+++-- | A 'CoreRule' is:+--+-- * \"Local\" if the function it is a rule for is defined in the+--   same module as the rule itself.+--+-- * \"Orphan\" if nothing on the LHS is defined in the same module+--   as the rule itself+data CoreRule+  = Rule {+        ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user+        ru_act  :: Activation,          -- ^ When the rule is active++        -- Rough-matching stuff+        -- see comments with InstEnv.ClsInst( is_cls, is_rough )+        ru_fn    :: !Name,               -- ^ Name of the 'GHC.Types.Id.Id' at the head of this rule+        ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side++        -- Proper-matching stuff+        -- see comments with InstEnv.ClsInst( is_tvs, is_tys )+        ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over+        ru_args  :: [CoreExpr],         -- ^ Left hand side arguments++        -- And the right-hand side+        ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule+                                        -- Occurrence info is guaranteed correct+                                        -- See Note [OccInfo in unfoldings and rules]++        -- Locality+        ru_auto :: Bool,   -- ^ @True@  <=> this rule is auto-generated+                           --               (notably by Specialise or SpecConstr)+                           --   @False@ <=> generated at the user's behest+                           -- See Note [Trimming auto-rules] in "GHC.Iface.Tidy"+                           -- for the sole purpose of this field.++        ru_origin :: !Module,   -- ^ 'Module' the rule was defined in, used+                                -- to test if we should see an orphan rule.++        ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan.++        ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is+                                -- defined in the same module as the rule+                                -- and is not an implicit 'Id' (like a record selector,+                                -- class operation, or data constructor).  This+                                -- is different from 'ru_orphan', where a rule+                                -- can avoid being an orphan if *any* Name in+                                -- LHS of the rule was defined in the same+                                -- module as the rule.+    }++  -- | Built-in rules are used for constant folding+  -- and suchlike.  They have no free variables.+  -- A built-in rule is always visible (there is no such thing as+  -- an orphan built-in rule.)+  | BuiltinRule {+        ru_name  :: RuleName,   -- ^ As above+        ru_fn    :: Name,       -- ^ As above+        ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,+                                -- if it fires, including type arguments+        ru_try   :: RuleFun+                -- ^ This function does the rewrite.  It given too many+                -- arguments, it simply discards them; the returned 'CoreExpr'+                -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args+    }+                -- See Note [Extra args in the target] in GHC.Core.Rules++type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr++-- | The 'InScopeSet' in the 'InScopeEnv' is a /superset/ of variables that are+-- currently in scope. See Note [The InScopeSet invariant].+data InScopeEnv = ISE InScopeSet IdUnfoldingFun++type IdUnfoldingFun = Id -> Unfolding+-- A function that embodies how to unfold an Id if you need+-- to do that in the Rule.  The reason we need to pass this info in+-- is that whether an Id is unfoldable depends on the simplifier phase++isBuiltinRule :: CoreRule -> Bool+isBuiltinRule (BuiltinRule {}) = True+isBuiltinRule _                = False++isAutoRule :: CoreRule -> Bool+isAutoRule (BuiltinRule {}) = False+isAutoRule (Rule { ru_auto = is_auto }) = is_auto++-- | The number of arguments the 'ru_fn' must be applied+-- to before the rule can match on it+ruleArity :: CoreRule -> FullArgCount+ruleArity (BuiltinRule {ru_nargs = n}) = n+ruleArity (Rule {ru_args = args})      = length args++ruleName :: CoreRule -> RuleName+ruleName = ru_name++ruleModule :: CoreRule -> Maybe Module+ruleModule Rule { ru_origin } = Just ru_origin+ruleModule BuiltinRule {} = Nothing++ruleActivation :: CoreRule -> Activation+ruleActivation (BuiltinRule { })       = AlwaysActive+ruleActivation (Rule { ru_act = act }) = act++-- | The 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side+ruleIdName :: CoreRule -> Name+ruleIdName = ru_fn++isLocalRule :: CoreRule -> Bool+isLocalRule (BuiltinRule {})               = False+isLocalRule (Rule { ru_local = is_local }) = is_local++-- | Set the 'Name' of the 'GHC.Types.Id.Id' at the head of the rule left hand side+setRuleIdName :: Name -> CoreRule -> CoreRule+setRuleIdName nm ru = ru { ru_fn = nm }++{-+************************************************************************+*                                                                      *+                Unfoldings+*                                                                      *+************************************************************************++The @Unfolding@ type is declared here to avoid numerous loops++Note [Never put `OtherCon` unfoldings on lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Based on #21496 we never attach unfoldings of any kind to lambda binders.+It's just too easy for the call site to change and invalidate the unfolding.+E.g. the caller of the lambda drops a seq (e.g. because the lambda is strict in it's binder)+which in turn makes the OtherCon[] unfolding a lie.+So unfoldings on lambda binders can never really be trusted when on lambda binders if there+is the chance of the call site to change. So it's easiest to just never attach any+to lambda binders to begin with, as well as stripping them off if we e.g. float out+and expression while abstracting over some arguments.+-}++-- | Records the /unfolding/ of an identifier, which is approximately the form the+-- identifier would have if we substituted its definition in for the identifier.+-- This type should be treated as abstract everywhere except in "GHC.Core.Unfold"+data Unfolding+  = NoUnfolding        -- ^ We have no information about the unfolding.++  | BootUnfolding      -- ^ We have no information about the unfolding, because+                       -- this 'Id' came from an @hi-boot@ file.+                       -- See Note [Inlining and hs-boot files] in "GHC.CoreToIface"+                       -- for what this is used for.++  | OtherCon [AltCon]  -- ^ It ain't one of these constructors.+                       -- @OtherCon xs@ also indicates that something has been evaluated+                       -- and hence there's no point in re-evaluating it.+                       -- @OtherCon []@ is used even for non-data-type values+                       -- to indicated evaluated-ness.  Notably:+                       --+                       -- > data C = C !(Int -> Int)+                       -- > case x of { C f -> ... }+                       --+                       -- Here, @f@ gets an @OtherCon []@ unfolding.++  | DFunUnfolding {     -- The Unfolding of a DFunId+                        -- See Note [DFun unfoldings]+                        --     df = /\a1..am. \d1..dn. MkD t1 .. tk+                        --                                 (op1 a1..am d1..dn)+                        --                                 (op2 a1..am d1..dn)+        df_bndrs :: [Var],      -- The bound variables [a1..m],[d1..dn]+        df_con   :: DataCon,    -- The dictionary data constructor (never a newtype datacon)+        df_args  :: [CoreExpr]  -- Args of the data con: types, superclasses and methods,+    }                           -- in positional order++  | CoreUnfolding { -- An unfolding for an Id with no pragma,+                    -- or perhaps a NOINLINE pragma+                    -- (For NOINLINE, the phase, if any, is in the+                    -- InlinePragInfo for this Id.)+        uf_tmpl     :: CoreExpr,         -- The unfolding itself (aka "template")+                                         -- Always occ-analysed;+                                         -- See Note [OccInfo in unfoldings and rules]++        uf_src      :: UnfoldingSource,  -- Where the unfolding came from+        uf_is_top   :: Bool,             -- True <=> top level binding+        uf_cache    :: UnfoldingCache,   -- Cache of flags computable from the expr+                                         -- See Note [Tying the 'CoreUnfolding' knot]+        uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.+    }+  -- ^ An unfolding with redundant cached information. Parameters:+  --+  --  uf_tmpl: Template used to perform unfolding;+  --           NB: Occurrence info is guaranteed correct:+  --               see Note [OccInfo in unfoldings and rules]+  --+  --  uf_is_top: Is this a top level binding?+  --+  --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on+  --     this variable+  --+  --  uf_is_work_free:  Does this waste only a little work if we expand it inside an inlining?+  --     Basically this is a cached version of 'exprIsWorkFree'+  --+  --  uf_guidance:  Tells us about the /size/ of the unfolding template+++-- | Properties of a 'CoreUnfolding' that could be computed on-demand from its template.+-- See Note [UnfoldingCache]+data UnfoldingCache+  = UnfoldingCache {+        uf_is_value   :: !Bool,         -- exprIsHNF template (cached); it is ok to discard+                                        --      a `seq` on this variable+        uf_is_conlike :: !Bool,         -- True <=> applicn of constructor or CONLIKE function+                                        --      Cached version of exprIsConLike+        uf_is_work_free :: !Bool,       -- True <=> doesn't waste (much) work to expand+                                        --          inside an inlining+                                        --      Cached version of exprIsCheap+        uf_expandable :: !Bool          -- True <=> can expand in RULE matching+                                        --      Cached version of exprIsExpandable+    }+  deriving (Eq)++-- | 'UnfoldingGuidance' says when unfolding should take place+data UnfoldingGuidance+  = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl+                -- Used (a) for small *and* cheap unfoldings+                --      (b) for INLINE functions+                -- See Note [INLINE for small functions] in GHC.Core.Unfold+      ug_arity    :: Arity,     -- Number of value arguments expected++      ug_unsat_ok  :: Bool,     -- True <=> ok to inline even if unsaturated+      ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring+                -- So True,True means "always"+    }++  | UnfIfGoodArgs {     -- Arose from a normal Id; the info here is the+                        -- result of a simple analysis of the RHS++      ug_args ::  [Int],  -- Discount if the argument is evaluated.+                          -- (i.e., a simplification will definitely+                          -- be possible).  One elt of the list per *value* arg.++      ug_size :: Int,     -- The "size" of the unfolding.++      ug_res :: Int       -- Scrutinee discount: the discount to subtract if the thing is in+    }                     -- a context (case (thing args) of ...),+                          -- (where there are the right number of arguments.)++  | UnfNever        -- The RHS is big, so don't inline it+  deriving (Eq)++{- Note [UnfoldingCache]+~~~~~~~~~~~~~~~~~~~~~~~~+The UnfoldingCache field of an Unfolding holds four (strict) booleans,+all derived from the uf_tmpl field of the unfolding.++* We serialise the UnfoldingCache to and from interface files, for+  reasons described in  Note [Tying the 'CoreUnfolding' knot] in+  GHC.IfaceToCore++* Because it is a strict data type, we must be careful not to+  pattern-match on it until we actually want its values.  E.g+  GHC.Core.Unfold.callSiteInline/tryUnfolding are careful not to force+  it unnecessarily.  Just saves a bit of work.++* When `seq`ing Core to eliminate space leaks, to suffices to `seq` on+  the cache, but not its fields, because it is strict in all fields.++Note [Historical note: unfoldings for wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have a nice clever scheme in interface files for+wrappers. A wrapper's unfolding can be reconstructed from its worker's+id and its strictness. This decreased .hi file size (sometimes+significantly, for modules like GHC.Classes with many high-arity w/w+splits) and had a slight corresponding effect on compile times.++However, when we added the second demand analysis, this scheme lead to+some Core lint errors. The second analysis could change the strictness+signatures, which sometimes resulted in a wrapper's regenerated+unfolding applying the wrapper to too many arguments.++Instead of repairing the clever .hi scheme, we abandoned it in favor+of simplicity. The .hi sizes are usually insignificant (excluding the++1M for base libraries), and compile time barely increases (~+1% for+nofib). The nicer upshot is that the UnfoldingSource no longer mentions+an Id, so, eg, substitutions need not traverse them.+++Note [DFun unfoldings]+~~~~~~~~~~~~~~~~~~~~~~+The Arity in a DFunUnfolding is total number of args (type and value)+that the DFun needs to produce a dictionary.  That's not necessarily+related to the ordinary arity of the dfun Id, esp if the class has+one method, so the dictionary is represented by a newtype.  Example++     class C a where { op :: a -> Int }+     instance C a -> C [a] where op xs = op (head xs)++The instance translates to++     $dfCList :: forall a. C a => C [a]  -- Arity 2!+     $dfCList = /\a.\d. $copList {a} d |> co++     $copList :: forall a. C a => [a] -> Int  -- Arity 2!+     $copList = /\a.\d.\xs. op {a} d (head xs)++Now we might encounter (op (dfCList {ty} d) a1 a2)+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList+has all its arguments, even though its (value) arity is 2.  That's+why we record the number of expected arguments in the DFunUnfolding.++Note that although it's an Arity, it's most convenient for it to give+the *total* number of arguments, both type and value.  See the use+site in exprIsConApp_maybe.+-}++-- Constants for the UnfWhen constructor+needSaturated, unSaturatedOk :: Bool+needSaturated = False+unSaturatedOk = True++boringCxtNotOk, boringCxtOk :: Bool+boringCxtOk    = True+boringCxtNotOk = False++------------------------------------------------+noUnfolding :: Unfolding+-- ^ There is no known 'Unfolding'+evaldUnfolding :: Unfolding+-- ^ This unfolding marks the associated thing as being evaluated++noUnfolding    = NoUnfolding+evaldUnfolding = OtherCon []++-- | There is no known 'Unfolding', because this came from an+-- hi-boot file.+bootUnfolding :: Unfolding+bootUnfolding = BootUnfolding++mkOtherCon :: [AltCon] -> Unfolding+mkOtherCon = OtherCon++-- | Retrieves the template of an unfolding if possible+-- maybeUnfoldingTemplate is used mainly when specialising, and we do+-- want to specialise DFuns, so it's important to return a template+-- for DFunUnfoldings+maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr+maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })+  = Just expr+maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })+  = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args))+maybeUnfoldingTemplate _+  = Nothing++-- | The constructors that the unfolding could never be:+-- returns @[]@ if no information is available+otherCons :: Unfolding -> [AltCon]+otherCons (OtherCon cons) = cons+otherCons _               = []++-- | Determines if it is certainly the case that the unfolding will+-- yield a value (something in HNF): returns @False@ if unsure+isValueUnfolding :: Unfolding -> Bool+        -- Returns False for OtherCon+isValueUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache+isValueUnfolding (DFunUnfolding {})                   = True+isValueUnfolding _                                    = False++-- | Determines if it possibly the case that the unfolding will+-- yield a value. Unlike 'isValueUnfolding' it returns @True@+-- for 'OtherCon'+isEvaldUnfolding :: Unfolding -> Bool+        -- Returns True for OtherCon+isEvaldUnfolding (OtherCon _)                         = True+isEvaldUnfolding (DFunUnfolding {})                   = True+isEvaldUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_value cache+isEvaldUnfolding _                                    = False++-- | @True@ if the unfolding is a constructor application, the application+-- of a CONLIKE function or 'OtherCon'+isConLikeUnfolding :: Unfolding -> Bool+isConLikeUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_conlike cache+isConLikeUnfolding _                                    = False++-- | Is the thing we will unfold into certainly cheap?+isCheapUnfolding :: Unfolding -> Bool+isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache+isCheapUnfolding _                                    = False++isExpandableUnfolding :: Unfolding -> Bool+isExpandableUnfolding (CoreUnfolding { uf_cache = cache }) = uf_expandable cache+isExpandableUnfolding _                                    = False++expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr+-- Expand an expandable unfolding; this is used in rule matching+--   See Note [Expanding variables] in GHC.Core.Rules+-- The key point here is that CONLIKE things can be expanded+expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })+  | uf_expandable cache+    = Just rhs+expandUnfolding_maybe _ = Nothing++isCompulsoryUnfolding :: Unfolding -> Bool+isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src+isCompulsoryUnfolding _                                = False++isStableUnfolding :: Unfolding -> Bool+-- True of unfoldings that should not be overwritten+-- by a CoreUnfolding for the RHS of a let-binding+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src+isStableUnfolding (DFunUnfolding {})               = True+isStableUnfolding _                                = False++isStableUserUnfolding :: Unfolding -> Bool+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma+isStableUserUnfolding (CoreUnfolding { uf_src = src }) = isStableUserSource src+isStableUserUnfolding _                                = False++isStableSystemUnfolding :: Unfolding -> Bool+-- True of unfoldings that arise from an INLINE or INLINEABLE pragma+isStableSystemUnfolding (CoreUnfolding { uf_src = src }) = isStableSystemSource src+isStableSystemUnfolding _                                = False++isInlineUnfolding :: Unfolding -> Bool+-- ^ True of a /stable/ unfolding that is+--   (a) always inlined; that is, with an `UnfWhen` guidance, or+--   (b) a DFunUnfolding which never needs to be inlined+isInlineUnfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })+  | isStableSource src+  , UnfWhen {} <- guidance+  = True++isInlineUnfolding (DFunUnfolding {})+  = True++-- Default case+isInlineUnfolding _ = False+++-- | Only returns False if there is no unfolding information available at all+hasSomeUnfolding :: Unfolding -> Bool+hasSomeUnfolding NoUnfolding   = False+hasSomeUnfolding BootUnfolding = False+hasSomeUnfolding _             = True++isBootUnfolding :: Unfolding -> Bool+isBootUnfolding BootUnfolding = True+isBootUnfolding _             = False++neverUnfoldGuidance :: UnfoldingGuidance -> Bool+neverUnfoldGuidance UnfNever = True+neverUnfoldGuidance _        = False++hasCoreUnfolding :: Unfolding -> Bool+-- An unfolding "has Core" if it contains a Core expression, which+-- may mention free variables. See Note [Fragile unfoldings]+hasCoreUnfolding (CoreUnfolding {}) = True+hasCoreUnfolding (DFunUnfolding {}) = True+hasCoreUnfolding _                  = False+  -- NoUnfolding, BootUnfolding, OtherCon have no Core++canUnfold :: Unfolding -> Bool+canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)+canUnfold _                                   = False++isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool+-- See Note [Better unfolding]+isBetterUnfoldingThan NoUnfolding   _ = False+isBetterUnfoldingThan BootUnfolding _ = False++isBetterUnfoldingThan (CoreUnfolding {uf_cache = uc1}) unf2+  = case unf2 of+      CoreUnfolding {uf_cache = uc2} -> uf_is_value uc1 && not (uf_is_value uc2)+      OtherCon _                     -> uf_is_value uc1+      _                              -> True+         -- Default case: CoreUnfolding better than NoUnfolding etc+         -- Better than DFunUnfolding? I don't care.++isBetterUnfoldingThan (DFunUnfolding {}) unf2+  | DFunUnfolding {} <- unf2 = False+  | otherwise                = True++isBetterUnfoldingThan (OtherCon cs1) unf2+  = case unf2 of+      CoreUnfolding {uf_cache = uc}             -- If unf1 is OtherCon and unf2 is+                       -> not (uf_is_value uc)  -- just a thunk, unf1 is better++      OtherCon cs2     -> not (null cs1) && null cs2  -- A bit crude+      DFunUnfolding {} -> False+      NoUnfolding      -> True+      BootUnfolding    -> True++{- Note [Fragile unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An unfolding is "fragile" if it mentions free variables (and hence would+need substitution) or might be affected by optimisation.  The non-fragile+ones are++   NoUnfolding, BootUnfolding++   OtherCon {}    If we know this binder (say a lambda binder) will be+                  bound to an evaluated thing, we want to retain that+                  info in simpleOptExpr; see #13077.++We consider even a StableUnfolding as fragile, because it needs substitution.++Note [Better unfolding]+~~~~~~~~~~~~~~~~~~~~~~~+(unf1 `isBetterUnfoldingThan` unf2) is used when we have+    let x = <rhs> in   -- unf2+    let $j y = ...x...+    in case x of+          K a -> ...$j v....++At the /call site/ of $j, `x` has a better unfolding than it does at the+/defnition site/ of $j; so we are keener to inline $j.  See+Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion.++The notion of "better" is encapsulated here.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+When you say+      {-# INLINE f #-}+      f x = <rhs>+you intend that calls (f e) are replaced by <rhs>[e/x] So we+should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle+with it.  Meanwhile, we can optimise <rhs> to our heart's content,+leaving the original unfolding intact in Unfolding of 'f'. For example+        all xs = foldr (&&) True xs+        any p = all . map p  {-# INLINE any #-}+We optimise any's RHS fully, but leave the stable unfolding for `any`+saying "all . map p", which deforests well at the call site.++So INLINE pragma gives rise to a stable unfolding, which captures the+original RHS.++Moreover, it's only used when 'f' is applied to the+specified number of arguments; that is, the number of argument on+the LHS of the '=' sign in the original source definition.+For example, (.) is now defined in the libraries like this+   {-# INLINE (.) #-}+   (.) f g = \x -> f (g x)+so that it'll inline when applied to two arguments. If 'x' appeared+on the left, thus+   (.) f g x = f (g x)+it'd only inline when applied to three arguments.  This slightly-experimental+change was requested by Roman, but it seems to make sense.++Note [OccInfo in unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In unfoldings and rules, we guarantee that the template is occ-analysed, so+that the occurrence info on the binders is correct. That way, when the+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.+(The Simplifier is designed to simplify occ-analysed expressions.)++Given this decision it's vital that we do *always* do it.++* If we don't, we may get more simplifier iterations than necessary,+  because once-occ info isn't there++* More seriously, we may get an infinite loop if there's a Rec without a+  loop breaker marked.++* Or we may get code that mentions variables not in scope: #22761+  e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3+  Then the pre-simplifier occ-anal will occ-anal the unfolding+  (redundantly perhaps, but we need its free vars); this will not report+  the use of `p`; so p's binding will be discarded, and yet `p` is still+  mentioned.++  Better to occ-anal the unfolding at birth, which will drop the+  z-binding as dead code.  (Remember, it's the occurrence analyser that+  drops dead code.)++* Another example is #8892:+    \x -> letrec { f = ...g...; g* = f } in body+  where g* is (for some strange reason) the loop breaker.  If we don't+  occ-anal it when reading it in, we won't mark g as a loop breaker, and we+  may inline g entirely in body, dropping its binding, and leaving the+  occurrence in f out of scope. This happened in #8892, where the unfolding+  in question was a DFun unfolding.+++************************************************************************+*                                                                      *+                  AltCon+*                                                                      *+************************************************************************+-}++-- The Ord is needed for the FiniteMap used in the lookForConstructor+-- in GHC.Core.Opt.Simplify.Env.  If you declared that lookForConstructor+-- *ignores* constructor-applications with LitArg args, then you could get rid+-- of this Ord.++instance Outputable AltCon where+  ppr (DataAlt dc) = ppr dc+  ppr (LitAlt lit) = ppr lit+  ppr DEFAULT      = text "__DEFAULT"++cmpAlt :: Alt a -> Alt a -> Ordering+cmpAlt (Alt con1 _ _) (Alt con2 _ _) = con1 `cmpAltCon` con2++ltAlt :: Alt a -> Alt a -> Bool+ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT++cmpAltCon :: AltCon -> AltCon -> Ordering+-- ^ Compares 'AltCon's within a single list of alternatives+-- DEFAULT comes out smallest, so that sorting by AltCon puts+-- alternatives in the order required: see Note [Case expression invariants]+cmpAltCon DEFAULT      DEFAULT     = EQ+cmpAltCon DEFAULT      _           = LT++cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2+cmpAltCon (DataAlt _)  DEFAULT      = GT+cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2+cmpAltCon (LitAlt _)   DEFAULT      = GT++cmpAltCon con1 con2 = pprPanic "cmpAltCon" (ppr con1 $$ ppr con2)++{-+************************************************************************+*                                                                      *+\subsection{Useful synonyms}+*                                                                      *+************************************************************************++Note [CoreProgram]+~~~~~~~~~~~~~~~~~~+The top level bindings of a program, a CoreProgram, are represented as+a list of CoreBind++ * Later bindings in the list can refer to earlier ones, but not vice+   versa.  So this is OK+      NonRec { x = 4 }+      Rec { p = ...q...x...+          ; q = ...p...x }+      Rec { f = ...p..x..f.. }+      NonRec { g = ..f..q...x.. }+   But it would NOT be ok for 'f' to refer to 'g'.++ * The occurrence analyser does strongly-connected component analysis+   on each Rec binding, and splits it into a sequence of smaller+   bindings where possible.  So the program typically starts life as a+   single giant Rec, which is then dependency-analysed into smaller+   chunks.+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+type CoreProgram = [CoreBind]   -- See Note [CoreProgram]++-- | The common case for the type of binders and variables when+-- we are manipulating the Core language within GHC+type CoreBndr = Var+-- | Expressions where binders are 'CoreBndr's+type CoreExpr = Expr CoreBndr+-- | Argument expressions where binders are 'CoreBndr's+type CoreArg  = Arg  CoreBndr+-- | Binding groups where binders are 'CoreBndr's+type CoreBind = Bind CoreBndr+-- | Case alternatives where binders are 'CoreBndr's+type CoreAlt  = Alt  CoreBndr++{-+************************************************************************+*                                                                      *+\subsection{Tagging}+*                                                                      *+************************************************************************+-}++-- | Binders are /tagged/ with a t+data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"++type TaggedBind t = Bind (TaggedBndr t)+type TaggedExpr t = Expr (TaggedBndr t)+type TaggedArg  t = Arg  (TaggedBndr t)+type TaggedAlt  t = Alt  (TaggedBndr t)++instance Outputable b => Outputable (TaggedBndr b) where+  ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'++deTagExpr :: TaggedExpr t -> CoreExpr+deTagExpr (Var v)                   = Var v+deTagExpr (Lit l)                   = Lit l+deTagExpr (Type ty)                 = Type ty+deTagExpr (Coercion co)             = Coercion co+deTagExpr (App e1 e2)               = App (deTagExpr e1) (deTagExpr e2)+deTagExpr (Lam (TB b _) e)          = Lam b (deTagExpr e)+deTagExpr (Let bind body)           = Let (deTagBind bind) (deTagExpr body)+deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)+deTagExpr (Tick t e)                = Tick t (deTagExpr e)+deTagExpr (Cast e co)               = Cast (deTagExpr e) co++deTagBind :: TaggedBind t -> CoreBind+deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)+deTagBind (Rec prs)             = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]++deTagAlt :: TaggedAlt t -> CoreAlt+deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs)++{-+************************************************************************+*                                                                      *+\subsection{Core-constructing functions with checking}+*                                                                      *+************************************************************************+-}++-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to+-- use 'GHC.Core.Make.mkCoreApps' if possible+mkApps    :: Expr b -> [Arg b]  -> Expr b+-- | Apply a list of type argument expressions to a function expression in a nested fashion+mkTyApps  :: Expr b -> [Type]   -> Expr b+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion+mkCoApps  :: Expr b -> [Coercion] -> Expr b+-- | Apply a list of type or value variables to a function expression in a nested fashion+mkVarApps :: Expr b -> [Var] -> Expr b+-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to+-- use 'GHC.Core.Make.mkCoreConApps' if possible+mkConApp      :: DataCon -> [Arg b] -> Expr b++mkApps    f args = foldl' App                       f args+mkCoApps  f args = foldl' (\ e a -> App e (Coercion a)) f args+mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars+mkConApp con args = mkApps (Var (dataConWorkId con)) args++mkTyApps  f args = foldl' (\ e a -> App e (mkTyArg a)) f args++mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b+mkConApp2 con tys arg_ids = Var (dataConWorkId con)+                            `mkApps` map Type tys+                            `mkApps` map varToCoreExpr arg_ids++mkTyArg :: Type -> Expr b+mkTyArg ty+  | Just co <- isCoercionTy_maybe ty = Coercion co+  | otherwise                        = Type ty++-- | Create a machine integer literal expression of type @Int#@ from an @Integer@.+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'+mkIntLit :: Platform -> Integer -> Expr b+mkIntLit platform n = Lit (mkLitInt platform n)++-- | Create a machine integer literal expression of type @Int#@ from an+-- @Integer@, wrapping if necessary.+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'+mkIntLitWrap :: Platform -> Integer -> Expr b+mkIntLitWrap platform n = Lit (mkLitIntWrap platform n)++-- | Create a machine word literal expression of type  @Word#@ from an @Integer@.+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'+mkWordLit :: Platform -> Integer -> Expr b+mkWordLit platform w = Lit (mkLitWord platform w)++-- | Create a machine word literal expression of type  @Word#@ from an+-- @Integer@, wrapping if necessary.+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'+mkWordLitWrap :: Platform -> Integer -> Expr b+mkWordLitWrap platform w = Lit (mkLitWordWrap platform w)++mkWord8Lit :: Integer -> Expr b+mkWord8Lit    w = Lit (mkLitWord8 w)++mkWord32LitWord32 :: Word32 -> Expr b+mkWord32LitWord32 w = Lit (mkLitWord32 (toInteger w))++mkWord64LitWord64 :: Word64 -> Expr b+mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))++mkInt64LitInt64 :: Int64 -> Expr b+mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w))++-- | Create a machine character literal expression of type @Char#@.+-- If you want an expression of type @Char@ use 'GHC.Core.Make.mkCharExpr'+mkCharLit :: Char -> Expr b+-- | Create a machine string literal expression of type @Addr#@.+-- If you want an expression of type @String@ use 'GHC.Core.Make.mkStringExpr'+mkStringLit :: String -> Expr b++mkCharLit   c = Lit (mkLitChar c)+mkStringLit s = Lit (mkLitString s)++-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.+-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr'+mkFloatLit :: Rational -> Expr b+-- | Create a machine single precision literal expression of type @Float#@ from a @Float@.+-- If you want an expression of type @Float@ use 'GHC.Core.Make.mkFloatExpr'+mkFloatLitFloat :: Float -> Expr b++mkFloatLit      f = Lit (mkLitFloat f)+mkFloatLitFloat f = Lit (mkLitFloat (toRational f))++-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.+-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr'+mkDoubleLit :: Rational -> Expr b+-- | Create a machine double precision literal expression of type @Double#@ from a @Double@.+-- If you want an expression of type @Double@ use 'GHC.Core.Make.mkDoubleExpr'+mkDoubleLitDouble :: Double -> Expr b++mkDoubleLit       d = Lit (mkLitDouble d)+mkDoubleLitDouble d = Lit (mkLitDouble (toRational d))++-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes+-- that the rhs satisfies the let-can-float invariant.  Prefer to use+-- 'GHC.Core.Make.mkCoreLets' if possible, which does guarantee the invariant+mkLets        :: [Bind b] -> Expr b -> Expr b+-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to+-- use 'GHC.Core.Make.mkCoreLams' if possible+mkLams        :: [b] -> Expr b -> Expr b++mkLams binders body = foldr Lam body binders+mkLets binds body   = foldr mkLet body binds++mkLet :: Bind b -> Expr b -> Expr b+-- The desugarer sometimes generates an empty Rec group+-- which Lint rejects, so we kill it off right away+mkLet (Rec []) body = body+mkLet bind     body = Let bind body++-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@.+mkLetNonRec :: b -> Expr b -> Expr b -> Expr b+mkLetNonRec b rhs body = Let (NonRec b rhs) body++-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of+-- @binds@ if binds is non-empty.+mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b+mkLetRec [] body = body+mkLetRec bs body = Let (Rec bs) body++-- | Create a binding group where a type variable is bound to a type.+-- Per Note [Core type and coercion invariant],+-- this can only be used to bind something in a non-recursive @let@ expression+mkTyBind :: TyVar -> Type -> CoreBind+mkTyBind tv ty      = NonRec tv (Type ty)++-- | Create a binding group where a type variable is bound to a type.+-- Per Note [Core type and coercion invariant],+-- this can only be used to bind something in a non-recursive @let@ expression+mkCoBind :: CoVar -> Coercion -> CoreBind+mkCoBind cv co      = NonRec cv (Coercion co)++-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately+varToCoreExpr :: CoreBndr -> Expr b+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)+                | isCoVar v = Coercion (mkCoVarCo v)+                | otherwise = assert (isId v) $ Var v++varsToCoreExprs :: [CoreBndr] -> [Expr b]+varsToCoreExprs vs = map varToCoreExpr vs++{-+************************************************************************+*                                                                      *+   Getting a result type+*                                                                      *+************************************************************************++These are defined here to avoid a module loop between GHC.Core.Utils and GHC.Core.FVs++-}++-- | If the expression is a 'Type', converts. Otherwise,+-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'.+exprToType :: CoreExpr -> Type+exprToType (Type ty)     = ty+exprToType _bad          = pprPanic "exprToType" empty++{-+************************************************************************+*                                                                      *+\subsection{Simple access functions}+*                                                                      *+************************************************************************+-}++-- | Extract every variable by this group+bindersOf  :: Bind b -> [b]+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+bindersOf (NonRec binder _) = [binder]+bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]++-- | 'bindersOf' applied to a list of binding groups+bindersOfBinds :: [Bind b] -> [b]+bindersOfBinds binds = foldr ((++) . bindersOf) [] binds++-- We inline this to avoid unknown function calls.+{-# INLINE foldBindersOfBindStrict #-}+foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a+foldBindersOfBindStrict f+  = \z bind -> case bind of+      NonRec b _rhs -> f z b+      Rec pairs -> foldl' f z $ map fst pairs++{-# INLINE foldBindersOfBindsStrict #-}+foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a+foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds+  where+    fold_bind = (foldBindersOfBindStrict f)+++rhssOfBind :: Bind b -> [Expr b]+rhssOfBind (NonRec _ rhs) = [rhs]+rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]++rhssOfBinds :: [Bind b] -> [Expr b]+rhssOfBinds []             = []+rhssOfBinds (NonRec _ rhs : bs) = rhs : rhssOfBinds bs+rhssOfBinds (Rec pairs    : bs) = map snd pairs ++ rhssOfBinds bs++rhssOfAlts :: [Alt b] -> [Expr b]+rhssOfAlts alts = [e | Alt _ _ e <- alts]++-- | Collapse all the bindings in the supplied groups into a single+-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group+flattenBinds :: [Bind b] -> [(b, Expr b)]+flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds+flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds+flattenBinds []                   = []++-- | We often want to strip off leading lambdas before getting down to+-- business. Variants are 'collectTyBinders', 'collectValBinders',+-- and 'collectTyAndValBinders'+collectBinders         :: Expr b   -> ([b],     Expr b)+collectTyBinders       :: CoreExpr -> ([TyVar], CoreExpr)+collectValBinders      :: CoreExpr -> ([Id],    CoreExpr)+collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)++-- | Strip off exactly N leading lambdas (type or value).+-- Good for use with join points.+-- Panic if there aren't enough+collectNBinders :: JoinArity -> Expr b -> ([b], Expr b)++collectBinders expr+  = go [] expr+  where+    go bs (Lam b e) = go (b:bs) e+    go bs e          = (reverse bs, e)++collectTyBinders expr+  = go [] expr+  where+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e+    go tvs e                     = (reverse tvs, e)++collectValBinders expr+  = go [] expr+  where+    go ids (Lam b e) | isId b = go (b:ids) e+    go ids body               = (reverse ids, body)++collectTyAndValBinders expr+  = (tvs, ids, body)+  where+    (tvs, body1) = collectTyBinders expr+    (ids, body)  = collectValBinders body1++collectNBinders orig_n orig_expr+  = go orig_n [] orig_expr+  where+    go 0 bs expr      = (reverse bs, expr)+    go n bs (Lam b e) = go (n-1) (b:bs) e+    go _ _  _         = pprPanic "collectNBinders" $ int orig_n++-- | Strip off exactly N leading value lambdas+-- returning all the binders found up to that point+-- Return Nothing if there aren't enough+collectNValBinders_maybe :: Arity -> CoreExpr -> Maybe ([Var], CoreExpr)+collectNValBinders_maybe orig_n orig_expr+  = go orig_n [] orig_expr+  where+    go 0 bs expr      = Just (reverse bs, expr)+    go n bs (Lam b e) | isId b    = go (n-1) (b:bs) e+                      | otherwise = go n     (b:bs) e+    go _ _  _         = Nothing++-- | Takes a nested application expression and returns the function+-- being applied and the arguments to which it is applied+collectArgs :: Expr b -> (Expr b, [Arg b])+collectArgs expr+  = go expr []+  where+    go (App f a) as = go f (a:as)+    go e         as = (e, as)++-- | Takes a nested application expression and returns the function+-- being applied and the arguments to which it is applied+collectValArgs :: Expr b -> (Expr b, [Arg b])+collectValArgs expr+  = go expr []+  where+    go (App f a) as+      | isValArg a  = go f (a:as)+      | otherwise   = go f as+    go e         as = (e, as)++-- | Takes a nested application expression and returns the function+-- being applied. Looking through casts and ticks to find it.+collectFunSimple :: Expr b -> Expr b+collectFunSimple expr+  = go expr+  where+    go expr' =+      case expr' of+        App f _a    -> go f+        Tick _t e   -> go e+        Cast e _co  -> go e+        e           -> e++-- | fmap on the body of a lambda.+--   wrapLamBody f (\x -> body) == (\x -> f body)+wrapLamBody :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr+wrapLamBody f expr = go expr+  where+  go (Lam v body) = Lam v $ go body+  go expr = f expr++-- | Attempt to remove the last N arguments of a function call.+-- Strip off any ticks or coercions encountered along the way and any+-- at the end.+stripNArgs :: Word -> Expr a -> Maybe (Expr a)+stripNArgs !n (Tick _ e) = stripNArgs n e+stripNArgs n (Cast f _) = stripNArgs n f+stripNArgs 0 e = Just e+stripNArgs n (App f _) = stripNArgs (n - 1) f+stripNArgs _ _ = Nothing++-- | Like @collectArgs@, but also looks through floatable+-- ticks if it means that we can find more arguments.+collectArgsTicks :: (CoreTickish -> Bool) -> Expr b+                 -> (Expr b, [Arg b], [CoreTickish])+collectArgsTicks skipTick expr+  = go expr [] []+  where+    go (App f a)  as ts = go f (a:as) ts+    go (Tick t e) as ts+      | skipTick t      = go e as (t:ts)+    go e          as ts = (e, as, reverse ts)+++{-+************************************************************************+*                                                                      *+\subsection{Predicates}+*                                                                      *+************************************************************************++At one time we optionally carried type arguments through to runtime.+@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,+i.e. if type applications are actual lambdas because types are kept around+at runtime.  Similarly isRuntimeArg.+-}++-- | Will this variable exist at runtime?+isRuntimeVar :: Var -> Bool+isRuntimeVar = isId++-- | Will this argument expression exist at runtime?+isRuntimeArg :: CoreExpr -> Bool+isRuntimeArg = isValArg++-- | Returns @True@ for value arguments, false for type args+-- NB: coercions are value arguments (zero width, to be sure,+-- like State#, but still value args).+isValArg :: Expr b -> Bool+isValArg e = not (isTypeArg e)++-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'+-- expression at its top level+isTyCoArg :: Expr b -> Bool+isTyCoArg (Type {})     = True+isTyCoArg (Coercion {}) = True+isTyCoArg _             = False++-- | Returns @True@ iff the expression is a 'Coercion'+-- expression at its top level+isCoArg :: Expr b -> Bool+isCoArg (Coercion {}) = True+isCoArg _             = False++-- | Returns @True@ iff the expression is a 'Type' expression at its+-- top level.  Note this does NOT include 'Coercion's.+isTypeArg :: Expr b -> Bool+isTypeArg (Type {}) = True+isTypeArg _         = False++-- | The number of binders that bind values rather than types+valBndrCount :: [CoreBndr] -> Int+valBndrCount = count isId++-- | The number of argument expressions that are values rather than types at their top level+valArgCount :: [Arg b] -> Int+valArgCount = count isValArg++{-+************************************************************************+*                                                                      *+\subsection{Annotated core}+*                                                                      *+************************************************************************+-}++-- | Annotated core: allows annotation at every node in the tree+type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)++-- | A clone of the 'Expr' type but allowing annotation at every tree node+data AnnExpr' bndr annot+  = AnnVar      Id+  | AnnLit      Literal+  | AnnLam      bndr (AnnExpr bndr annot)+  | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)+  | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]+  | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)+  | AnnCast     (AnnExpr bndr annot) (annot, Coercion)+                   -- Put an annotation on the (root of) the coercion+  | AnnTick     CoreTickish (AnnExpr bndr annot)+  | AnnType     Type+  | AnnCoercion Coercion++-- | A clone of the 'Alt' type but allowing annotation at every tree node+data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot)++-- | A clone of the 'Bind' type but allowing annotation at every tree node+data AnnBind bndr annot+  = AnnNonRec bndr (AnnExpr bndr annot)+  | AnnRec    [(bndr, AnnExpr bndr annot)]++-- | Takes a nested application expression and returns the function+-- being applied and the arguments to which it is applied+collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])+collectAnnArgs expr+  = go expr []+  where+    go (_, AnnApp f a) as = go f (a:as)+    go e               as = (e, as)++collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a+                       -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])+collectAnnArgsTicks tickishOk expr+  = go expr [] []+  where+    go (_, AnnApp f a)  as ts = go f (a:as) ts+    go (_, AnnTick t e) as ts | tickishOk t+                              = go e as (t:ts)+    go e                as ts = (e, as, reverse ts)++deAnnotate :: AnnExpr bndr annot -> Expr bndr+deAnnotate (_, e) = deAnnotate' e++deAnnotate' :: AnnExpr' bndr annot -> Expr bndr+deAnnotate' (AnnType t)           = Type t+deAnnotate' (AnnCoercion co)      = Coercion co+deAnnotate' (AnnVar  v)           = Var v+deAnnotate' (AnnLit  lit)         = Lit lit+deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)+deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)+deAnnotate' (AnnCast e (_,co))    = Cast (deAnnotate e) co+deAnnotate' (AnnTick tick body)   = Tick tick (deAnnotate body)++deAnnotate' (AnnLet bind body)+  = Let (deAnnBind bind) (deAnnotate body)+deAnnotate' (AnnCase scrut v t alts)+  = Case (deAnnotate scrut) v t (map deAnnAlt alts)++deAnnAlt :: AnnAlt bndr annot -> Alt bndr+deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs)++deAnnBind  :: AnnBind b annot -> Bind b+deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)+deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]++-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'+collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)+collectAnnBndrs e+  = collect [] e+  where+    collect bs (_, AnnLam b body) = collect (b:bs) body+    collect bs body               = (reverse bs, body)++-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr'+collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)+collectNAnnBndrs orig_n e+  = collect orig_n [] e+  where+    collect 0 bs body               = (reverse bs, body)+    collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body+    collect _ _  _                  = pprPanic "collectNBinders" $ int orig_n
+ GHC/Core.hs-boot view
@@ -0,0 +1,9 @@+{-# LANGUAGE NoPolyKinds #-}+module GHC.Core where+import {-# SOURCE #-} GHC.Types.Var++data Expr a++type CoreBndr = Var++type CoreExpr = Expr CoreBndr
+ GHC/Core/Class.hs view
@@ -0,0 +1,405 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+-- The @Class@ datatype++++module GHC.Core.Class (+        Class,+        ClassOpItem,+        ClassATItem(..), TyFamEqnValidityInfo(..),+        ClassMinimalDef,+        DefMethInfo, pprDefMethInfo,++        FunDep, pprFundeps, pprFunDep,++        mkClass, mkAbstractClass, classTyVars, classArity,+        classKey, className, classATs, classATItems, classTyCon, classMethods,+        classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,+        classHasSCs, classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef,+        classHasFds,++        -- Predicates+        -- NB: other isXXlass predicates are defined in GHC.Core.Predicate+        --     to avoid module loops+        isAbstractClass+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, PredType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType )+import GHC.Hs.Extension (GhcRn)+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Types.SrcLoc+import GHC.Types.Var.Set+import GHC.Utils.Outputable+import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue )++import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection[Class-basic]{@Class@: basic definition}+*                                                                      *+************************************************************************++A @Class@ corresponds to a Greek kappa in the static semantics:+-}++data Class+  = Class {+        classTyCon :: TyCon,    -- The data type constructor for+                                -- dictionaries of this class+                                -- See Note [ATyCon for classes] in GHC.Core.TyCo.Rep++        className :: Name,              -- Just the cached name of the TyCon+        classKey  :: Unique,            -- Cached unique of TyCon++        classTyVars  :: [TyVar],        -- The class kind and type variables;+                                        -- identical to those of the TyCon+           -- If you want visibility info, look at the classTyCon+           -- This field is redundant because it's duplicated in the+           -- classTyCon, but classTyVars is used quite often, so maybe+           -- it's a bit faster to cache it here++        classFunDeps :: [FunDep TyVar],  -- The functional dependencies++        classBody :: ClassBody -- Superclasses, ATs, methods++     }++--  | e.g.+--+-- >  class C a b c | a b -> c, a c -> b where...+--+--  Here fun-deps are [([a,b],[c]), ([a,c],[b])]+type FunDep a = ([a],[a])++type ClassOpItem = (Id, DefMethInfo)+        -- Selector function; contains unfolding+        -- Default-method info++type DefMethInfo = Maybe (Name, DefMethSpec Type)+   -- Nothing                    No default method+   -- Just ($dm, VanillaDM)      A polymorphic default method, name $dm+   -- Just ($gm, GenericDM ty)   A generic default method, name $gm, type ty+   --                              The generic dm type is *not* quantified+   --                              over the class variables; ie has the+   --                              class variables free++data ClassATItem+  = ATI TyCon         -- See Note [Associated type tyvar names]+        (Maybe (Type, TyFamEqnValidityInfo))+          -- ^ Default associated type (if any) from this template.+          --+          -- As per Note [Associated type defaults], the Type has been renamed+          -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses+          -- the original user-written type variables.++-- | Information about a type family equation, used for validity checking+-- of closed type family equations and associated type family default equations.+--+-- This type exists to delay validity-checking after typechecking type declaration+-- groups, to avoid cyclic evaluation inside the typechecking knot.+--+-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".+data TyFamEqnValidityInfo+  -- | Used for equations which don't need any validity checking,+  -- for example equations imported from another module.+  = NoVI++  -- | Information necessary for validity checking of a type family equation.+  | VI+    { vi_loc :: SrcSpan+    , vi_qtvs :: [TcTyVar]+      -- ^ LHS quantified type variables+    , vi_non_user_tvs :: TyVarSet+      -- ^ non-user-written type variables (for error message reporting)+      --+      -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@+      -- introduces the kind variable @k@ for the kind of @a@. See #23734.+    , vi_pats :: [Type]+      -- ^ LHS patterns+    , vi_rhs :: Type+      -- ^ RHS of the equation+      --+      -- NB: for associated type family default declarations, this is the RHS+      -- *before* applying the substitution from+      -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl.+    }++type ClassMinimalDef = BooleanFormula GhcRn -- Required methods++data ClassBody+  = AbstractClass+  | ConcreteClass {+        -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)+        -- We need value-level selectors for both the dictionary+        -- superclasses and the equality superclasses+        cls_sc_theta :: [PredType],     -- Immediate superclasses,+        cls_sc_sel_ids :: [Id],          -- Selector functions to extract the+                                        --   superclasses from a+                                        --   dictionary of this class+        -- Associated types+        cls_ats :: [ClassATItem],  -- Associated type families++        -- Class operations (methods, not superclasses)+        cls_ops :: [ClassOpItem],  -- Ordered by tag++        -- Minimal complete definition+        cls_min_def :: ClassMinimalDef+    }+    -- TODO: maybe super classes should be allowed in abstract class definitions++classMinimalDef :: Class -> ClassMinimalDef+classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d+classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction++{-+Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following is an example of associated type defaults:+   class C a where+     data D a r++     type F x a b :: *+     type F p q r = (p,q)->r    -- Default++Note that++ * The TyCons for the associated types *share type variables* with the+   class, so that we can tell which argument positions should be+   instantiated in an instance decl.  (The first for 'D', the second+   for 'F'.)++ * We can have default definitions only for *type* families,+   not data families++ * In the default decl, the "patterns" should all be type variables,+   but (in the source language) they don't need to be the same as in+   the 'type' decl signature or the class.  It's more like a+   free-standing 'type instance' declaration.++ * HOWEVER, in the internal ClassATItem we rename the RHS to match the+   tyConTyVars of the family TyCon.  So in the example above we'd get+   a ClassATItem of++        ATI F (Just ((x,a) -> b, validity_info)++   That is, the type stored in the first component of the pair has been+   renamed to use the class type variables. On the other hand, the+   TyFamEqnValidityInfo, used for validity checking of the type family equation+   (considered as a free-standing equation) uses the original types, e.g.+   involving the type variables 'p', 'q', 'r'.++The @mkClass@ function fills in the indirect superclasses.++The SrcSpan is for the entire original declaration.+-}++mkClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> [PredType] -> [Id]+        -> [ClassATItem]+        -> [ClassOpItem]+        -> ClassMinimalDef+        -> TyCon+        -> Class++mkClass cls_name tyvars fds super_classes superdict_sels at_stuff+        op_stuff mindef tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = ConcreteClass {+                    cls_sc_theta = super_classes,+                    cls_sc_sel_ids = superdict_sels,+                    cls_ats  = at_stuff,+                    cls_ops  = op_stuff,+                    cls_min_def = mindef+                },+            classTyCon   = tycon }++mkAbstractClass :: Name -> [TyVar]+        -> [FunDep TyVar]+        -> TyCon+        -> Class++mkAbstractClass cls_name tyvars fds tycon+  = Class { classKey     = nameUnique cls_name,+            className    = cls_name,+                -- NB:  tyConName tycon = cls_name,+                -- But it takes a module loop to assert it here+            classTyVars  = tyvars,+            classFunDeps = fds,+            classBody = AbstractClass,+            classTyCon   = tycon }++{-+Note [Associated type tyvar names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TyCon of an associated type should use the same variable names as its+parent class. Thus+    class C a b where+      type F b x a :: *+We make F use the same Name for 'a' as C does, and similarly 'b'.++The reason for this is when checking instances it's easier to match+them up, to ensure they match.  Eg+    instance C Int [d] where+      type F [d] x Int = ....+we should make sure that the first and third args match the instance+header.++Having the same variables for class and tycon is also used in checkValidRoles+(in GHC.Tc.TyCl) when checking a class's roles.+++************************************************************************+*                                                                      *+\subsection[Class-selectors]{@Class@: simple selectors}+*                                                                      *+************************************************************************++The rest of these functions are just simple selectors.+-}++classArity :: Class -> Arity+classArity clas = length (classTyVars clas)+        -- Could memoise this++classAllSelIds :: Class -> [Id]+-- Both superclass-dictionary and method selectors+classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})+  = sc_sels ++ classMethods c+classAllSelIds c = assert (null (classMethods c) ) []++classSCSelIds :: Class -> [Id]+-- Both superclass-dictionary and method selectors+classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }})+  = sc_sels+classSCSelIds c = assert (null (classMethods c) ) []++classSCSelId :: Class -> Int -> Id+-- Get the n'th superclass selector Id+-- where n is 0-indexed, and counts+--    *all* superclasses including equalities+classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n+  = assert (n >= 0 && lengthExceeds sc_sels n )+    sc_sels !! n+classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)++classMethods :: Class -> [Id]+classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } })+  = [op_sel | (op_sel, _) <- op_stuff]+classMethods _ = []++classOpItems :: Class -> [ClassOpItem]+classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }})+  = op_stuff+classOpItems _ = []++classATs :: Class -> [TyCon]+classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } })+  = [tc | ATI tc _ <- at_stuff]+classATs _ = []++classATItems :: Class -> [ClassATItem]+classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }})+  = at_stuff+classATItems _ = []++classSCTheta :: Class -> [PredType]+classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }})+  = theta_stuff+classSCTheta _ = []++classHasSCs :: Class -> Bool+classHasSCs cls = not (null (classSCTheta cls))++classTvsFds :: Class -> ([TyVar], [FunDep TyVar])+classTvsFds c = (classTyVars c, classFunDeps c)++classHasFds :: Class -> Bool+classHasFds (Class { classFunDeps = fds }) = not (null fds)++classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem])+classBigSig (Class {classTyVars = tyvars,+                    classBody = AbstractClass})+  = (tyvars, [], [], [])+classBigSig (Class {classTyVars = tyvars,+                    classBody = ConcreteClass {+                        cls_sc_theta = sc_theta,+                        cls_sc_sel_ids = sc_sels,+                        cls_ops  = op_stuff+                    }})+  = (tyvars, sc_theta, sc_sels, op_stuff)++classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = AbstractClass})+  = (tyvars, fundeps, [], [], [], [])+classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps,+                         classBody = ConcreteClass {+                             cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels,+                             cls_ats = ats, cls_ops = op_stuff+                         }})+  = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff)++isAbstractClass :: Class -> Bool+isAbstractClass Class{ classBody = AbstractClass } = True+isAbstractClass _ = False++{-+************************************************************************+*                                                                      *+\subsection[Class-instances]{Instance declarations for @Class@}+*                                                                      *+************************************************************************++We compare @Classes@ by their keys (which include @Uniques@).+-}++instance Eq Class where+    c1 == c2 = classKey c1 == classKey c2+    c1 /= c2 = classKey c1 /= classKey c2++instance Uniquable Class where+    getUnique c = classKey c++instance NamedThing Class where+    getName clas = className clas++instance Outputable Class where+    ppr c = ppr (getName c)++pprDefMethInfo :: DefMethInfo -> SDoc+pprDefMethInfo Nothing                  = empty   -- No default method+pprDefMethInfo (Just (n, VanillaDM))    = text "Default method" <+> ppr n+pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method"+                                          <+> ppr n <+> dcolon <+> pprType ty++pprFundeps :: Outputable a => [FunDep a] -> SDoc+pprFundeps []  = empty+pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))++pprFunDep :: Outputable a => FunDep a -> SDoc+pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs]++instance Data.Data Class where+    -- don't traverse?+    toConstr _   = abstractConstr "Class"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "Class"
+ GHC/Core/Coercion.hs view
@@ -0,0 +1,2807 @@+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-+(c) The University of Glasgow 2006+-}++-- | Module for (a) type kinds and (b) type coercions,+-- as used in System FC. See 'GHC.Core.Expr' for+-- more on System FC and how coercions fit into it.+--+module GHC.Core.Coercion (+        -- * Main data type+        Coercion, CoercionN, CoercionR, CoercionP,+        MCoercion(..), MCoercionN, MCoercionR,+        CoSel(..), FunSel(..),+        UnivCoProvenance, CoercionHole(..),+        coHoleCoVar, setCoHoleCoVar,+        LeftOrRight(..),+        Var, CoVar, TyCoVar,+        Role(..), ltRole,++        -- ** Functions over coercions+        coVarRType, coVarLType, coVarTypes,+        coVarKind, coVarTypesRole, coVarRole,+        coercionType, mkCoercionType,+        coercionKind, coercionLKind, coercionRKind,coercionKinds,+        coercionRole, coercionKindRole,++        -- ** Constructing coercions+        mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo,+        mkCoVarCo, mkCoVarCos,+        mkAxInstCo, mkUnbranchedAxInstCo,+        mkAxInstRHS, mkUnbranchedAxInstRHS,+        mkAxInstLHS, mkUnbranchedAxInstLHS,+        mkPiCo, mkPiCos, mkCoCast,+        mkSymCo, mkTransCo,+        mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,+        mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,+        mkNakedFunCo,+        mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos,+        mkPhantomCo, mkAxiomCo,+        mkHoleCo, mkUnivCo, mkSubCo,+        mkProofIrrelCo,+        downgradeRole,+        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,+        mkKindCo,+        castCoercionKind, castCoercionKind1, castCoercionKind2,++        -- ** Decomposition+        instNewTyCon_maybe,++        NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper,+        topNormaliseNewType_maybe, topNormaliseTypeX,++        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,+        splitAppCo_maybe,+        splitFunCo_maybe,+        splitForAllCo_maybe,+        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,++        tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,+        tyConRoleListX, tyConRoleListRepresentational, funRole,+        pickLR,++        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,+        mkCoherenceRightMCo,++        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,+        mkFunResMCo, mkPiMCos,+        isReflMCo, checkReflexiveMCo,++        -- ** Coercion variables+        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,++        -- ** Free variables+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,+        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,+        coercionSize, anyFreeVarsOfCo,++        -- ** Substitution+        CvSubstEnv, emptyCvSubstEnv,+        lookupCoVar,+        substCo, substCos, substCoVar, substCoVars, substCoWith,+        substCoVarBndr,+        extendTvSubstAndInScope, getCvSubstEnv,++        -- ** Lifting+        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,+        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,+        liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,+        updateLCSubst,++        mkSubstLiftingContext, liftingContextSubst, zapLiftingContext,+        lcLookupCoVar, lcInScopeSet,++        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,+        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,++        -- ** Comparison+        eqCoercion, eqCoercionX,++        -- ** Forcing evaluation of coercions+        seqCo,++        -- * Pretty-printing+        pprCo, pprParendCo,+        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,+        pprCoAxBranchUser, tidyCoAxBndrsForUser,+        etaExpandCoAxBranch,++        -- * Tidying+        tidyCo, tidyCos,++        -- * Other+        promoteCoercion, buildCoercion,++        multToCo, mkRuntimeRepCo,++        hasCoercionHole,+        setCoHoleType+       ) where++import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)++import GHC.Prelude++import GHC.Iface.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.Compare+import GHC.Core.Type+import GHC.Core.Predicate( mkNomEqPred, mkReprEqPred )+import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk+import GHC.Core.Coercion.Axiom+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name hiding ( varName )+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Types.SrcLoc+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Types.Unique.FM+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad (foldM, zipWithM)+import Data.Function ( on )+import Data.Char( isDigit )+import qualified Data.Monoid as Monoid+import Data.List.NonEmpty ( NonEmpty (..) )+import Control.DeepSeq++{-+%************************************************************************+%*                                                                      *+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom.  If there are+     -- any left over, we use AppCo.  See+     -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep++\subsection{Coercion variables}+%*                                                                      *+%************************************************************************+-}++coVarName :: CoVar -> Name+coVarName = varName++setCoVarUnique :: CoVar -> Unique -> CoVar+setCoVarUnique = setVarUnique++setCoVarName :: CoVar -> Name -> CoVar+setCoVarName   = setVarName++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing CoAxioms+%*                                                                      *+%************************************************************************++Defined here to avoid module loops. CoAxiom is loaded very early on.++-}++etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)+-- Return the (tvs,lhs,rhs) after eta-expanding,+-- to the way in which the axiom was originally written+-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom+etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs+                                , cab_eta_tvs = eta_tvs+                                , cab_lhs = lhs+                                , cab_rhs = rhs })+  -- ToDo: what about eta_cvs?+  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)+ where+    eta_tys = mkTyVarTys eta_tvs++pprCoAxiom :: CoAxiom br -> SDoc+-- Used in debug-printing only+pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })+  = hang (text "axiom" <+> ppr ax)+       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))++pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc+-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)+-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch)+-- This happens in error messages: don't print the RHS of a data+--   family axiom, which is meaningless to a user+pprCoAxBranchUser tc br+  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br+  | otherwise            = pprCoAxBranch    tc br++pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc+-- Print the family-instance equation when reporting+--   a conflict between equations (FamInst.conflictInstErr)+-- For type families the RHS is important; for data families not so.+--   Indeed for data families the RHS is a mysterious internal+--   type constructor, so we suppress it (#14179)+-- See FamInstEnv Note [Family instance overlap conflicts]+pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs+  where+    pp_rhs _ _ = empty++pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc+pprCoAxBranch = ppr_co_ax_branch ppr_rhs+  where+    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs++ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)+                 -> TyCon -> CoAxBranch -> SDoc+ppr_co_ax_branch ppr_rhs fam_tc branch+  = foldr1 (flip hangNotEmpty 2) $+    pprUserForAll (mkForAllTyBinders Inferred bndrs') :|+         -- See Note [Printing foralls in type family instances] in GHC.Iface.Type+    (pp_lhs <+> ppr_rhs tidy_env ee_rhs) :+    ( vcat [ text "-- Defined" <+> pp_loc+           , ppUnless (null incomps) $ whenPprDebug $+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) :+    []+  where+    incomps = coAxBranchIncomps branch+    loc = coAxBranchSpan branch+    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)+           | otherwise         = text "in" <+> ppr loc++    -- Eta-expand LHS and RHS types, because sometimes data family+    -- instances are eta-reduced.+    -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.+    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch++    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)+                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)++    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs++tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])+-- Tidy wildcards "_1", "_2" to "_", and do not return them+-- in the list of binders to be printed+-- This is so that in error messages we see+--     forall a. F _ [a] _ = ...+-- rather than+--     forall a _1 _2. F _1 [a] _2 = ...+--+-- This is a rather disgusting function+-- See Note [Wildcard names] in GHC.Tc.Gen.HsType+tidyCoAxBndrsForUser init_env tcvs+  = (tidy_env, reverse tidy_bndrs)+  where+    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs++    tidy_one (env@(occ_env, subst), rev_bndrs') bndr+      | is_wildcard bndr = (env_wild, rev_bndrs')+      | otherwise        = (env',     bndr' : rev_bndrs')+      where+        (env', bndr') = tidyVarBndr env bndr+        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)+        wild_bndr = setVarName bndr $+                    tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_"))+                    -- Tidy the binder to "_"++    is_wildcard :: Var -> Bool+    is_wildcard tv = case occNameString (getOccName tv) of+                       ('_' : rest) -> all isDigit rest+                       _            -> False+++{- *********************************************************************+*                                                                      *+              MCoercion+*                                                                      *+********************************************************************* -}++coToMCo :: Coercion -> MCoercion+-- Convert a coercion to a MCoercion,+-- It's not clear whether or not isReflexiveCo would be better here+--    See #19815 for a bit of data and discussion on this point+coToMCo co | isReflCo co = MRefl+           | otherwise   = MCo co++checkReflexiveMCo :: MCoercion -> MCoercion+checkReflexiveMCo MRefl                       = MRefl+checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl+                           | otherwise        = MCo co++-- | Tests if this MCoercion is obviously generalized reflexive+-- Guaranteed to work very quickly.+isGReflMCo :: MCoercion -> Bool+isGReflMCo MRefl = True+isGReflMCo (MCo co) | isGReflCo co = True+isGReflMCo _ = False++-- | Make a generalized reflexive coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflCo r ty mco+  | isGReflMCo mco = if r == Nominal then Refl ty+                                     else GRefl r ty MRefl+  | otherwise+  = -- I'd like to have this assert, but sadly it's not true during type+    -- inference because the types are not fully zonked+    -- assertPpr (case mco of+    --              MCo co -> typeKind ty `eqType` coercionLKind co+    --              MRefl  -> True)+    --          (vcat [ text "ty" <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+    --                , case mco of+    --                     MCo co -> text "co" <+> ppr co+    --                                  <+> dcolon <+> ppr (coercionKind co)+    --                     MRefl  -> text "MRefl"+    --                , callStackDoc ]) $+    GRefl r ty mco++mkGReflMCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion+mkGReflMCo r ty co = mkGReflCo r ty (MCo co)++-- | Compose two MCoercions via transitivity+mkTransMCo :: MCoercion -> MCoercion -> MCoercion+mkTransMCo MRefl     co2       = co2+mkTransMCo co1       MRefl     = co1+mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)++mkTransMCoL :: MCoercion -> Coercion -> MCoercion+mkTransMCoL MRefl     co2 = coToMCo co2+mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)++mkTransMCoR :: Coercion -> MCoercion -> MCoercion+mkTransMCoR co1 MRefl     = coToMCo co1+mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)++-- | Get the reverse of an 'MCoercion'+mkSymMCo :: MCoercion -> MCoercion+mkSymMCo MRefl    = MRefl+mkSymMCo (MCo co) = MCo (mkSymCo co)++-- | Cast a type by an 'MCoercion'+mkCastTyMCo :: Type -> MCoercion -> Type+mkCastTyMCo ty MRefl    = ty+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co++mkPiMCos :: [Var] -> MCoercion -> MCoercion+mkPiMCos _ MRefl = MRefl+mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)++mkFunResMCo :: Id -> MCoercionR -> MCoercionR+mkFunResMCo _      MRefl    = MRefl+mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co)++mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co++mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflRightMCo r ty MRefl    = mkReflCo r ty+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co++-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion+mkCoherenceRightMCo _ _  MRefl    co2 = co2+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2++isReflMCo :: MCoercion -> Bool+isReflMCo MRefl = True+isReflMCo _     = False++{-+%************************************************************************+%*                                                                      *+        Destructing coercions+%*                                                                      *+%************************************************************************+-}++-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into+-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:+--+-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]+decomposeCo :: Arity -> Coercion+            -> Infinite Role  -- the roles of the output coercions+            -> [Coercion]+decomposeCo arity co rs+  = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]+     -- Remember, SelTyCon is zero-indexed++decomposeFunCo :: HasDebugCallStack+               => Coercion  -- Input coercion+               -> (CoercionN, Coercion, Coercion)+-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2)+-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2)+-- actually cow will be a Phantom coercion if the input is a Phantom coercion++decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })+  = (w, co1, co2)+   -- Short-circuits the calls to mkSelCo++decomposeFunCo co+  = assertPpr all_ok (ppr co) $+    ( mkSelCo (SelFun SelMult) co+    , mkSelCo (SelFun SelArg) co+    , mkSelCo (SelFun SelRes) co )+  where+    Pair s1t1 s2t2 = coercionKind co+    all_ok = isFunTy s1t1 && isFunTy s2t2++{- Note [Pushing a coercion into a pi-type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this:+    (f |> co) t1 .. tn+Then we want to push the coercion into the arguments, so as to make+progress. For example of why you might want to do so, see Note+[Respecting definitional equality] in GHC.Core.TyCo.Rep.++This is done by decomposePiCos.  Specifically, if+    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)+then+    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn++Notes:++* k can be smaller than n! That is decomposePiCos can return *fewer*+  coercions than there are arguments (ie k < n), if the kind provided+  doesn't have enough binders.++* If there is a type error, we might see+       (f |> co) t1+  where co :: (forall a. ty) ~ (ty1 -> ty2)+  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.+  So decomposePiCos carefully tests both sides of the coercion to check+  they are both foralls or both arrows.  Not doing this caused #15343.+-}++decomposePiCos :: HasDebugCallStack+               => CoercionN -> Pair Type  -- Coercion and its kind+               -> [Type]+               -> ([CoercionN], CoercionN)+-- See Note [Pushing a coercion into a pi-type]+decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args+  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args+  where+    orig_subst = mkEmptySubst $ mkInScopeSet $+                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co++    go :: [CoercionN]      -- accumulator for argument coercions, reversed+       -> (Subst,Kind)  -- Lhs kind of coercion+       -> CoercionN        -- coercion originally applied to the function+       -> (Subst,Kind)  -- Rhs kind of coercion+       -> [Type]           -- Arguments to that function+       -> ([CoercionN], Coercion)+    -- Invariant:  co :: subst1(k1) ~ subst2(k2)++    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)+      | Just (a, t1) <- splitForAllTyCoVar_maybe k1+      , Just (b, t2) <- splitForAllTyCoVar_maybe k2+        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)+        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)+        --           a :: s1+        --           b :: s2+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]+      = let arg_co  = mkSelCo SelForAll (mkSymCo co)+            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)+            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)+            subst2' = extendTCvSubst subst2 b ty+        in+        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys++      | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1+      , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2+      , af1 == af2  -- Same sort of arrow+        -- know     co :: (s1 -> t1) ~ (s2 -> t2)+        --    function :: s1 -> t1+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1 ~ t2+      = let (_, sym_arg_co, res_co) = decomposeFunCo co+            -- It should be fine to ignore the multiplicity bit+            -- of the coercion for a Nominal coercion.+            arg_co = mkSymCo sym_arg_co+        in+        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys++      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)+      = go acc_arg_cos (zapSubst subst1, substTy subst1 k1)+                       co+                       (zapSubst subst2, substTy subst1 k2)+                       (ty:tys)++      -- tys might not be empty, if the left-hand type of the original coercion+      -- didn't have enough binders+    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)++-- | Extract a covar, if possible. This check is dirty. Be ashamed+-- of yourself. (It's dirty because it cares about the structure of+-- a coercion, which is morally reprehensible.)+getCoVar_maybe :: Coercion -> Maybe CoVar+getCoVar_maybe (CoVarCo cv) = Just cv+getCoVar_maybe _            = Nothing++multToCo :: Mult -> Coercion+multToCo r = mkNomReflCo r++-- first result has role equal to input; third result is Nominal+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+-- ^ Attempt to take a coercion application apart.+splitAppCo_maybe (AppCo co arg) = Just (co, arg)+splitAppCo_maybe (TyConAppCo r tc args)+  | args `lengthExceeds` tyConArity tc+  , Just (args', arg') <- snocView args+  = Just ( mkTyConAppCo r tc args', arg' )++  | not (tyConMustBeSaturated tc)+    -- Never create unsaturated type family apps!+  , Just (args', arg') <- snocView args+  , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg'+  = Just ( mkTyConAppCo r tc args', arg'' )+       -- Use mkTyConAppCo to preserve the invariant+       --  that identity coercions are always represented by Refl++splitAppCo_maybe co+  | Just (ty, r) <- isReflCo_maybe co+  , Just (ty1, ty2) <- splitAppTy_maybe ty+  = Just (mkReflCo r ty1, mkNomReflCo ty2)+splitAppCo_maybe _ = Nothing++-- Only used in specialise/Rules+splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)+splitFunCo_maybe _ = Nothing++splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR+                              , fco_kind = k_co, fco_body = co })+  = Just (tv, vL, vR, k_co, co)+splitForAllCo_maybe co+  | Just (ty, r)        <- isReflCo_maybe co+  , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty+  = Just (tcv, vis, vis, mkNomReflCo (varType tcv), mkReflCo r body_ty)+splitForAllCo_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_ty_maybe co+  | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co+  , isTyVar tv+  = Just stuff+splitForAllCo_ty_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_co_maybe co+  | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co+  , isCoVar cv+  = Just stuff+splitForAllCo_co_maybe _ = Nothing++-------------------------------------------------------+-- and some coercion kind stuff++coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type+coVarLType cv | (ty1, _, _) <- coVarTypesRole cv = ty1+coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2++coVarTypes :: HasDebugCallStack => CoVar -> Pair Type+coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2++coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role)+coVarTypesRole cv+ | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv)+ = (ty1, ty2, eqTyConRole tc)+ | otherwise+ = pprPanic "coVarTypesRole, non coercion variable"+            (ppr cv $$ ppr (varType cv))++coVarKind :: CoVar -> Type+coVarKind cv+  = assert (isCoVar cv )+    varType cv++coVarRole :: CoVar -> Role+coVarRole cv+  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of+                   Just tc0 -> tc0+                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))++eqTyConRole :: TyCon -> Role+-- Given (~#) or (~R#) return the Nominal or Representational respectively+eqTyConRole tc+  | tc `hasKey` eqPrimTyConKey+  = Nominal+  | tc `hasKey` eqReprPrimTyConKey+  = Representational+  | otherwise+  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)++-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`+-- produce a coercion `rep_co :: r1 ~ r2`+-- But actually it is possible that+--     co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: TYPE r1)       ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)+-- See Note [mkRuntimeRepCo]+mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion+mkRuntimeRepCo co+  = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $+    mkSelCo (SelTyCon 0 Nominal) kind_co+  where+    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2+    Pair k1 k2 = coercionKind kind_co++{- Note [mkRuntimeRepCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Given+   class C a where { op :: Maybe a }+we will get an axiom+   axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)+(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)++Then we may call mkRuntimeRepCo on (axC ty), and that will return+   mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2++So mkSelCo needs to be happy with decomposing a coercion of kind+   CONSTRAINT r1 ~ TYPE r2++Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`+in `mkSelCo`. See #23018 for a concrete example.  (In this context it's+important that TYPE and CONSTRAINT have the same arity and kind, not+merely that they are not-apart; otherwise SelCo would not make sense.)+-}++isReflCoVar_maybe :: Var -> Maybe Coercion+-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)+-- Works on all kinds of Vars, not just CoVars+isReflCoVar_maybe cv+  | isCoVar cv+  , Pair ty1 ty2 <- coVarTypes cv+  , ty1 `eqType` ty2+  = Just (mkReflCo (coVarRole cv) ty1)+  | otherwise+  = Nothing++-- | Tests if this coercion is obviously a generalized reflexive coercion.+-- Guaranteed to work very quickly.+isGReflCo :: Coercion -> Bool+isGReflCo (GRefl{}) = True+isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl+isGReflCo _         = False++-- | Tests if this coercion is obviously reflexive. Guaranteed to work+-- very quickly. Sometimes a coercion can be reflexive, but not obviously+-- so. c.f. 'isReflexiveCo'+isReflCo :: Coercion -> Bool+isReflCo (Refl{}) = True+isReflCo (GRefl _ _ mco) | isGReflMCo mco = True+isReflCo _ = False++-- | Returns the type coerced if this coercion is a generalized reflexive+-- coercion. Guaranteed to work very quickly.+isGReflCo_maybe :: Coercion -> Maybe (Type, Role)+isGReflCo_maybe (GRefl r ty _) = Just (ty, r)+isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)+isGReflCo_maybe _ = Nothing++-- | Returns the type coerced if this coercion is reflexive. Guaranteed+-- to work very quickly. Sometimes a coercion can be reflexive, but not+-- obviously so. c.f. 'isReflexiveCo_maybe'+isReflCo_maybe :: Coercion -> Maybe (Type, Role)+isReflCo_maybe (Refl ty) = Just (ty, Nominal)+isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflCo_maybe _ = Nothing++-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,+-- as it walks over the entire coercion.+isReflexiveCo :: Coercion -> Bool+isReflexiveCo = isJust . isReflexiveCo_maybe++-- | Extracts the coerced type from a reflexive coercion. This potentially+-- walks over the entire coercion, so avoid doing this in a loop.+isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)+isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)+isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflexiveCo_maybe co+  | ty1 `eqType` ty2+  = Just (ty1, r)+  | otherwise+  = Nothing+  where (Pair ty1 ty2, r) = coercionKindRole co+++{-+%************************************************************************+%*                                                                      *+            Building coercions+%*                                                                      *+%************************************************************************++These "smart constructors" maintain the invariants listed in the definition+of Coercion, and they perform very basic optimizations.++Note [Role twiddling functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a plethora of functions for twiddling roles:++mkSubCo: Requires a nominal input coercion and always produces a+representational output. This is used when you (the programmer) are sure you+know exactly that role you have and what you want.++downgradeRole_maybe: This function takes both the input role and the output role+as parameters. (The *output* role comes first!) It can only *downgrade* a+role -- that is, change it from N to R or P, or from R to P. This one-way+behavior is why there is the "_maybe". If an upgrade is requested, this+function produces Nothing. This is used when you need to change the role of a+coercion, but you're not sure (as you're writing the code) of which roles are+involved.++This function could have been written using coercionRole to ascertain the role+of the input. But, that function is recursive, and the caller of downgradeRole_maybe+often knows the input role. So, this is more efficient.++downgradeRole: This is just like downgradeRole_maybe, but it panics if the+conversion isn't a downgrade.++setNominalRole_maybe: This is the only function that can *upgrade* a coercion.+The result (if it exists) is always Nominal. The input can be at any role. It+works on a "best effort" basis, as it should never be strictly necessary to+upgrade a coercion during compilation. It is currently only used within GHC in+splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second+coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable+that splitAppCo_maybe is operating over a TyConAppCo that uses a+representational coercion. Hence the need for setNominalRole_maybe.+splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,+it is not absolutely critical that setNominalRole_maybe be complete.++Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom+UnivCos are perfectly type-safe, whereas representational and nominal ones are+not. (Nominal ones are no worse than representational ones, so this function *will*+change a UnivCo Representational to a UnivCo Nominal.)++Conal Elliott also came across a need for this function while working with the+GHC API, as he was decomposing Core casts. The Core casts use representational+coercions, as they must, but his use case required nominal coercions (he was+building a GADT). So, that's why this function is exported from this module.++One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as+appropriate? I (Richard E.) have decided not to do this, because upgrading a+role is bizarre and a caller should have to ask for this behavior explicitly.++-}++-- | Make a reflexive coercion+mkReflCo :: Role -> Type -> Coercion+mkReflCo Nominal ty = Refl ty+mkReflCo r       ty = GRefl r ty MRefl++-- | Make a representational reflexive coercion+mkRepReflCo :: Type -> Coercion+mkRepReflCo ty = GRefl Representational ty MRefl++-- | Make a nominal reflexive coercion+mkNomReflCo :: Type -> Coercion+mkNomReflCo = Refl++-- | Apply a type constructor to a list of coercions. It is the+-- caller's responsibility to get the roles correct on argument coercions.+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkTyConAppCo r tc cos+  | Just co <- tyConAppFunCo_maybe r tc cos+  = co++  -- Expand type synonyms+  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos+  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos++  | Just tys_roles <- traverse isReflCo_maybe cos+  = mkReflCo r (mkTyConApp tc (map fst tys_roles))+  -- See Note [Refl invariant]++  | otherwise = TyConAppCo r tc cos++mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo takes no FunTyFlags; it works them out+mkFunCoNoFTF r w arg_co res_co+  = mkFunCo2 r afl afr w arg_co res_co+  where+    afl = chooseFunTyFlag argl_ty resl_ty+    afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++-- | Build a function 'Coercion' from two other 'Coercion's. That is,+-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@+-- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@.+-- This (most common) version takes a single FunTyFlag, which is used+--   for both fco_afl and ftf_afr of the FunCo+mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo r af w arg_co res_co+  = mkFunCo2 r af af w arg_co res_co++mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo does not check FunCo invariants (checkFunCo)+-- It's a historical vestige; See Note [No assertion check on mkFunCo]+mkNakedFunCo = mkFunCo++mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag+         -> CoercionN -> Coercion -> Coercion -> Coercion+-- This is the smart constructor for FunCo; it checks invariants+mkFunCo2 r afl afr w arg_co res_co+  -- See Note [No assertion check on mkFunCo]+  | Just (ty1, _) <- isReflCo_maybe arg_co+  , Just (ty2, _) <- isReflCo_maybe res_co+  , Just (w, _)   <- isReflCo_maybe w+  = mkReflCo r (mkFunTy afl w ty1 ty2)  -- See Note [Refl invariant]++  | otherwise+  = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+          , fco_mult = w, fco_arg = arg_co, fco_res = res_co }+++{- Note [No assertion check on mkFunCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have a checkFunCo assertion on mkFunCo, but during typechecking+we can (legitimately) have not-full-zonked types or coercion variables, so+the assertion spuriously fails (test T11480b is a case in point).  Lint+checks all these things anyway.++We used to get around the problem by calling mkNakedFunCo from within the+typechecker, which dodged the assertion check.  But then mkAppCo calls+mkTyConAppCo, which calls tyConAppFunCo_maybe, which calls mkFunCo.+Duplicating this stack of calls with "naked" versions of each seems too much.++-- Commented out: see Note [No assertion check on mkFunCo]+checkFunCo :: Role -> FunTyFlag -> FunTyFlag+           -> CoercionN -> Coercion -> Coercion+           -> Maybe SDoc+-- Checks well-formed-ness for FunCo+-- Used only in assertions and Lint+{-# NOINLINE checkFunCo #-}+checkFunCo _r afl afr _w arg_co res_co+  | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty)+  = Just (hang (text "Bad arg or res types") 2 pp_inputs)++  | afl == computed_afl+  , afr == computed_afr+  = Nothing+  | otherwise+  = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl+               , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr+               , pp_inputs ])+  where+    computed_afl = chooseFunTyFlag argl_ty resl_ty+    computed_afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++    pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty+                     , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty+                     , text "arg_co:" <+> ppr arg_co+                     , text "res_co:" <+> ppr res_co ]++    ok ty = isTYPEorCONSTRAINT (typeKind ty)+    pp_ty str ty = text str <> colon <+> hang (ppr ty)+                                            2 (dcolon <+> ppr (typeKind ty))+-}++-- | Apply a 'Coercion' to another 'Coercion'.+-- The second coercion must be Nominal, unless the first is Phantom.+-- If the first is Phantom, then the second can be either Phantom or Nominal.+mkAppCo :: Coercion     -- ^ :: t1 ~r t2+        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2+        -> Coercion     -- ^ :: t1 s1 ~r t2 s2+mkAppCo co arg+  | Just (ty1, r) <- isReflCo_maybe co+  , Just (ty2, _) <- isReflCo_maybe arg+  = mkReflCo r (mkAppTy ty1 ty2)++  | Just (ty1, r) <- isReflCo_maybe co+  , Just (tc, tys) <- splitTyConApp_maybe ty1+    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)+  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)+  where+    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys++mkAppCo (TyConAppCo r tc args) arg+  = case r of+      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])+      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])+        where new_role = tyConRolesRepresentational tc Inf.!! length args+              arg'     = downgradeRole new_role Nominal arg+      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])+mkAppCo co arg = AppCo co  arg+-- Note, mkAppCo is careful to maintain invariants regarding+-- where Refl constructors appear; see the comments in the definition+-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.++-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.+-- See also 'mkAppCo'.+mkAppCos :: Coercion+         -> [Coercion]+         -> Coercion+mkAppCos co1 cos = foldl' mkAppCo co1 cos+++-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo v visL visR kind_co co+  | Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkTyCoForAllTy v visL ty)++  | otherwise+  = mkForAllCo_NoRefl v visL visR kind_co co++-- mkForAllVisCos [tv{vis}] constructs a cast+--   forall tv. res  ~R#   forall tv{vis} res`.+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep+mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion+mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs+  where+    go (Bndr tv vis)+      = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv))++-- | Make a Coercion quantified over a type/coercion variable;+-- the variable has the same kind and visibility in both sides of the coercion+mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion+mkHomoForAllCos vs orig_co+  | Just (ty, r) <- isReflCo_maybe orig_co+  = mkReflCo r (mkTyCoForAllTys vs ty)+  | otherwise+  = foldr go orig_co vs+  where+    go (Bndr var vis) co+      = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co++-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;+--   the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo_NoRefl tcv visL visR kind_co co+  = assertGoodForAllCo tcv visL visR kind_co co $+    assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $+    ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }++assertGoodForAllCo :: HasDebugCallStack+                   =>  TyCoVar -> ForAllTyFlag -> ForAllTyFlag+                   -> CoercionN -> Coercion -> a -> a+-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep+assertGoodForAllCo tcv visL visR kind_co co+  | isTyVar tcv+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc++  | otherwise+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc+        -- The kind of the tycovar should be the left-hand kind of the kind coercion.+  . assertPpr (almostDevoidCoVarOfCo tcv co) doc+        -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  . assertPpr (visL == coreTyLamForAllTyFlag+            && visR == coreTyLamForAllTyFlag) doc+        -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  where+    tcv_type      = varType tcv+    kind_co_lkind = coercionLKind kind_co++    doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type+               , text "Vis:" <+> ppr visL <+> ppr visR+               , text "kind_co:" <+> ppr kind_co+               , text "kind_co_lkind" <+> ppr kind_co_lkind+               , text "body_co" <+> ppr co ]+++mkNakedForAllCo :: TyVar    -- Never a CoVar+                -> ForAllTyFlag -> ForAllTyFlag+                -> CoercionN -> Coercion -> Coercion+-- This version lacks the assertion checks.+-- Used during type checking when the arguments may (legitimately) not be zonked+-- and so the assertions might (bogusly) fail+-- NB: since the coercions are un-zonked, we can't really deal with+--     (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep.+--     Fortunately we don't have to: this function is needed only for /type/ variables.+mkNakedForAllCo tv visL visR kind_co co+  | assertPpr (isTyVar tv) (ppr tv) True+  , Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkForAllTy (Bndr tv visL) ty)+  | otherwise+  = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }+++mkCoVarCo :: CoVar -> Coercion+-- cv :: s ~# t+-- See Note [mkCoVarCo]+mkCoVarCo cv = CoVarCo cv++mkCoVarCos :: [CoVar] -> [Coercion]+mkCoVarCos = map mkCoVarCo++{- Note [mkCoVarCo]+~~~~~~~~~~~~~~~~~~~+In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is+valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but+it's a relatively expensive test and perhaps better done in+optCoercion.  Not a big deal either way.+-}++mkAxInstCo :: Role+           -> CoAxiomRule   -- Always BranchedAxiom or UnbranchedAxiom+           -> [Type] -> [Coercion]+           -> Coercion+-- mkAxInstCo can legitimately be called over-saturated;+-- i.e. with more type arguments than the coercion requires+-- Only called with BranchedAxiom or UnbranchedAxiom+mkAxInstCo role axr tys cos+  | arity == n_tys = downgradeRole role ax_role $+                     AxiomCo axr (rtys `chkAppend` cos)+  | otherwise      = assert (arity < n_tys) $+                     downgradeRole role ax_role $+                     mkAppCos (AxiomCo axr (ax_args `chkAppend` cos))+                              leftover_args+  where+    (ax_role, branch)        = case coAxiomRuleBranch_maybe axr of+                                  Just (_tc, ax_role, branch) -> (ax_role, branch)+                                  Nothing -> pprPanic "mkAxInstCo" (ppr axr)+    n_tys                    = length tys+    arity                    = length (coAxBranchTyVars branch)+    arg_roles                = coAxBranchRoles branch+    rtys                     = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys+    (ax_args, leftover_args) = splitAt arity rtys++-- worker function+mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomCo = AxiomCo++-- to be used only with unbranched axioms+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched+                     -> [Type] -> [Coercion] -> Coercion+mkUnbranchedAxInstCo role ax tys cos+  = mkAxInstCo role (UnbranchedAxiom ax) tys cos++mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+-- Instantiate the axiom with specified types,+-- returning the instantiated RHS+-- A companion to mkAxInstCo:+--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))+mkAxInstRHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkAppTys rhs' tys2+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    rhs'         = substTyWith tvs tys1 $+                   substTyWithCoVars cvs cos $+                   coAxBranchRHS branch++mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0++-- | Return the left-hand type of the axiom, when the axiom is instantiated+-- at the types given.+mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+mkAxInstLHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    lhs_tys      = substTysWith tvs tys1 $+                   substTysWithCoVars cvs cos $+                   coAxBranchLHS branch+    fam_tc       = coAxiomTyCon ax++-- | Instantiate the left-hand side of an unbranched axiom+mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0++-- | Make a coercion from a coercion hole+mkHoleCo :: CoercionHole -> Coercion+mkHoleCo h = HoleCo h++-- | Make a universal coercion between two arbitrary types.+mkUnivCo :: UnivCoProvenance+         -> [Coercion] -- ^ Coercions on which this depends+         -> Role       -- ^ role of the built coercion, "r"+         -> Type       -- ^ t1 :: k1+         -> Type       -- ^ t2 :: k2+         -> Coercion   -- ^ :: t1 ~r t2+mkUnivCo prov deps role ty1 ty2+  | ty1 `eqType` ty2 = mkReflCo role ty1+  | otherwise        = UnivCo { uco_prov = prov, uco_role = role+                              , uco_lty = ty1, uco_rty = ty2+                              , uco_deps = deps }++-- | Create a symmetric version of the given 'Coercion' that asserts+--   equality between the same types but in the other "direction", so+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.+mkSymCo :: Coercion -> Coercion++-- Do a few simple optimizations, mainly to expose the underlying+-- constructors to other 'mk' functions.  E.g.+--   mkInstCo (mkSymCo (ForAllCo ...)) ty+-- We want to push the SymCo inside the ForallCo, so that we can instantiate+-- This can make a big difference.  E.g without coercion optimisation, GHC.Read+-- totally explodes; but when we push Sym inside ForAll, it's fine.+mkSymCo co | isReflCo co   = co+mkSymCo (SymCo co)         = co+mkSymCo (SubCo (SymCo co)) = SubCo co+mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co })+  | isReflCo kco           = co { fco_body = mkSymCo body_co }+mkSymCo co                 = SymCo co++-- | mkTransCo creates a new 'Coercion' by composing the two+--   given 'Coercion's transitively: (co1 ; co2)+mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion+mkTransCo co1 co2+   | isReflCo co1 = co2+   | isReflCo co2 = co1++   | GRefl r t1 (MCo kco1) <- co1+   , GRefl _ _  (MCo kco2) <- co2+   = GRefl r t1 (MCo $ mkTransCo kco1 kco2)++   | otherwise+   = TransCo co1 co2++--------------------+{- Note [mkSelCo precondition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To satisfy the Purely Kinded Type Invariant (PKTI), we require that+  in any call (mkSelCo cs co)+  * selectFromType cs (coercionLKind co) works+  * selectFromType cs (coercionRKind co) works+  * and hence coercionKind (SelCo cs co) works (PKTI)+-}++mkSelCo :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Coercion+-- See Note [mkSelCo precondition]+mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co++mkSelCo_maybe :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Maybe Coercion+-- Note [mkSelCo precondition]+mkSelCo_maybe cs co+  = assertPpr (good_call cs) bad_call_msg $+    go cs co+  where++    go SelForAll (ForAllCo { fco_kind = kind_co })+      = Just kind_co+      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)+      -- then (nth SelForAll co :: k1 ~N k2)+      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)+      -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4))++    go (SelFun fs) (FunCo _ _ _ w arg res)+      = Just (getNthFun fs w arg res)++    go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)+      = assertPpr (r == tyConRole r0 tc i)+                  (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $+        Just (arg_cos `getNth` i)++    go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo+      = do { co' <- go cs co; return (mkSymCo co') }++    go cs co+      | Just (ty, co_role) <- isReflCo_maybe co+      = Just (mkReflCo (mkSelCoResRole cs co_role) (selectFromType cs ty))+        -- mkSelCoreResRole: The role of the result may not be+        -- be equal to co_role, the role of co, per Note [SelCo].+        -- This was revealed by #23938.++      | Pair ty1 ty2 <- coercionKind co+      , let sty1    = selectFromType cs ty1+            sty2    = selectFromType cs ty2+            co_role = coercionRole co+      , sty1 `eqType` sty2+      = Just (mkReflCo (mkSelCoResRole cs co_role) sty1)+            -- Checking for fully reflexive-ness (by seeing if sty1=sty2)+            -- is worthwhile, because a non-Refl coercion `co` may well have a+            -- reflexive (SelCo cs co).+            -- E.g. co :: Either a b ~ Either a c+            --      Then (SubCo (SelTyCon 0) co) is reflexive++      | otherwise = Nothing++    ----------- Assertion checking --------------+    -- NB: using coercionKind requires Note [mkSelCo precondition]+    Pair ty1 ty2 = coercionKind co+    bad_call_msg = vcat [ text "Coercion =" <+> ppr co+                        , text "LHS ty =" <+> ppr ty1+                        , text "RHS ty =" <+> ppr ty2+                        , text "cs =" <+> ppr cs+                        , text "coercion role =" <+> ppr (coercionRole co) ]++    -- good_call checks the typing rules given in Note [SelCo]+    good_call SelForAll+      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1+      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2+      =  True++    good_call (SelFun {})+       = isFunTy ty1 && isFunTy ty2++    good_call (SelTyCon n r)+       | Just (tc1, tys1) <- splitTyConApp_maybe ty1+       , Just (tc2, tys2) <- splitTyConApp_maybe ty2+       , let { len1 = length tys1+             ; len2 = length tys2 }+       =  (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))+                      -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]+       && len1 == len2+       && n < len1+       && r == tyConRole (coercionRole co) tc1 n++    good_call _ = False++mkSelCoResRole :: CoSel -> Role -> Role+-- What is the role of (SelCo cs co), if co has role 'r'?+-- It is not just 'r'!+-- c.f. the SelCo case of coercionRole+mkSelCoResRole SelForAll       _ = Nominal+mkSelCoResRole (SelTyCon _ r') _ = r'+mkSelCoResRole (SelFun fs)     r = funRole r fs++-- | Extract the nth field of a FunCo+getNthFun :: FunSel+          -> a    -- ^ multiplicity+          -> a    -- ^ argument+          -> a    -- ^ result+          -> a    -- ^ One of the above three+getNthFun SelMult mult _   _   = mult+getNthFun SelArg _     arg _   = arg+getNthFun SelRes _     _   res = res++selectFromType :: HasDebugCallStack => CoSel -> Type -> Type+selectFromType (SelFun fs) ty+  | Just (_af, mult, arg, res) <- splitFunTy_maybe ty+  = getNthFun fs mult arg res++selectFromType (SelTyCon n _) ty+  | Just args <- tyConAppArgs_maybe ty+  = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $+    args `getNth` n++selectFromType SelForAll ty       -- Works for both tyvar and covar+  | Just (tv,_) <- splitForAllTyCoVar_maybe ty+  = tyVarKind tv++selectFromType cs ty+  = pprPanic "selectFromType" (ppr cs $$ ppr ty)++--------------------+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkLRCo lr co+  | Just (ty, eq) <- isReflCo_maybe co+  = mkReflCo eq (pickLR lr (splitAppTy ty))+  | otherwise+  = LRCo lr co++-- | Instantiates a 'Coercion'.+-- Works for both tyvar and covar+mkInstCo :: Coercion -> CoercionN -> Coercion+mkInstCo co_fun co_arg+  | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun+  , Just (arg, _) <- isReflCo_maybe co_arg+  = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $+       -- If the arg is Refl, then kind_co must be reflexive too+    substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co+mkInstCo co arg = InstCo co arg++-- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- produces @co' :: ty ~r (ty |> co)@+mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion+mkGReflRightCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise = mkGReflMCo r ty co++-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,+-- produces @co' :: (ty |> co) ~r ty@+mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion+mkGReflLeftCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise    = mkSymCo $ mkGReflMCo r ty co++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,+-- produces @co' :: (ty |> co) ~r ty'+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceLeftCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,+-- produces @co' :: ty' ~r (ty |> co)+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceRightCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = co2 `mkTransCo` mkGReflMCo r ty co++-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.+mkKindCo :: Coercion -> Coercion+mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)+mkKindCo (GRefl _ _ (MCo co)) = co+mkKindCo co+  | Pair ty1 ty2 <- coercionKind co+       -- Generally, calling coercionKind during coercion creation is a bad idea,+       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,+       -- so it's OK here.+  , let tk1 = typeKind ty1+        tk2 = typeKind ty2+  , tk1 `eqType` tk2+  = Refl tk1+  | otherwise+  = KindCo co++mkSubCo :: HasDebugCallStack => Coercion -> Coercion+-- Input coercion is Nominal, result is Representational+-- see also Note [Role twiddling functions]+mkSubCo (Refl ty) = GRefl Representational ty MRefl+mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co+mkSubCo (TyConAppCo Nominal tc cos)+  = TyConAppCo Representational tc (applyRoles tc cos)+mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })+  = co { fco_role = Representational+       , fco_arg = downgradeRole Representational Nominal arg+       , fco_res = downgradeRole Representational Nominal res }+mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $+             SubCo co++-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]+downgradeRole_maybe :: Role   -- ^ desired role+                    -> Role   -- ^ current role+                    -> Coercion -> Maybe Coercion+-- In (downgradeRole_maybe dr cr co) it's a precondition that+--                                   cr = coercionRole co++downgradeRole_maybe Nominal          Nominal          co = Just co+downgradeRole_maybe Nominal          _                _  = Nothing++downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)+downgradeRole_maybe Representational Representational co = Just co+downgradeRole_maybe Representational Phantom          _  = Nothing++downgradeRole_maybe Phantom          Phantom          co = Just co+downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)++-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.+-- See Note [Role twiddling functions]+downgradeRole :: Role  -- desired role+              -> Role  -- current role+              -> Coercion -> Coercion+downgradeRole r1 r2 co+  = case downgradeRole_maybe r1 r2 co of+      Just co' -> co'+      Nothing  -> pprPanic "downgradeRole" (ppr co)++-- | Make a "coercion between coercions".+mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"+               -> CoercionN  -- ^ :: phi1 ~N phi2+               -> Coercion   -- ^ g1 :: phi1+               -> Coercion   -- ^ g2 :: phi2+               -> Coercion   -- ^ :: g1 ~r g2++-- if the two coercion prove the same fact, I just don't care what+-- the individual coercions are.+mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)+  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@+mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r+                                      (mkCoercionTy g1) (mkCoercionTy g2)++{-+%************************************************************************+%*                                                                      *+   Roles+%*                                                                      *+%************************************************************************+-}++-- | Converts a coercion to be nominal, if possible.+-- See Note [Role twiddling functions]+setNominalRole_maybe :: Role -- of input coercion+                     -> Coercion -> Maybe CoercionN+setNominalRole_maybe r co+  | r == Nominal = Just co+  | otherwise = setNominalRole_maybe_helper co+  where+    setNominalRole_maybe_helper (SubCo co)  = Just co+    setNominalRole_maybe_helper co@(Refl _) = Just co+    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co+    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos+           ; return $ TyConAppCo Nominal tc cos' }+    setNominalRole_maybe_helper co@(FunCo { fco_role = Representational+                                          , fco_arg = co1, fco_res = co2 })+      = do { co1' <- setNominalRole_maybe Representational co1+           ; co2' <- setNominalRole_maybe Representational co2+           ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' }+           }+    setNominalRole_maybe_helper (SymCo co)+      = SymCo <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper (TransCo co1 co2)+      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2+    setNominalRole_maybe_helper (AppCo co1 co2)+      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2+    setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co })+      | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep+      = do { body_co' <- setNominalRole_maybe_helper body_co+           ; return (co { fco_body = body_co' }) }+    setNominalRole_maybe_helper (SelCo cs co) =+      -- NB, this case recurses via setNominalRole_maybe, not+      -- setNominalRole_maybe_helper!+      case cs of+        SelTyCon n _r ->+          -- Remember to update the role in SelTyCon to nominal;+          -- not doing this caused #23362.+          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.+          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co+        SelFun fs ->+          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co+        SelForAll ->+          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)+    setNominalRole_maybe_helper (InstCo co arg)+      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg+    setNominalRole_maybe_helper co@(UnivCo { uco_prov = prov })+      | case prov of PhantomProv {}    -> False  -- should always be phantom+                     ProofIrrelProv {} -> True   -- it's always safe+                     PluginProv {}     -> False  -- who knows? This choice is conservative.+      = Just $ co { uco_role = Nominal }+    setNominalRole_maybe_helper _ = Nothing++-- | Make a phantom coercion between two types. The coercion passed+-- in must be a nominal coercion between the kinds of the+-- types.+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkPhantomCo h t1 t2+  = mkUnivCo PhantomProv [h] Phantom t1 t2++-- takes any coercion and turns it into a Phantom coercion+toPhantomCo :: Coercion -> Coercion+toPhantomCo co+  = mkPhantomCo (mkKindCo co) ty1 ty2+  where Pair ty1 ty2 = coercionKind co++-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational+applyRoles :: TyCon -> [Coercion] -> [Coercion]+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational++-- The Role parameter is the Role of the TyConAppCo+-- defined here because this is intimately concerned with the implementation+-- of TyConAppCo+-- Always returns an infinite list (with a infinite tail of Nominal)+tyConRolesX :: Role -> TyCon -> Infinite Role+tyConRolesX Representational tc = tyConRolesRepresentational tc+tyConRolesX role             _  = Inf.repeat role++tyConRoleListX :: Role -> TyCon -> [Role]+tyConRoleListX role = Inf.toList . tyConRolesX role++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRolesRepresentational :: TyCon -> Infinite Role+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRoleListRepresentational :: TyCon -> [Role]+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational++tyConRole :: Role -> TyCon -> Int -> Role+tyConRole Nominal          _  _ = Nominal+tyConRole Phantom          _  _ = Phantom+tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n++funRole :: Role -> FunSel -> Role+funRole Nominal          _  = Nominal+funRole Phantom          _  = Phantom+funRole Representational fs = funRoleRepresentational fs++funRoleRepresentational :: FunSel -> Role+funRoleRepresentational SelMult = Nominal+funRoleRepresentational SelArg  = Representational+funRoleRepresentational SelRes  = Representational++ltRole :: Role -> Role -> Bool+-- Is one role "less" than another?+--     Nominal < Representational < Phantom+ltRole Phantom          _       = False+ltRole Representational Phantom = True+ltRole Representational _       = False+ltRole Nominal          Nominal = False+ltRole Nominal          _       = True++-------------------------------++-- | like mkKindCo, but aggressively & recursively optimizes to avoid using+-- a KindCo constructor. The output role is nominal.+promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN++-- First cases handles anything that should yield refl.+promoteCoercion co = case co of++    Refl _ -> mkNomReflCo ki1++    GRefl _ _ MRefl -> mkNomReflCo ki1++    GRefl _ _ (MCo co) -> co++    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- No later branch should return refl+     -- The assert (False )s throughout+     -- are these cases explicitly, but they should never fire.++    TyConAppCo _ tc args+      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args+      -> co'+      | otherwise+      -> mkKindCo co++    AppCo co1 arg+      | Just co' <- instCoercion (coercionKind (mkKindCo co1))+                                 (promoteCoercion co1) arg+      -> co'+      | otherwise+      -> mkKindCo co++    ForAllCo { fco_tcv = tv, fco_body = g }+      | isTyVar tv+      -> promoteCoercion g++    ForAllCo {}+      -> assert False $+            -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2)+            -- The tyvar case is handled above, so the bound var is a+            -- a coercion variable. So both sides have kind Type+            -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).+            -- So the result is Refl, and that should have been caught by+            -- the first equation above.  Hence `assert False`+         mkNomReflCo liftedTypeKind++    FunCo {} -> mkKindCo co+       -- We can get Type~Constraint or Constraint~Type+       -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint))++    CoVarCo {} -> mkKindCo co+    HoleCo {}  -> mkKindCo co+    AxiomCo {} -> mkKindCo co+    UnivCo {}  -> mkKindCo co  -- We could instead return the (single) `uco_deps` coercion in+                               -- the `ProofIrrelProv` and `PhantomProv` cases, but it doesn't+                               -- quite seem worth doing.++    SymCo g+      -> mkSymCo (promoteCoercion g)++    TransCo co1 co2+      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)++    SelCo n co1+      | Just co' <- mkSelCo_maybe n co1+      -> promoteCoercion co'++      | otherwise+      -> mkKindCo co++    LRCo lr co1+      | Just (lco, rco) <- splitAppCo_maybe co1+      -> case lr of+           CLeft  -> promoteCoercion lco+           CRight -> promoteCoercion rco++      | otherwise+      -> mkKindCo co++    InstCo g _+      | isForAllTy_ty ty1+      -> assert (isForAllTy_ty ty2) $+         promoteCoercion g+      | otherwise+      -> assert False $+         mkNomReflCo liftedTypeKind+           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep++    KindCo _+      -> assert False $ -- See the first equation above+         mkNomReflCo liftedTypeKind++    SubCo g+      -> promoteCoercion g++  where+    Pair ty1 ty2 = coercionKind co+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,+-- where @g' = promoteCoercion (h w)@.+-- fails if this is not possible, if @g@ coerces between a forall and an ->+-- or if second parameter has a representational role and can't be used+-- with an InstCo.+instCoercion :: Pair Type -- g :: lty ~ rty+             -> CoercionN  -- ^  must be nominal+             -> Coercion+             -> Maybe CoercionN+instCoercion (Pair lty rty) g w+  | (isForAllTy_ty lty && isForAllTy_ty rty)+  || (isForAllTy_co lty && isForAllTy_co rty)+  , Just w' <- setNominalRole_maybe (coercionRole w) w+    -- g :: (forall t1. t2) ~ (forall t1. t3)+    -- w :: s1 ~ s2+    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]+  = Just $ mkInstCo g w'++  | isFunTy lty && isFunTy rty+    -- g :: (t1 -> t2) ~ (t3 -> t4)+    -- returns t2 ~ t4+  = Just $ mkSelCo (SelFun SelRes) g -- extract result type++  | otherwise -- one forall, one funty...+  = Nothing++-- | Repeated use of 'instCoercion'+instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN+instCoercions g ws+  = let arg_ty_pairs = map coercionKind ws in+    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)+  where+    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)+       -> Maybe (Pair Type, Coercion)+    go (g_tys, g) (w_tys, w)+      = do { g' <- instCoercion g_tys g w+           ; return (piResultTy <$> g_tys <*> w_tys, g') }++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+castCoercionKind2 :: Coercion -> Role -> Type -> Type+                 -> CoercionN -> CoercionN -> Coercion+castCoercionKind2 g r t1 t2 h1 h2+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)++-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@+-- That is, it's a specialised form of castCoercionKind, where the two+--          kind coercions are identical+-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h) ~r (t2 |> h)@.+-- @h@ must be nominal.+-- See Note [castCoercionKind1]+castCoercionKind1 :: Coercion -> Role -> Type -> Type+                  -> CoercionN -> Coercion+castCoercionKind1 g r t1 t2 h+  = case g of+      Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal+                 mkNomReflCo (mkCastTy t2 h)+      GRefl _ _ mco -> case mco of+           MRefl       -> mkReflCo r (mkCastTy t2 h)+           MCo kind_co -> mkGReflMCo r (mkCastTy t1 h)+                               (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)+      _ -> castCoercionKind2 g r t1 t2 h h++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)+-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand.+castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion+castCoercionKind g h1 h2+  = castCoercionKind2 g r t1 t2 h1 h2+  where+    (Pair t1 t2, r) = coercionKindRole g++mkPiCos :: Role -> [Var] -> Coercion -> Coercion+mkPiCos r vs co = foldr (mkPiCo r) co vs++-- | Make a forall 'Coercion', where both types related by the coercion+-- are quantified over the same variable.+mkPiCo  :: Role -> Var -> Coercion -> Coercion+mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co+              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $+                  -- We didn't call mkForAllCo here because if v does not appear+                  -- in co, the argument coercion will be nominal. But here we+                  -- want it to be r. It is only called in 'mkPiCos', which is+                  -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for+                  -- now (Aug 2018) v won't occur in co.+                            mkFunResCo r v co+              | otherwise = mkFunResCo r v co++mkFunResCo :: Role -> Id -> Coercion -> Coercion+-- Given res_co :: res1 ~ res2,+--   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2)+-- Reflexive in the multiplicity argument+mkFunResCo role id res_co+  = mkFunCoNoFTF role mult arg_co res_co+  where+    arg_co = mkReflCo role (varType id)+    mult   = multToCo (idMult id)++-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2+-- The first coercion might be lifted or unlifted; thus the ~? above+-- Lifted and unlifted equalities take different numbers of arguments,+-- so we have to make sure to supply the right parameter to decomposeCo.+-- Also, note that the role of the first coercion is the same as the role of+-- the equalities related by the second coercion. The second coercion is+-- itself always representational.+mkCoCast :: Coercion -> CoercionR -> Coercion+mkCoCast c g+  | (g2:g1:_) <- reverse co_list+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2++  | otherwise+  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))+  where+    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)+    -- g1 :: s1 ~# s2+    -- g2 :: t1 ~# t2+    (tc, _) = splitTyConApp (coercionLKind g)+    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)++{- Note [castCoercionKind1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+castCoercionKind1 deals with the very important special case of castCoercionKind2+where the two kind coercions are identical.  In that case we can exploit the+situation where the main coercion is reflexive, via the special cases for Refl+and GRefl.++This is important when rewriting  (ty |> co). We rewrite ty, yielding+   fco :: ty ~ ty'+and now we want a coercion xco between+   xco :: (ty |> co) ~ (ty' |> co)+That's exactly what castCoercionKind1 does.  And it's very very common for+fco to be Refl.  In that case we do NOT want to get some terrible composition+of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2+has to do in its full generality.  See #18413.+-}++{-+%************************************************************************+%*                                                                      *+            Newtypes+%*                                                                      *+%************************************************************************+-}++-- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)`+--   then `co :: T ts ~R# rep_ty`+--+-- Checks for a newtype, and for being saturated+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)+instNewTyCon_maybe tc tys+  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype+  , tvs `leLength` tys                                    -- Check saturated enough+  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+         Type normalisation+*                                                                      *+************************************************************************+-}++-- | A function to check if we can reduce a type by one step. Used+-- with 'topNormaliseTypeX'.+type NormaliseStepper ev = RecTcChecker+                         -> TyCon     -- tc+                         -> [Type]    -- tys+                         -> NormaliseStepResult ev++-- | The result of stepping in a normalisation function.+-- See 'topNormaliseTypeX'.+data NormaliseStepResult ev+  = NS_Done   -- ^ Nothing more to do+  | NS_Abort  -- ^ Utter failure. The outer function should fail too.+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;+                                    -- ^ ev is evidence;+                                    -- Usually a co :: old type ~ new type+  deriving (Functor)++instance Outputable ev => Outputable (NormaliseStepResult ev) where+  ppr NS_Done           = text "NS_Done"+  ppr NS_Abort          = text "NS_Abort"+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]++-- | Try one stepper and then try the next, if the first doesn't make+-- progress.+-- So if it returns NS_Done, it means that both steppers are satisfied+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev+                -> NormaliseStepper ev+composeSteppers step1 step2 rec_nts tc tys+  = case step1 rec_nts tc tys of+      success@(NS_Step {}) -> success+      NS_Done              -> step2 rec_nts tc tys+      NS_Abort             -> NS_Abort++-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+-- a loop. If it would fall into a loop, it produces 'NS_Abort'.+unwrapNewTypeStepper :: NormaliseStepper Coercion+unwrapNewTypeStepper rec_nts tc tys+  | Just (ty', co) <- instNewTyCon_maybe tc tys+  = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $+    case checkRecTc rec_nts tc of+      Just rec_nts' -> NS_Step rec_nts' ty' co+      Nothing       -> NS_Abort++  | otherwise+  = NS_Done++-- | A general function for normalising the top-level of a type. It continues+-- to use the provided 'NormaliseStepper' until that function fails, and then+-- this function returns. The roles of the coercions produced by the+-- 'NormaliseStepper' must all be the same, which is the role returned from+-- the call to 'topNormaliseTypeX'.+--+-- Typically ev is Coercion.+--+-- If topNormaliseTypeX step plus ty = Just (ev, ty')+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn+-- If it returns Nothing then no newtype unwrapping could happen+topNormaliseTypeX :: NormaliseStepper ev+                  -> (ev -> ev -> ev)+                  -> Type -> Maybe (ev, Type)+topNormaliseTypeX stepper plus ty+ | Just (tc, tys) <- splitTyConApp_maybe ty+ -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous+ --      for certain type synonyms, we should think about reducing it (see #20990)+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys+ = go rec_nts ev ty'+ | otherwise+ = Nothing+ where+    go rec_nts ev ty+      | Just (tc, tys) <- splitTyConApp_maybe ty+      = case stepper rec_nts tc tys of+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'+          NS_Done  -> Just (ev, ty)+          NS_Abort -> Nothing++      | otherwise+      = Just (ev, ty)++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.+-- This function strips off @newtype@ layers enough to reveal something that isn't+-- a @newtype@.  Specifically, here's the invariant:+--+-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')+--+-- then (a)  @co : ty ~R ty'@.+--      (b)  ty' is not a newtype.+--+-- The function returns @Nothing@ for non-@newtypes@,+-- or unsaturated applications+--+-- This function does *not* look through type families, because it has no access to+-- the type family environment. If you do have that at hand, consider to use+-- topNormaliseType_maybe, which should be a drop-in replacement for+-- topNormaliseNewType_maybe+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'+topNormaliseNewType_maybe ty+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty++{-+%************************************************************************+%*                                                                      *+                   Comparison of coercions+%*                                                                      *+%************************************************************************+-}++-- | Syntactic equality of coercions+eqCoercion :: Coercion -> Coercion -> Bool+eqCoercion = eqType `on` coercionType++-- | Compare two 'Coercion's, with respect to an RnEnv2+eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool+eqCoercionX env = eqTypeX env `on` coercionType++{-+%************************************************************************+%*                                                                      *+                   "Lifting" substitution+           [(TyCoVar,Coercion)] -> Type -> Coercion+%*                                                                      *+%************************************************************************++Note [Lifting coercions over types: liftCoSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The KPUSH rule deals with this situation+   data T a = K (a -> Maybe a)+   g :: T t1 ~ T t2+   x :: t1 -> Maybe t1++   case (K @t1 x) |> g of+     K (y:t2 -> Maybe t2) -> rhs++We want to push the coercion inside the constructor application.+So we do this++   g' :: t1~t2  =  SelCo (SelTyCon 0) g++   case K @t2 (x |> g' -> Maybe g') of+     K (y:t2 -> Maybe t2) -> rhs++The crucial operation is that we+  * take the type of K's argument: a -> Maybe a+  * and substitute g' for a+thus giving *coercion*.  This is what liftCoSubst does.++In the presence of kind coercions, this is a bit+of a hairy operation. So, we refer you to the paper introducing kind coercions,+available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf++Note [extendLiftingContextEx]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we have datatype+  K :: /\k. /\a::k. P -> T k  -- P be some type+  g :: T k1 ~ T k2++  case (K @k1 @t1 x) |> g of+    K y -> rhs++We want to push the coercion inside the constructor application.+We first get the coercion mapped by the universal type variable k:+   lc = k |-> SelCo (SelTyCon 0) g :: k1~k2++Here, the important point is that the kind of a is coerced, and P might be+dependent on the existential type variable a.+Thus we first get the coercion of a's kind+   g2 = liftCoSubst lc k :: k1 ~ k2++Then we store a new mapping into the lifting context+   lc2 = a |-> (t1 ~ t1 |> g2), lc++So later when we can correctly deal with the argument type P+   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]++This is exactly what extendLiftingContextEx does.+* For each (tyvar:k, ty) pair, we product the mapping+    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))+* For each (covar:s1~s2, ty) pair, we produce the mapping+    covar |-> (co ~ co')+    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'++This follows the lifting context extension definition in the+"FC with Explicit Kind Equality" paper.+-}++-- ----------------------------------------------------+-- See Note [Lifting coercions over types: liftCoSubst]+-- ----------------------------------------------------++data LiftingContext = LC Subst LiftCoEnv+  -- in optCoercion, we need to lift when optimizing InstCo.+  -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt+  -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.++instance Outputable LiftingContext where+  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)++type LiftCoEnv = VarEnv Coercion+     -- Maps *type variables* to *coercions*.+     -- That's the whole point of this function!+     -- Also maps coercion variables to ProofIrrelCos.++-- like liftCoSubstWith, but allows for existentially-bound types as well+liftCoSubstWithEx :: [TyVar]       -- universally quantified tyvars+                  -> [Coercion]    -- coercions to substitute for those+                  -> [TyCoVar]     -- existentially quantified tycovars+                  -> [Type]        -- types and coercions to be bound to ex vars+                  -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args)+                      -- Returned coercion has Representational role+liftCoSubstWithEx univs omegas exs rhos+  = let theta = mkLiftingContext (zipEqual univs omegas)+        psi   = extendLiftingContextEx theta (zipEqual exs rhos)+    in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs))++liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion+liftCoSubstWith r tvs cos ty+  = liftCoSubst r (mkLiftingContext $ zipEqual tvs cos) ty++-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)+-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where+-- @lc_left@ is a substitution mapping type variables to the left-hand+-- types of the mapped coercions in @lc@, and similar for @lc_right@.+liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion+{-# INLINE liftCoSubst #-}+-- Inlining this function is worth 2% of allocation in T9872d,+liftCoSubst r lc@(LC subst env) ty+  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)+  | otherwise         = ty_co_subst lc r ty++emptyLiftingContext :: InScopeSet -> LiftingContext+emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv++mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext+mkLiftingContext pairs+  = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))+       (mkVarEnv pairs)++mkSubstLiftingContext :: Subst -> LiftingContext+mkSubstLiftingContext subst = LC subst emptyVarEnv++liftingContextSubst :: LiftingContext -> Subst+liftingContextSubst (LC subst _) = subst++-- | Extend a lifting context with a new mapping.+extendLiftingContext :: LiftingContext  -- ^ original LC+                     -> TyCoVar         -- ^ new variable to map...+                     -> Coercion        -- ^ ...to this lifted version+                     -> LiftingContext+    -- mappings to reflexive coercions are just substitutions+extendLiftingContext (LC subst env) tv arg+  | Just (ty, _) <- isReflCo_maybe arg+  = LC (extendTCvSubst subst tv ty) env+  | otherwise+  = LC subst (extendVarEnv env tv arg)++-- | Extend the substitution component of a lifting context with+-- a new binding for a coercion variable. Used during coercion optimisation.+extendLiftingContextCvSubst :: LiftingContext+                            -> CoVar+                            -> Coercion+                            -> LiftingContext+extendLiftingContextCvSubst (LC subst env) cv co+  = LC (extendCvSubst subst cv co) env++-- | Extend a lifting context with a new mapping, and extend the in-scope set+extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC+                               -> TyCoVar         -- ^ new variable to map...+                               -> Coercion        -- ^ to this coercion+                               -> LiftingContext+extendLiftingContextAndInScope (LC subst env) tv co+  = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co++-- | Extend a lifting context with existential-variable bindings.+-- See Note [extendLiftingContextEx]+extendLiftingContextEx :: LiftingContext    -- ^ original lifting context+                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs+                       -> LiftingContext+-- Note that this is more involved than extendLiftingContext. That function+-- takes a coercion to extend with, so it's assumed that the caller has taken+-- into account any of the kind-changing stuff worried about here.+extendLiftingContextEx lc [] = lc+extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)+-- This function adds bindings for *Nominal* coercions. Why? Because it+-- works with existentially bound variables, which are considered to have+-- nominal roles.+  | isTyVar v+  = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty)+                 (extendVarEnv env v $+                  mkGReflRightCo Nominal+                                 ty+                                 (ty_co_subst lc Nominal (tyVarKind v)))+    in extendLiftingContextEx lc' rest+  | CoercionTy co <- ty+  = -- co      :: s1 ~r s2+    -- lift_s1 :: s1 ~r s1'+    -- lift_s2 :: s2 ~r s2'+    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')+    assert (isCoVar v) $+    let (s1, s2, r) = coVarTypesRole v+        lift_s1 = ty_co_subst lc r s1+        lift_s2 = ty_co_subst lc r s2+        kco     = mkTyConAppCo Nominal (equalityTyCon r)+                               [ mkKindCo lift_s1, mkKindCo lift_s2+                               , lift_s1         , lift_s2          ]+        lc'     = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co)+                     (extendVarEnv env v+                        (mkProofIrrelCo Nominal kco co $+                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))+    in extendLiftingContextEx lc' rest+  | otherwise+  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)+++-- | Erase the environments in a lifting context+zapLiftingContext :: LiftingContext -> LiftingContext+zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv++updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a)+-- Lift a Subst-update function over LiftingContext+updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res)+  where+    (subst', res) = upd subst++-- | The \"lifting\" operation which substitutes coercions for type+--   variables in a type to produce a coercion.+--+--   For the inverse operation, see 'liftCoMatch'+ty_co_subst :: LiftingContext -> Role -> Type -> Coercion+ty_co_subst !lc role ty+    -- !lc: making this function strict in lc allows callers to+    -- pass its two components separately, rather than boxing them.+    -- Unfortunately, Boxity Analysis concludes that we need lc boxed+    -- because it's used that way in liftCoSubstTyVarBndrUsing.+  = go role ty+  where+    go :: Role -> Type -> Coercion+    go r ty                 | Just ty' <- coreView ty+                            = go r ty'+    go Phantom ty           = lift_phantom ty+    go r (TyVarTy tv)       = expectJust $+                              liftCoSubstTyVar lc r tv+    go r (AppTy ty1 ty2)    = mkAppCo (go r ty1) (go Nominal ty2)+    go r (TyConApp tc tys)  = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)+    go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)+    go r t@(ForAllTy (Bndr v vis) ty)+       = let (lc', v', h) = liftCoSubstVarBndr lc v+             body_co = ty_co_subst lc' r ty in+         if isTyVar v' || almostDevoidCoVarOfCo v' body_co+           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo+           -- imposes an extra restriction on where a covar can appear. See+           -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep+            -- We specifically check for this and panic because we know that+           -- there's a hole in the type system here (see (FC6), and we'd rather+           -- panic than fall into it.+         then mkForAllCo v' vis vis h body_co+         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)+    go r ty@(LitTy {})     = assert (r == Nominal) $+                             mkNomReflCo ty+    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)+                                                        (substRightCo lc co)+    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)+                                                  (substRightCo lc co)+      where kco = go Nominal (coercionType co)++    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))+                                  (substTy (lcSubstLeft  lc) ty)+                                  (substTy (lcSubstRight lc) ty)++{-+Note [liftCoSubstTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~+This function can fail if a coercion in the environment is of too low a role.++liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and+also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting+lemma guarantees that the roles work out. If we fail in this+case, we really should panic -- something is deeply wrong. But, in matchAxiom,+failing is fine. matchAxiom is trying to find a set of coercions+that match, but it may fail, and this is healthy behavior.+-}++-- See Note [liftCoSubstTyVar]+liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion+liftCoSubstTyVar (LC subst env) r v+  | Just co_arg <- lookupVarEnv env v+  = downgradeRole_maybe r (coercionRole co_arg) co_arg++  | otherwise+  = Just $ mkReflCo r (substTyVar subst v)++{- Note [liftCoSubstVarBndr]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+callback:+  'liftCoSubstVarBndrUsing' needs to be general enough to work in two+  situations:++    - in this module, which manipulates 'Coercion's, and+    - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain+      a coercion as well as a type.++  To achieve this, we require that the return type of the 'callback' function+  contain a coercion within it. This is witnessed by the first argument+  to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve+  the coercion inside the return type. Thus:++    - in this module, we simply pass 'id' as the getter,+    - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter.++liftCoSubstTyVarBndrUsing:+  Given+    forall tv:k. t+  We want to get+    forall (tv:k1) (kind_co :: k1 ~ k2) body_co++  We lift the kind k to get the kind_co+    kind_co = ty_co_subst k :: k1 ~ k2++  Now in the LiftingContext, we add the new mapping+    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)++liftCoSubstCoVarBndrUsing:+  Given+    forall cv:(s1 ~ s2). t+  We want to get+    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co++  We lift s1 and s2 respectively to get+    eta1 :: s1' ~ t1+    eta2 :: s2' ~ t2+  And+    kind_co = TyConAppCo Nominal (~#) eta1 eta2++  Now in the liftingContext, we add the new mapping+    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)+-}++-- See Note [liftCoSubstVarBndr]+liftCoSubstVarBndr :: LiftingContext -> TyCoVar+                   -> (LiftingContext, TyCoVar, Coercion)+liftCoSubstVarBndr lc tv+  = liftCoSubstVarBndrUsing id callback lc tv+  where+    callback lc' ty' = ty_co_subst lc' Nominal ty'++-- the callback must produce a nominal coercion+liftCoSubstVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                        -> (LiftingContext -> Type -> r) -- ^ callback+                        -> LiftingContext -> TyCoVar+                        -> (LiftingContext, TyCoVar, r)+liftCoSubstVarBndrUsing view_co fun lc old_var+  | isTyVar old_var+  = liftCoSubstTyVarBndrUsing view_co fun lc old_var+  | otherwise+  = liftCoSubstCoVarBndrUsing view_co fun lc old_var++-- Works for tyvar binder+liftCoSubstTyVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> TyVar+                          -> (LiftingContext, TyVar, r)+liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isTyVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = tyVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta+               -- :: new_var ~ new_var |> eta+    new_cenv = extendVarEnv cenv old_var lifted++-- Works for covar binder+liftCoSubstCoVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> CoVar+                          -> (LiftingContext, CoVar, r)+liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isCoVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = coVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    -- old_var :: s1  ~r s2+    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)+    -- eta1    :: s1' ~r t1+    -- eta2    :: s2' ~r t2+    -- co1     :: s1' ~r s2'+    -- co2     :: t1  ~r t2+    -- lifted  :: co1 ~N co2++    role   = coVarRole old_var+    eta'   = downgradeRole role Nominal eta+    eta1   = mkSelCo (SelTyCon 2 role) eta'+    eta2   = mkSelCo (SelTyCon 3 role) eta'++    co1     = mkCoVarCo new_var+    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2+    lifted  = mkProofIrrelCo Nominal eta co1 co2++    new_cenv = extendVarEnv cenv old_var lifted++-- | Is a var in the domain of a lifting context?+isMappedByLC :: TyCoVar -> LiftingContext -> Bool+isMappedByLC tv (LC _ env) = tv `elemVarEnv` env++-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1+-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1+substLeftCo :: LiftingContext -> Coercion -> Coercion+substLeftCo lc co+  = substCo (lcSubstLeft lc) co++-- Ditto, but for t2 and g2+substRightCo :: LiftingContext -> Coercion -> Coercion+substRightCo lc co+  = substCo (lcSubstRight lc) co++-- | Apply "sym" to all coercions in a 'LiftCoEnv'+swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv+swapLiftCoEnv = mapVarEnv mkSymCo++lcSubstLeft :: LiftingContext -> Subst+lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env++lcSubstRight :: LiftingContext -> Subst+lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env++liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst+liftEnvSubstLeft = liftEnvSubst pFst++liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst+liftEnvSubstRight = liftEnvSubst pSnd++liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst+liftEnvSubst selector subst lc_env+  = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst+  where+    pairs            = nonDetUFMToList lc_env+                       -- It's OK to use nonDetUFMToList here because we+                       -- immediately forget the ordering by creating+                       -- a VarEnv+    (tpairs, cpairs) = partitionWith ty_or_co pairs+    -- Make sure the in-scope set is wide enough to cover the range of the+    -- substitution (#22235).+    in_scope         = mkInScopeSet $+                       tyCoVarsOfTypes (map snd tpairs) `unionVarSet`+                       tyCoVarsOfCos (map snd cpairs)+    tenv             = mkVarEnv_Directly tpairs+    cenv             = mkVarEnv_Directly cpairs++    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)+    ty_or_co (u, co)+      | Just equality_co <- isCoercionTy_maybe equality_ty+      = Right (u, equality_co)+      | otherwise+      = Left (u, equality_ty)+      where+        equality_ty = selector (coercionKind co)++-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext'+lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion+lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv++-- | Get the 'InScopeSet' from a 'LiftingContext'+lcInScopeSet :: LiftingContext -> InScopeSet+lcInScopeSet (LC subst _) = substInScopeSet subst++{-+%************************************************************************+%*                                                                      *+            Sequencing on coercions+%*                                                                      *+%************************************************************************+-}++seqMCo :: MCoercion -> ()+seqMCo MRefl    = ()+seqMCo (MCo co) = seqCo co++seqCo :: Coercion -> ()+seqCo (Refl ty)             = seqType ty+seqCo (GRefl r ty mco)      = r `seq` seqType ty `seq` seqMCo mco+seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos+seqCo (AppCo co1 co2)       = seqCo co1 `seq` seqCo co2+seqCo (CoVarCo cv)          = cv `seq` ()+seqCo (HoleCo h)            = coHoleCoVar h `seq` ()+seqCo (SymCo co)            = seqCo co+seqCo (TransCo co1 co2)     = seqCo co1 `seq` seqCo co2+seqCo (SelCo n co)          = n `seq` seqCo co+seqCo (LRCo lr co)          = lr `seq` seqCo co+seqCo (InstCo co arg)       = seqCo co `seq` seqCo arg+seqCo (KindCo co)           = seqCo co+seqCo (SubCo co)            = seqCo co+seqCo (AxiomCo _ cs)        = seqCos cs+seqCo (ForAllCo tv visL visR k co)+  = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq`+    seqCo k `seq` seqCo co+seqCo (FunCo r af1 af2 w co1 co2)+  = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2+seqCo (UnivCo { uco_prov = p, uco_role = r+              , uco_lty = t1, uco_rty = t2, uco_deps = deps })+  = p `seq` r `seq` seqType t1 `seq` seqType t2 `seq` seqCos deps++seqCos :: [Coercion] -> ()+seqCos []       = ()+seqCos (co:cos) = seqCo co `seq` seqCos cos++{-+%************************************************************************+%*                                                                      *+             The kind of a type, and of a coercion+%*                                                                      *+%************************************************************************+-}++{- Note [coercionKind performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+coercionKind, coercionLKind, and coercionRKind are very "hot" functions; in some+coercion-heavy programs they can have a material effect on compile time/allocation.++Hence+* Rather than making one function which returns a pair (lots of allocation and+  de-allocation) we have two functions, coercionLKind and coercionRKind, which+  return the left and right kind respectively.++* Both are defined by a single worker function `coercion_lr_kind`, which takes a+  flag of type `LeftOrRight`.  This worker function is marked INLINE, and inlined+  at its precisely-two call-sites in coercionLKind and coercionRKind.++Take care when making changes here... it's easy to accidentally add allocation!+-}++-- | Apply 'coercionKind' to multiple 'Coercion's+coercionKinds :: [Coercion] -> Pair [Type]+coercionKinds tys = sequenceA $ map coercionKind tys++-- | Get a coercion's kind and role.+coercionKindRole :: Coercion -> (Pair Type, Role)+coercionKindRole co = (coercionKind co, coercionRole co)++coercionType :: Coercion -> Type+coercionType co = case coercionKindRole co of+  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2++------------------+-- | If it is the case that+--+-- > c :: (t1 ~ t2)+--+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.++coercionKind :: HasDebugCallStack => Coercion -> Pair Type+-- See Note [coercionKind performance]+coercionKind co = Pair (coercionLKind co) (coercionRKind co)++coercionLKind, coercionRKind :: HasDebugCallStack => Coercion -> Type+-- See Note [coercionKind performance]+coercionLKind co = coercion_lr_kind CLeft  co+coercionRKind co = coercion_lr_kind CRight co++coercion_lr_kind :: HasDebugCallStack => LeftOrRight -> Coercion -> Type+{-# INLINE coercion_lr_kind #-}+-- See Note [coercionKind performance]+coercion_lr_kind which orig_co+  = go orig_co+  where+    go (Refl ty)              = ty+    go (GRefl _ ty MRefl)     = ty+    go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1)+    go (TyConAppCo _ tc cos)  = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)        = mkAppTy (go co1) (go co2)+    go (CoVarCo cv)           = go_covar cv+    go (HoleCo h)             = go_covar (coHoleCoVar h)+    go (SymCo co)             = pickLR which (coercionRKind co, coercionLKind co)+    go (TransCo co1 co2)      = pickLR which (go co1,           go co2)+    go (LRCo lr co)           = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)       = go_app aco [go arg]+    go (KindCo co)            = typeKind (go co)+    go (SubCo co)             = go co+    go (SelCo d co)           = selectFromType d (go co)+    go (AxiomCo ax cos)       = go_ax ax cos++    go (UnivCo { uco_lty = lty, uco_rty = rty})+      = pickLR which (lty, rty)+    go (FunCo { fco_afl = afl, fco_afr = afr, fco_mult = mult+              , fco_arg = arg, fco_res = res})+      = -- See Note [FunCo]+        FunTy { ft_af = pickLR which (afl, afr), ft_mult = go mult+              , ft_arg = go arg, ft_res = go res }++    go co@(ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_visR = visR+                    , fco_kind = k_co, fco_body = co1 })+      = case which of+          CLeft  -> mkTyCoForAllTy tv1 visL (go co1)+          CRight | isGReflCo k_co  -- kind_co always has kind `Type`, thus `isGReflCo`+                 -> mkTyCoForAllTy tv1 visR (go co1)+                 | otherwise+                 -> go_forall_right empty_subst co+      where+         empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co)++    -------------+    go_covar cv = pickLR which (coVarLType cv, coVarRType cv)++    -------------+    go_app :: Coercion -> [Type] -> Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (go arg:args)+    go_app co              args = piResultTys (go co) args++    -------------+    go_ax axr@(BuiltInFamRew  bif) cos  = check_bif_res axr (bifrw_proves  bif (map coercionKind cos))+    go_ax axr@(BuiltInFamInj bif) [co]  = check_bif_res axr (bifinj_proves bif (coercionKind co))+    go_ax axr@(BuiltInFamInj {})  _     = crash axr+    go_ax     (UnbranchedAxiom ax) cos  = go_branch ax (coAxiomSingleBranch ax) cos+    go_ax     (BranchedAxiom ax i) cos  = go_branch ax (coAxiomNthBranch ax i)  cos++    -------------+    check_bif_res _   (Just (Pair lhs rhs)) = pickLR which (lhs,rhs)+    check_bif_res axr Nothing               = crash axr++    crash :: CoAxiomRule -> Type+    crash axr = pprPanic "coercionKind" (ppr axr)++    -------------+    go_branch :: CoAxiom br -> CoAxBranch -> [Coercion] -> Type+    go_branch ax (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                             , cab_lhs = lhs_tys, cab_rhs = rhs_ty }) cos+      = assert (cos `equalLength` tcvs) $+                  -- Invariant of AxiomRuleCo: cos should+                  -- exactly saturate the axiom branch+        let (tys1, cotys1) = splitAtList tvs tys+            cos1           = map stripCoercionTy cotys1+        in+        -- You might think to use+        --        substTy (zipTCvSubst tcvs ltys) (pickLR ...)+        -- but #25066 makes it much less efficient than the silly calls below+        substTyWith tvs tys1       $+        substTyWithCoVars cvs cos1 $+        pickLR which (mkTyConApp tc lhs_tys, rhs_ty)+     where+       tc   = coAxiomTyCon ax+       tcvs | null cvs  = tvs  -- Very common case (currently always!)+            | otherwise = tvs ++ cvs+       tys = map go cos++    -------------+    go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      -- See Note [Nested ForAllCos]+      | isTyVar tv1+      = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)+      where+        k2  = coercionRKind k_co+        tv2 = setTyVarKind tv1 (substTy subst k2)+        subst' | isGReflCo k_co = extendSubstInScope subst tv1+                 -- kind_co always has kind @Type@, thus @isGReflCo@+               | otherwise      = extendTvSubst (extendSubstInScope subst tv2) tv1 $+                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co++    go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      | isCoVar cv1+      = mkTyCoForAllTy cv2 visR (go_forall_right subst' co)+      where+        k2    = coercionRKind k_co+        r     = coVarRole cv1+        k_co' = downgradeRole r Nominal k_co+        eta1  = mkSelCo (SelTyCon 2 r) k_co'+        eta2  = mkSelCo (SelTyCon 3 r) k_co'++        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)+        -- k1    = t1 ~r t2+        -- k2    = s1 ~r s2+        -- cv1  :: t1 ~r t2+        -- cv2  :: s1 ~r s2+        -- eta1 :: t1 ~r s1+        -- eta2 :: t2 ~r s2+        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2++        cv2     = setVarType cv1 (substTy subst k2)+        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)+        subst'  | isReflCo k_co = extendSubstInScope subst cv1+                | otherwise     = extendCvSubst (extendSubstInScope subst cv2)+                                                cv1 n_subst++    go_forall_right subst other_co+      -- when other_co is not a ForAllCo+      = substTy subst (go other_co)++{- Note [Nested ForAllCos]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`.+We do not want to perform `n` single-type-variable substitutions over the kind+of `co`; rather we want to do one substitution which substitutes for all of+`a1`, `a2` ... simultaneously.  If we do one at a time we get the performance+hole reported in #11735.++Solution: gather up the type variables for nested `ForAllCos`, and+substitute for them all at once.  Remarkably, for #11735 this single+change reduces /total/ compile time by a factor of more than ten.++Note [Nested InstCos]+~~~~~~~~~~~~~~~~~~~~~+In #5631 we found that 70% of the entire compilation time was+being spent in coercionKind!  The reason was that we had+   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos+where+   g :: forall a1 a2 .. a100. phi+If we deal with the InstCos one at a time, we'll do this:+   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'+   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst+But this is a *quadratic* algorithm, and the blew up #5631.+So it's very important to do the substitution simultaneously;+cf Type.piResultTys (which in fact we call here).+-}++-- | Retrieve the role from a coercion.+coercionRole :: Coercion -> Role+coercionRole = go+  where+    go (Refl _)                     = Nominal+    go (GRefl r _ _)                = r+    go (TyConAppCo r _ _)           = r+    go (AppCo co1 _)                = go co1+    go (ForAllCo { fco_body = co }) = go co+    go (FunCo { fco_role = r })     = r+    go (CoVarCo cv)                 = coVarRole cv+    go (HoleCo h)                   = coVarRole (coHoleCoVar h)+    go (UnivCo { uco_role = r })    = r+    go (SymCo co)                   = go co+    go (TransCo co1 _co2)           = go co1+    go (SelCo cs co)                = mkSelCoResRole cs (coercionRole co)+    go (LRCo {})                    = Nominal+    go (InstCo co _)                = go co+    go (KindCo {})                  = Nominal+    go (SubCo _)                    = Representational+    go (AxiomCo ax _)               = coAxiomRuleRole ax++-- | Makes a coercion type from two types: the types whose equality+-- is proven by the relevant 'Coercion'+mkCoercionType :: Role -> Type -> Type -> Type+mkCoercionType Nominal          = mkNomEqPred+mkCoercionType Representational = mkReprEqPred+mkCoercionType Phantom          = \ty1 ty2 ->+  let ki1 = typeKind ty1+      ki2 = typeKind ty2+  in+  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]++-- | Assuming that two types are the same, ignoring coercions, find+-- a nominal coercion between the types. This is useful when optimizing+-- transitivity over coercion applications, where splitting two+-- AppCos might yield different kinds. See Note [EtaAppCo] in+-- "GHC.Core.Coercion.Opt".+buildCoercion :: HasDebugCallStack => Type -> Type -> CoercionN+buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2+               | Just ty2' <- coreView ty2 = go ty1 ty2'++    go (CastTy ty1 co) ty2+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceLeftCo r ty1 co co'++    go ty1 (CastTy ty2 co)+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceRightCo r ty2 co co'++    go ty1@(TyVarTy tv1) _tyvarty+      = assert (case _tyvarty of+                  { TyVarTy tv2 -> tv1 == tv2+                  ; _           -> False      }) $+        mkNomReflCo ty1++    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 })+      = assert (af1 == af2) $+        mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)++    go (TyConApp tc1 args1) (TyConApp tc2 args2)+      = assertPpr (tc1 == tc2) (vcat [ ppr tc1 <+> ppr tc2+                                     , text "orig_ty1:" <+> ppr orig_ty1+                                     , text "orig_ty2:" <+> ppr orig_ty2+                                     ]) $+        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)++    go (AppTy ty1a ty1b) ty2+      | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go ty1 (AppTy ty2a ty2b)+      | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)+      | isTyVar tv1+      = assert (isTyVar tv2) $+        mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')+      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)+            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'     = substTyWithInScope in_scope [tv2]+                         [mkTyVarTy tv1 `mkCastTy` kind_co]+                         ty2++    go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)+      = assert (isCoVar cv1 && isCoVar cv2) $+        mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')+      where s1 = varType cv1+            s2 = varType cv2+            kind_co = go s1 s2++            -- s1 = t1 ~r t2+            -- s2 = t3 ~r t4+            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)+            -- eta1 :: t1 ~r t3+            -- eta2 :: t2 ~r t4++            r    = coVarRole cv1+            kind_co' = downgradeRole r Nominal kind_co+            eta1 = mkSelCo (SelTyCon 2 r) kind_co'+            eta2 = mkSelCo (SelTyCon 3 r) kind_co'++            subst = mkEmptySubst $ mkInScopeSet $+                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`+                                                       mkCoVarCo cv1 `mkTransCo`+                                                       eta2)+                            ty2++    go ty1@(LitTy lit1) _lit2+      = assert (case _lit2 of+                  { LitTy lit2 -> lit1 == lit2+                  ; _          -> False        }) $+        mkNomReflCo ty1++    go (CoercionTy co1) (CoercionTy co2)+      = mkProofIrrelCo Nominal kind_co co1 co2+      where+        kind_co = go (coercionType co1) (coercionType co2)++    go ty1 ty2+      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2+                                           , ppr ty1, ppr ty2 ])+++{-+%************************************************************************+%*                                                                      *+       Coercion holes+%*                                                                      *+%************************************************************************+-}++has_co_hole_ty :: Type -> Monoid.Any+(has_co_hole_ty, _, _, _)+  = foldTyCo folder ()+  where+    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = const2 (Monoid.Any False)+                        , tcf_covar = const2 (Monoid.Any False)+                        , tcf_hole  = \_ _ -> Monoid.Any True+                        , tcf_tycobinder = const2+                        }++-- | Is there a coercion hole in this type?+-- See wrinkle (DE6) of Note [Defaulting equalities] in GHC.Tc.Solver.Default+hasCoercionHole :: Type -> Bool+hasCoercionHole = Monoid.getAny . has_co_hole_ty++-- | Set the type of a 'CoercionHole'+setCoHoleType :: CoercionHole -> Type -> CoercionHole+setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t)+
+ GHC/Core/Coercion.hs-boot view
@@ -0,0 +1,58 @@+{-# LANGUAGE FlexibleContexts #-}++module GHC.Core.Coercion where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.TyCo.Rep+import {-# SOURCE #-} GHC.Core.TyCon++import GHC.Types.Basic ( LeftOrRight )+import GHC.Core.Coercion.Axiom+import GHC.Types.Var+import GHC.Data.Pair+import GHC.Utils.Misc++mkReflCo :: Role -> Type -> Coercion+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkAppCo :: Coercion -> Coercion -> Coercion+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion+mkFunCo      :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo2     :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkCoVarCo :: CoVar -> Coercion+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkUnivCo :: UnivCoProvenance -> [Coercion] -> Role -> Type -> Type -> Coercion+mkSymCo :: Coercion -> Coercion+mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion+mkSelCo :: HasDebugCallStack => CoSel -> Coercion -> Coercion+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkInstCo :: Coercion -> Coercion -> Coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkNomReflCo :: Type -> Coercion+mkKindCo :: Coercion -> Coercion+mkSubCo :: HasDebugCallStack => Coercion -> Coercion+mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion+mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion++funRole :: Role -> FunSel -> Role++isGReflCo :: Coercion -> Bool+isReflCo :: Coercion -> Bool+isReflexiveCo :: Coercion -> Bool+decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion)+coVarTypesRole :: HasDebugCallStack => CoVar -> (Type, Type, Role)+coVarRole :: CoVar -> Role++mkCoercionType :: Role -> Type -> Type -> Type++seqCo :: Coercion -> ()++coercionKind  :: HasDebugCallStack => Coercion -> Pair Type+coercionLKind :: HasDebugCallStack => Coercion -> Type+coercionRKind :: HasDebugCallStack => Coercion -> Type+coercionType :: Coercion -> Type++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+  -- used to look through newtypes to the right of+  -- function arrows, in 'GHC.Core.Type.getRuntimeArgTys'
+ GHC/Core/Coercion/Axiom.hs view
@@ -0,0 +1,749 @@+{-# OPTIONS_GHC -Wno-orphans     #-} -- Outputable+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE RoleAnnotations     #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- (c) The University of Glasgow 2012++-- | Module for coercion axioms, used to represent type family instances+-- and newtypes++module GHC.Core.Coercion.Axiom (+       BranchFlag, Branched, Unbranched, BranchIndex, Branches(..),+       manyBranches, unbranched,+       fromBranches, numBranches,+       mapAccumBranches,++       CoAxiom(..), CoAxBranch(..),++       toBranchedAxiom, toUnbranchedAxiom,+       coAxiomName, coAxiomArity, coAxiomBranches,+       coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats,+       coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole,+       coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars,+       coAxBranchRoles,+       coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps,+       placeHolderIncomps,++       Role(..), fsFromRole,++       CoAxiomRule(..), BuiltInFamRewrite(..), BuiltInFamInjectivity(..), TypeEqn,+       coAxiomRuleArgRoles, coAxiomRuleRole,+       coAxiomRuleBranch_maybe, isNewtypeAxiomRule_maybe,+       BuiltInSynFamily(..), trivialBuiltInFamily+       ) where++import GHC.Prelude++import Language.Haskell.Syntax.Basic (Role(..))++import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprTyVar )+import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon, isNewTyCon )+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Var+import GHC.Utils.Misc+import GHC.Utils.Binary+import GHC.Utils.Panic+import GHC.Data.Pair+import GHC.Types.Basic+import Data.Typeable ( Typeable )+import GHC.Types.SrcLoc+import qualified Data.Data as Data+import Data.Array+import Data.List ( mapAccumL )+import Control.DeepSeq++{-+Note [Coercion axiom branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to allow closed type families, an axiom needs to contain an+ordered list of alternatives, called branches. The kind of the coercion built+from an axiom is determined by which index is used when building the coercion+from the axiom.++For example, consider the axiom derived from the following declaration:++type family F a where+  F [Int] = Bool+  F [a]   = Double+  F (a b) = Char++This will give rise to this axiom:++axF :: {                                         F [Int] ~ Bool+       ; forall (a :: *).                        F [a]   ~ Double+       ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char+       }++The axiom is used with the AxiomCo constructor of Coercion. If we wish+to have a coercion showing that F (Maybe Int) ~ Char, it will look like++axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char+-- or, written using concrete-ish syntax --+AxiomRuleCo axF 2 [Refl *, Refl Maybe, Refl Int]++Note that the index is 0-based.++For type-checking, it is also necessary to check that no previous pattern+can unify with the supplied arguments. After all, it is possible that some+of the type arguments are lambda-bound type variables whose instantiation may+cause an earlier match among the branches. We wish to prohibit this behavior,+so the type checker rules out the choice of a branch where a previous branch+can unify. See also [Apartness] in GHC.Core.FamInstEnv.++For example, the following is malformed, where 'a' is a lambda-bound type+variable:++axF[2] <*> <a> <Bool> :: F (a Bool) ~ Char++Why? Because a might be instantiated with [], meaning that branch 1 should+apply, not branch 2. This is a vital consistency check; without it, we could+derive Int ~ Bool, and that is a Bad Thing.++Note [Branched axioms]+~~~~~~~~~~~~~~~~~~~~~~+Although a CoAxiom has the capacity to store many branches, in certain cases,+we want only one. These cases are in data/newtype family instances, newtype+coercions, and type family instances.+Furthermore, these unbranched axioms are used in a+variety of places throughout GHC, and it would difficult to generalize all of+that code to deal with branched axioms, especially when the code can be sure+of the fact that an axiom is indeed a singleton. At the same time, it seems+dangerous to assume singlehood in various places through GHC.++The solution to this is to label a CoAxiom with a phantom type variable+declaring whether it is known to be a singleton or not. The branches+are stored using a special datatype, declared below, that ensures that the+type variable is accurate.++************************************************************************+*                                                                      *+                    Branches+*                                                                      *+************************************************************************+-}++{- Note [BranchIndex]+~~~~~~~~~~~~~~~~~~~~+A CoAxiom has 1 or more branches. Each branch has contains a list+of the free type variables in that branch, the LHS type patterns,+and the RHS type for that branch. When we apply an axiom to a list+of coercions, we must choose which branch of the axiom we wish to+use, as the different branches may have different numbers of free+type variables. (The number of type patterns is always the same+among branches, but that doesn't quite concern us here.)+-}+++type BranchIndex = Int         -- Counting from zero+      -- The index of the branch in the list of branches+      -- See Note [BranchIndex]++-- promoted data type+data BranchFlag = Branched | Unbranched+type Branched = 'Branched+type Unbranched = 'Unbranched+-- By using type synonyms for the promoted constructors, we avoid needing+-- DataKinds and the promotion quote in client modules. This also means that+-- we don't need to export the term-level constructors, which should never be used.++newtype Branches (br :: BranchFlag)+  = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch }+type role Branches nominal++manyBranches :: [CoAxBranch] -> Branches Branched+manyBranches brs = assert (snd bnds >= fst bnds )+                   MkBranches (listArray bnds brs)+  where+    bnds = (0, length brs - 1)++unbranched :: CoAxBranch -> Branches Unbranched+unbranched br = MkBranches (listArray (0, 0) [br])++toBranched :: Branches br -> Branches Branched+toBranched = MkBranches . unMkBranches++toUnbranched :: Branches br -> Branches Unbranched+toUnbranched (MkBranches arr) = assert (bounds arr == (0,0) )+                                MkBranches arr++fromBranches :: Branches br -> [CoAxBranch]+fromBranches = elems . unMkBranches++branchesNth :: Branches br -> BranchIndex -> CoAxBranch+branchesNth (MkBranches arr) n = arr ! n++numBranches :: Branches br -> Int+numBranches (MkBranches arr) = snd (bounds arr) + 1++-- | The @[CoAxBranch]@ passed into the mapping function is a list of+-- all previous branches, reversed+mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch)+                  -> Branches br -> Branches br+mapAccumBranches f (MkBranches arr)+  = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr)))+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_branches cur_branch = ( cur_branch : prev_branches+                                  , f prev_branches cur_branch )+++{-+************************************************************************+*                                                                      *+                    Coercion axioms+*                                                                      *+************************************************************************++Note [Storing compatibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During axiom application, we need to be aware of which branches are compatible+with which others. The full explanation is in Note [Compatibility] in+GHc.Core.FamInstEnv. (The code is placed there to avoid a dependency from+GHC.Core.Coercion.Axiom on the unification algorithm.) Although we could+theoretically compute compatibility on the fly, this is silly, so we store it+in a CoAxiom.++Specifically, each branch refers to all other branches with which it is+incompatible. This list might well be empty, and it will always be for the+first branch of any axiom.++CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk+stored in cab_incomps. The incompatibilities are properly a property of the+axiom as a whole, and they are computed only when the final axiom is built.++During serialization, the list is converted into a list of the indices+of the branches.++Note [CoAxioms are homogeneous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All axioms must be *homogeneous*, meaning that the kind of the LHS must+match the kind of the RHS. In practice, this means:++  Given a CoAxiom { co_ax_tc = ax_tc },+  for every branch CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }:+    typeKind (mkTyConApp ax_tc lhs) `eqType` typeKind rhs++This is checked in FamInstEnv.mkCoAxBranch.+-}++-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data CoAxiom br+  = CoAxiom                   -- Type equality axiom.+    { co_ax_unique   :: Unique        -- Unique identifier+    , co_ax_name     :: Name          -- Name for pretty-printing+    , co_ax_role     :: Role          -- Role of the axiom's equality+    , co_ax_tc       :: TyCon         -- The head of the LHS patterns+                                      -- e.g.  the newtype or family tycon+    , co_ax_branches :: Branches br   -- The branches that form this axiom+    , co_ax_implicit :: Bool          -- True <=> the axiom is "implicit"+                                      -- See Note [Implicit axioms]+         -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1.+    }++-- | A branch of a coercion axiom, which provides the evidence for+-- unwrapping a newtype or a type-family reduction step using a single equation.+data CoAxBranch+  = CoAxBranch+    { cab_loc      :: SrcSpan+        -- ^ Location of the defining equation+        -- See Note [CoAxiom locations]+    , cab_tvs      :: [TyVar]+       -- ^ Bound type variables; not necessarily fresh+       -- See Note [CoAxBranch type variables]+    , cab_eta_tvs  :: [TyVar]+       -- ^ Eta-reduced tyvars+       -- cab_tvs and cab_lhs may be eta-reduced; see+       -- Note [Eta reduction for data families]+    , cab_cvs      :: [CoVar]+      -- ^ Bound coercion variables+       -- Always empty, for now.+       -- See Note [Constraints in patterns]+       -- in GHC.Tc.TyCl+    , cab_roles    :: [Role]+       -- ^ See Note [CoAxBranch roles]+    , cab_lhs      :: [Type]+       -- ^ Type patterns to match against+    , cab_rhs      :: Type+       -- ^ Right-hand side of the equality+       -- See Note [CoAxioms are homogeneous]+    , cab_incomps  :: [CoAxBranch]+       -- ^ The previous incompatible branches+       -- See Note [Storing compatibility]+    }+  deriving Data.Data++toBranchedAxiom :: CoAxiom br -> CoAxiom Branched+toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toBranched branches }++toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched+toUnbranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toUnbranched branches }++coAxiomNumPats :: CoAxiom br -> Int+coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0)++coAxiomArity :: CoAxiom br -> BranchIndex -> Arity+coAxiomArity ax index+  = length tvs + length cvs+  where+    CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index+coAxiomName :: CoAxiom br -> Name+coAxiomName = co_ax_name++coAxiomRole :: CoAxiom br -> Role+coAxiomRole = co_ax_role++coAxiomBranches :: CoAxiom br -> Branches br+coAxiomBranches = co_ax_branches++coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch+coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index+  = branchesNth bs index++coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch+coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })+  = arr ! 0++coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch+coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr })+  | snd (bounds arr) == 0+  = Just $ arr ! 0+  | otherwise+  = Nothing++coAxiomTyCon :: CoAxiom br -> TyCon+coAxiomTyCon = co_ax_tc++coAxBranchTyVars :: CoAxBranch -> [TyVar]+coAxBranchTyVars = cab_tvs++coAxBranchCoVars :: CoAxBranch -> [CoVar]+coAxBranchCoVars = cab_cvs++coAxBranchLHS :: CoAxBranch -> [Type]+coAxBranchLHS = cab_lhs++coAxBranchRHS :: CoAxBranch -> Type+coAxBranchRHS = cab_rhs++coAxBranchRoles :: CoAxBranch -> [Role]+coAxBranchRoles = cab_roles++coAxBranchSpan :: CoAxBranch -> SrcSpan+coAxBranchSpan = cab_loc++isImplicitCoAxiom :: CoAxiom br -> Bool+isImplicitCoAxiom = co_ax_implicit++coAxBranchIncomps :: CoAxBranch -> [CoAxBranch]+coAxBranchIncomps = cab_incomps++-- See Note [Compatibility] in GHC.Core.FamInstEnv+placeHolderIncomps :: [CoAxBranch]+placeHolderIncomps = panic "placeHolderIncomps"++{-+Note [CoAxBranch type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the case of a CoAxBranch of an associated type-family instance,+we use the *same* type variables in cab_tvs (where possible) as the+enclosing class or instance.  Consider++  instance C Int [z] where+     type F Int [z] = ...   -- Second param must be [z]++In the CoAxBranch in the instance decl (F Int [z]) we use the+same 'z', so that it's easy to check that that type is the same+as that in the instance header.++However, I believe that the cab_tvs of any CoAxBranch are distinct+from the cab_tvs of other CoAxBranches in the same CoAxiom.  This is+important when checking for compatiblity and apartness; e.g. see+GHC.Core.FamInstEnv.compatibleBranches.  (The story seems a bit wobbly+here, but it seems to work.)++Note [CoAxBranch roles]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  newtype Age = MkAge Int+  newtype Wrap a = MkWrap a++  convert :: Wrap Age -> Int+  convert (MkWrap (MkAge i)) = i++We want this to compile to:++  NTCo:Wrap :: forall a. Wrap a ~R a+  NTCo:Age  :: Age ~R Int+  convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0])++But, note that NTCo:Age is at role R. Thus, we need to be able to pass+coercions at role R into axioms. However, we don't *always* want to be able to+do this, as it would be disastrous with type families. The solution is to+annotate the arguments to the axiom with roles, much like we annotate tycon+tyvars. Where do these roles get set? Newtype axioms inherit their roles from+the newtype tycon; family axioms are all at role N.++Note [CoAxiom locations]+~~~~~~~~~~~~~~~~~~~~~~~~+The source location of a CoAxiom is stored in two places in the+datatype tree.+  * The first is in the location info buried in the Name of the+    CoAxiom. This span includes all of the branches of a branched+    CoAxiom.+  * The second is in the cab_loc fields of the CoAxBranches.++In the case of a single branch, we can extract the source location of+the branch from the name of the CoAxiom. In other cases, we need an+explicit SrcSpan to correctly store the location of the equation+giving rise to the FamInstBranch.++Note [Implicit axioms]+~~~~~~~~~~~~~~~~~~~~~~+See also Note [Implicit TyThings] in GHC.Types.TyThing+* A CoAxiom arising from data/type family instances is not "implicit".+  That is, it has its own IfaceAxiom declaration in an interface file++* The CoAxiom arising from a newtype declaration *is* "implicit".+  That is, it does not have its own IfaceAxiom declaration in an+  interface file; instead the CoAxiom is generated by type-checking+  the newtype declaration++Note [Eta reduction for data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family T a b :: *+   newtype instance T Int a = MkT (IO a) deriving( Monad )+We'd like this to work.++From the 'newtype instance' you might think we'd get:+   newtype TInt a = MkT (IO a)+   axiom ax1 a :: T Int a ~ TInt a   -- The newtype-instance part+   axiom ax2 a :: TInt a ~ IO a      -- The newtype part++But now what can we do?  We have this problem+   Given:   d  :: Monad IO+   Wanted:  d' :: Monad (T Int) = d |> ????+What coercion can we use for the ???++Solution: eta-reduce both axioms, thus:+   axiom ax1 :: T Int ~ TInt+   axiom ax2 :: TInt ~ IO+Now+   d' = d |> Monad (sym (ax2 ; ax1))++----- Bottom line ------++For a CoAxBranch for a data family instance with representation+TyCon rep_tc:++  - cab_tvs (of its CoAxiom) may be shorter+    than tyConTyVars of rep_tc.++  - cab_lhs may be shorter than tyConArity of the family tycon+       i.e. LHS is unsaturated++  - cab_rhs will be (rep_tc cab_tvs)+       i.e. RHS is un-saturated++  - This eta reduction happens for data instances as well+    as newtype instances. Here we want to eta-reduce the data family axiom.++  - This eta-reduction is done in GHC.Tc.TyCl.Instance.tcDataFamInstDecl.++But for a /type/ family+  - cab_lhs has the exact arity of the family tycon++There are certain situations (e.g., pretty-printing) where it is necessary to+deal with eta-expanded data family instances. For these situations, the+cab_eta_tvs field records the stuff that has been eta-reduced away.+So if we have+    axiom forall a b. F [a->b] = D b a+and cab_eta_tvs is [p,q], then the original user-written definition+looked like+    axiom forall a b p q. F [a->b] p q = D b a p q+(See #9692, #14179, and #15845 for examples of what can go wrong if+we don't eta-expand when showing things to the user.)++See also:++* Note [Newtype eta] in GHC.Core.TyCon.  This is notionally separate+  and deals with the axiom connecting a newtype with its representation+  type; but it too is eta-reduced.+* Note [Implementing eta reduction for data families] in "GHC.Tc.TyCl.Instance". This+  describes the implementation details of this eta reduction happen.+* Note [RoughMap and rm_empty] for how this complicates the RoughMap implementation slightly.+-}++{- *********************************************************************+*                                                                      *+              Instances, especially pretty-printing+*                                                                      *+********************************************************************* -}++instance Eq (CoAxiom br) where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable (CoAxiom br) where+    getUnique = co_ax_unique++instance NamedThing (CoAxiom br) where+    getName = co_ax_name++instance Typeable br => Data.Data (CoAxiom br) where+    -- don't traverse?+    toConstr _   = abstractConstr "CoAxiom"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "CoAxiom"++instance Outputable (CoAxiom br) where+  -- You may want GHC.Core.Coercion.pprCoAxiom instead+  ppr = ppr . getName++instance Outputable CoAxBranch where+  -- This instance doesn't know the name of the type family+  -- If possible, use GHC.Core.Coercion.pprCoAxBranch instead+  ppr (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                  , cab_lhs = lhs_tys, cab_rhs = rhs, cab_incomps = incomps })+    = text "CoAxBranch" <+> braces payload+    where+      payload = hang (text "forall" <+> pprWithCommas pprTyVar (tvs ++ cvs) <> dot)+                   2 (vcat [ text "<tycon>" <+> sep (map pprType lhs_tys)+                           , nest 2 (text "=" <+> ppr rhs)+                           , ppUnless (null incomps) $+                             text "incomps:" <+> vcat (map ppr incomps) ])++{-+************************************************************************+*                                                                      *+                    Roles+*                                                                      *+************************************************************************++Roles are defined here to avoid circular dependencies.+-}++-- These names are slurped into the parser code. Changing these strings+-- will change the **surface syntax** that GHC accepts! If you want to+-- change only the pretty-printing, do some replumbing. See+-- mkRoleAnnotDecl in GHC.Parser.PostProcess+fsFromRole :: Role -> FastString+fsFromRole Nominal          = fsLit "nominal"+fsFromRole Representational = fsLit "representational"+fsFromRole Phantom          = fsLit "phantom"++instance Outputable Role where+  ppr = ftext . fsFromRole++instance Binary Role where+  put_ bh Nominal          = putByte bh 1+  put_ bh Representational = putByte bh 2+  put_ bh Phantom          = putByte bh 3++  get bh = do tag <- getByte bh+              case tag of 1 -> return Nominal+                          2 -> return Representational+                          3 -> return Phantom+                          _ -> panic ("get Role " ++ show tag)++instance NFData Role where+  rnf Nominal = ()+  rnf Representational = ()+  rnf Phantom = ()++{-+************************************************************************+*                                                                      *+                    CoAxiomRule+              Rules for building Evidence+*                                                                      *+************************************************************************++Note [CoAxiomRule]+~~~~~~~~~~~~~~~~~~+A CoAxiomRule is a built-in axiom, one that we assume to be true:+CoAxiomRules come in four flavours:++* BuiltInFamRew: provides evidence for, say+      (ax1)    3+4 ----> 7+      (ax2)    s+0 ----> s+  The evidence looks like+      AxiomCo ax1 [3,4] :: 3+4 ~ 7+      AxiomCo ax2 [s]   :: s+0 ~ s+  The arguments in the AxiomCo are the /instantiating types/, or+  more generally coercions (see Note [Coercion axioms applied to coercions]+  in GHC.Core.TyCo.Rep).++* BuiltInFamInj: provides evidence for the injectivity of type families+  For example+      (ax3)   g1: a+b ~ 0        --->  a~0+      (ax4)   g2: a+b ~ 0        --->  b~0+      (ax5)   g3: a+b1 ~ a~b2    --->  b1~b2+  The argument to the AxiomCo is the full coercion (always just one).+  So then:+      AxiomCo ax3 [g1] :: a ~ 0+      AxiomCo ax4 [g2] :: b ~ 0+      AxiomCo ax5 [g3] :: b1 ~ b2++* BranchedAxiom: used for closed type families+      type family F a where+        F Int  = Bool+        F Bool = Char+        F a    = a -> Int+  We get one (CoAxiom Branched) for the entire family; when used in an+  AxiomCo we pair it with the BranchIndex to say which branch to pick.++* UnbranchedAxiom: used for several purposes;+    - Newtypes+    - Data family instances+    - Open type family instances++Note [Avoiding allocating lots of CoAxiomRules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CoAxiomRule is a sum type of four alternatives, which is very nice. But+there is a danger of allocating lots of (BuiltInFamRew bif) objects, every+time we (say) need a type-family rewrite.++To avoid this allocation, we cache the appropraite CoAxiomRule inside each+   BuiltInFamRewrite, BuiltInFamInjectivity+making a little circular data structure.  See the `bifrw_axr` field of+BuiltInFamRewrite, and similarly the others.++It's simple to do this, and saves a percent or two of allocation in programs+that do a lot of type-family work.+-}++-- | CoAxiomRule describes a built-in axiom, one that we assume to be true+-- See Note [CoAxiomRule]+data CoAxiomRule+  = BuiltInFamRew  BuiltInFamRewrite                   -- Built-in type-family rewrites+                                                       --    e.g.  3+5 ~ 7++  | BuiltInFamInj  BuiltInFamInjectivity               -- Built-in type-family deductions+                                                       --    e.g.  a+b~0 ==>  a~0+                                                       -- Always unary++  | BranchedAxiom      (CoAxiom Branched) BranchIndex  -- Closed type family++  | UnbranchedAxiom    (CoAxiom Unbranched)            -- Open type family instance,+                                                       --    data family instances+                                                       --    and newtypes++instance Eq CoAxiomRule where+  (BuiltInFamRew  bif1)  == (BuiltInFamRew  bif2)  = bifrw_name  bif1 == bifrw_name bif2+  (BuiltInFamInj bif1)   == (BuiltInFamInj bif2)   = bifinj_name bif1 == bifinj_name bif2+  (UnbranchedAxiom ax1)  == (UnbranchedAxiom ax2)  = getUnique ax1 == getUnique ax2+  (BranchedAxiom ax1 i1) == (BranchedAxiom ax2 i2) = getUnique ax1 == getUnique ax2 && i1 == i2+  _ == _ = False++coAxiomRuleRole :: CoAxiomRule -> Role+coAxiomRuleRole (BuiltInFamRew  {})  = Nominal+coAxiomRuleRole (BuiltInFamInj {})   = Nominal+coAxiomRuleRole (UnbranchedAxiom ax) = coAxiomRole ax+coAxiomRuleRole (BranchedAxiom ax _) = coAxiomRole ax++coAxiomRuleArgRoles :: CoAxiomRule -> [Role]+coAxiomRuleArgRoles (BuiltInFamRew  bif) = replicate (bifrw_arity bif) Nominal+coAxiomRuleArgRoles (BuiltInFamInj {})   = [Nominal]+coAxiomRuleArgRoles (UnbranchedAxiom ax) = coAxBranchRoles (coAxiomSingleBranch ax)+coAxiomRuleArgRoles (BranchedAxiom ax i) = coAxBranchRoles (coAxiomNthBranch ax i)++coAxiomRuleBranch_maybe :: CoAxiomRule -> Maybe (TyCon, Role, CoAxBranch)+coAxiomRuleBranch_maybe (UnbranchedAxiom ax) = Just (co_ax_tc ax, co_ax_role ax, coAxiomSingleBranch ax)+coAxiomRuleBranch_maybe (BranchedAxiom ax i) = Just (co_ax_tc ax, co_ax_role ax, coAxiomNthBranch ax i)+coAxiomRuleBranch_maybe _                    = Nothing++isNewtypeAxiomRule_maybe :: CoAxiomRule -> Maybe (TyCon, CoAxBranch)+isNewtypeAxiomRule_maybe (UnbranchedAxiom ax)+  | let tc = coAxiomTyCon ax, isNewTyCon tc = Just (tc, coAxiomSingleBranch ax)+isNewtypeAxiomRule_maybe _                  = Nothing++instance Data.Data CoAxiomRule where+  -- don't traverse?+  toConstr _   = abstractConstr "CoAxiomRule"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoAxiomRule"++instance Outputable CoAxiomRule where+  ppr (BuiltInFamRew  bif) = ppr (bifrw_name bif)+  ppr (BuiltInFamInj bif)  = ppr (bifinj_name bif)+  ppr (UnbranchedAxiom ax) = ppr (coAxiomName ax)+  ppr (BranchedAxiom ax i) = ppr (coAxiomName ax) <> brackets (int i)++{- *********************************************************************+*                                                                      *+                    Built-in families+*                                                                      *+********************************************************************* -}+++-- | A more explicit representation for `t1 ~ t2`.+type TypeEqn = Pair Type++-- Type checking of built-in families+data BuiltInSynFamily = BuiltInSynFamily+  { sfMatchFam :: [BuiltInFamRewrite]+  , sfInteract :: [BuiltInFamInjectivity]+    -- If given these type arguments and RHS, returns the equalities that+    -- are guaranteed to hold.  That is, if+    --     (ar, Pair s1 s2)  is an element of  (sfInteract tys ty)+    -- then  AxiomRule ar [co :: F tys ~ ty]  ::  s1~s2+  }++data BuiltInFamInjectivity  -- Argument and result role are always Nominal+  = BIF_Interact+      { bifinj_name :: FastString+      , bifinj_axr  :: CoAxiomRule -- Cached copy of (BuiltInFamINj this-bif)+                                   -- See Note [Avoiding allocating lots of CoAxiomRules]++      , bifinj_proves :: TypeEqn -> Maybe TypeEqn+            -- ^ Always unary: just one TypeEqn argument+            -- Returns @Nothing@ when it doesn't like the supplied argument.+            -- When this happens in a coercion that means that the coercion is+            -- ill-formed, and Core Lint checks for that.+      }++data BuiltInFamRewrite  -- Argument roles and result role are always Nominal+  = BIF_Rewrite+      { bifrw_name   :: FastString+      , bifrw_axr    :: CoAxiomRule -- Cached copy of (BuiltInFamRew this-bif)+                                    -- See Note [Avoiding allocating lots of CoAxiomRules]++      , bifrw_fam_tc :: TyCon       -- Needed for tyConsOfType++      , bifrw_arity  :: Arity       -- Number of type arguments needed+                                    -- to instantiate this axiom++      , bifrw_match :: [Type] -> Maybe ([Type], Type)+           -- coaxrMatch: does this reduce on the given arguments?+           -- If it does, returns (types to instantiate the rule at, rhs type)+           -- That is: mkAxiomCo ax (zipWith mkReflCo coAxiomRuleArgRoles ts)+           --              :: F tys ~N rhs,++      , bifrw_proves :: [TypeEqn] -> Maybe TypeEqn }+           -- length(inst_tys) = bifrw_arity++      -- INVARIANT: bifrw_match and bifrw_proves are related as follows:+      -- If    Just (inst_tys, res_ty) = bifrw_match ax arg_tys+      -- then  * length arg_tys = tyConArity fam_tc+      --       * length inst_tys = bifrw_arity+       --      * bifrw_proves (map (return @Pair) inst_tys) = Just (return @Pair res_ty)+++-- Provides default implementations that do nothing.+trivialBuiltInFamily :: BuiltInSynFamily+trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = [], sfInteract = [] }
+ GHC/Core/Coercion/Opt.hs view
@@ -0,0 +1,1513 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE CPP #-}++module GHC.Core.Coercion.Opt+   ( optCoercion+   , OptCoercionOpts (..)+   )+where++import GHC.Prelude++import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType, eqForAllVis )+import GHC.Core.Coercion+import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.Unify++import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Data.Pair++import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Monad   ( zipWithM )++{-+%************************************************************************+%*                                                                      *+                 Optimising coercions+%*                                                                      *+%************************************************************************++This module does coercion optimisation.  See the paper++   Evidence normalization in Systtem FV (RTA'13)+   https://simon.peytonjones.org/evidence-normalization/++The paper is also in the GHC repo, in docs/opt-coercion.++Note [Optimising coercion optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Looking up a coercion's role or kind is linear in the size of the+coercion. Thus, doing this repeatedly during the recursive descent+of coercion optimisation is disastrous. We must be careful to avoid+doing this if at all possible.++Because it is generally easy to know a coercion's components' roles+from the role of the outer coercion, we pass down the known role of+the input in the algorithm below. We also keep functions opt_co2+and opt_co3 separate from opt_co4, so that the former two do Phantom+checks that opt_co4 can avoid. This is a big win because Phantom coercions+rarely appear within non-phantom coercions -- only in some TyConAppCos+and some AxiomInstCos. We handle these cases specially by calling+opt_co2.++Note [Optimising InstCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Optimising InstCo is pretty subtle: #15725, #25387.++(1) tv is a type variable. We want to optimise++  InstCo (ForAllCo tv kco g) g2  -->   S(g)++where S is some substitution. Let's look at the typing rules.++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    -----------------------------+    ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco])++    g1 : (all tv:k1.t1') ~ (all tv:k2.t2')+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]++Putting these two together++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo (ForAllCo tv kco g) g2 : t1[tv |-> s1] ~ t2[tv |-> s2 |> sym kco]++We thus want S(g) to have kind++  S(g) :: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym kco])++All we need do is to substitute the coercion tv_co for tv:+  S = [tv :-> tv_co]+where+  tv_co : s1 ~ (s2 |> sym kco)+This looks bizarre, because we're substituting a /type variable/ with a+/coercion/. However, this operation already exists: it's called *lifting*, and+defined in GHC.Core.Coercion.  We just need to enhance the lifting operation to+be able to deal with an ambient substitution, which is why a LiftingContext+stores a TCvSubst.++In general if+  S = [tv :-> tv_co]+  tv_co : r1 ~ r2+  g     : t1 ~ t2+then+  S(g) : t1[tv :-> r1] ~ t2[tv :-> r2]++The substitution S is embodied in the LiftingContext argument of `opt_co4`;+See Note [The LiftingContext in optCoercion]++(2) cv is a coercion variable+Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.++h : (t1 ~r t2) ~N (t3 ~r t4)+cv : t1 ~r t2 |- g : t1' ~r2 t2'+n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3+n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4+------------------------------------------------+ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2+                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])++g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')+g2 : h1 ~N h2+h1 : t1 ~r t2+h2 : t3 ~r t4+------------------------------------------------+InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]++We thus want some coercion proving this:++  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]++So we substitute the coercion variable c for the coercion+(h1 ~N (n1; h2; sym n2)) in g.++Note [The LiftingContext in optCoercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To suppport Note [Optimising InstCo] the coercion optimiser carries a+GHC.Core.Coercion.LiftingContext, which comprises+  * An ordinary Subst+  * The `lc_env`: a mapping from /type variables/ to /coercions/++We don't actually have a separate function+   liftCoSubstCo :: LiftingContext -> Coercion -> Coercion+The substitution of a type variable by a coercion is done by the calls to+`liftCoSubst` (on a type) in the Refl and GRefl cases of `opt_co4`.++We use the following invariants:+ (LC1) The coercions in the range of `lc_env` have already had all substitutions+       applied; they are "OutCoercions".  If you re-optimise these coercions, you+       must zap the LiftingContext first.++ (LC2) However they have /not/ had the "ambient sym" (the second argument of+       `opt_co4`) applied.  The ambient sym applies to the entire coercion not+       to the little bits being substituted.+-}++-- | Coercion optimisation options+newtype OptCoercionOpts = OptCoercionOpts+   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)+   }++optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo+-- ^ optCoercion applies a substitution to a coercion,+--   *and* optimises it to reduce its size+optCoercion opts env co+  | optCoercionEnabled opts+  = optCoercion' env co++{-+  = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $+    let result = optCoercion' env co in+    pprTrace "optCoercion }"+       (vcat [ text "Co:"    <+> ppr (coercionSize co)+             , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)")+                             <+> ppr (coercionSize result) ]) $+    result+-}++  | otherwise+  = substCo env co++optCoercion' :: Subst -> Coercion -> NormalCo+optCoercion' env co+  | debugIsOn+  = let out_co = opt_co1 lc NotSwapped co+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co++        details = vcat [ text "in_co:" <+> ppr co+                       , text "in_ty1:" <+> ppr in_ty1+                       , text "in_ty2:" <+> ppr in_ty2+                       , text "out_co:" <+> ppr out_co+                       , text "out_ty1:" <+> ppr out_ty1+                       , text "out_ty2:" <+> ppr out_ty2+                       , text "in_role:" <+> ppr in_role+                       , text "out_role:" <+> ppr out_role+                       ]+    in+    warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co)+                 "optCoercion: reflexive but not refl" details $+    -- The coercion optimiser should usually optimise+    --     co:ty~ty   -->  Refl ty+    -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N),+    -- and so that can trigger this warning (e.g. test str002).+    -- Maybe we should optimise that coercion to (Refl N), but it+    -- just doesn't seem worth the bother+    out_co++  | otherwise+  = opt_co1 lc NotSwapped co+  where+    lc = mkSubstLiftingContext env+--    ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)+++type NormalCo    = Coercion+  -- Invariants:+  --  * The substitution has been fully applied+  --  * For trans coercions (co1 `trans` co2)+  --       co1 is not a trans, and neither co1 nor co2 is identity++type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity++-- | Do we force the result to be representational?+type ReprFlag = Bool++-- | Optimize a coercion, making no assumptions. All coercions in+-- the lifting context are already optimized (and sym'd if nec'y)+opt_co1 :: LiftingContext+        -> SwapFlag   -- IsSwapped => apply Sym to the result+        -> Coercion -> NormalCo+opt_co1 env sym co = opt_co2 env sym (coercionRole co) co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's role. No other assumptions.+opt_co2 :: LiftingContext+        -> SwapFlag   -- ^IsSwapped => apply Sym to the result+        -> Role       -- ^ The role of the input coercion+        -> Coercion -> NormalCo+opt_co2 env sym Phantom co = opt_phantom env sym co+opt_co2 env sym r       co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's non-Phantom role,+--   and with an optional downgrade+opt_co3 :: LiftingContext -> SwapFlag -> Maybe Role -> Role -> Coercion -> NormalCo+opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co+opt_co3 env sym (Just Representational) r co = opt_co4 env sym True  r co+  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore+opt_co3 env sym _                       r co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a non-phantom coercion.+opt_co4, opt_co4' :: LiftingContext -> SwapFlag -> ReprFlag+                  -> Role -> Coercion -> NormalCo+-- Precondition:  In every call (opt_co4 lc sym rep role co)+--                we should have role = coercionRole co+-- Precondition:  role is not Phantom+-- Postcondition: The resulting coercion is equivalant to+--                     wrapsub (wrapsym (mksub co)+--                 where wrapsym is SymCo if sym=True+--                       wrapsub is SubCo if rep=True++-- opt_co4 is there just to support tracing, when debugging+-- Usually it just goes straight to opt_co4'+opt_co4 = opt_co4'++{-+opt_co4 env sym rep r co+  = pprTrace "opt_co4 {"+   ( vcat [ text "Sym:" <+> ppr sym+          , text "Rep:" <+> ppr rep+          , text "Role:" <+> ppr r+          , text "Co:" <+> ppr co ]) $+   assert (r == coercionRole co )    $+   let result = opt_co4' env sym rep r co in+   pprTrace "opt_co4 }" (ppr co $$ text "---" $$ ppr result) $+   assertPpr (res_role == coercionRole result)+             (vcat [ text "Role:" <+> ppr r+                   , text "Result: " <+>  ppr result+                   , text "Result type:" <+> ppr (coercionType result) ]) $+   result++  where+    res_role | rep       = Representational+             | otherwise = r+-}++opt_co4' env sym rep r (Refl ty)+  = assertPpr (r == Nominal)+              (text "Expected role:" <+> ppr r    $$+               text "Found role:" <+> ppr Nominal $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym rep r (GRefl _r ty MRefl)+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym  rep r (GRefl _r ty (MCo kco))+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    if isGReflCo kco || isGReflCo kco'+    then wrapSym sym ty_co+    else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co+            -- ty :: k1+            -- kco :: k1 ~ k2+            -- Desired result coercion:   ty ~ ty |> co+  where+    r'    = chooseRole rep r+    ty_co = liftCoSubst r' env ty+    kco'  = opt_co4 env NotSwapped False Nominal kco++opt_co4' env sym rep r (SymCo co)  = opt_co4 env (flipSwap sym) rep r co+  -- surprisingly, we don't have to do anything to the env here. This is+  -- because any "lifting" substitutions in the env are tied to ForAllCos,+  -- which treat their left and right sides differently. We don't want to+  -- exchange them.++opt_co4' env sym rep r g@(TyConAppCo _r tc cos)+  = assert (r == _r) $+    case (rep, r) of+      (True, Nominal) ->+        mkTyConAppCo Representational tc+                     (zipWith3 (opt_co3 env sym)+                               (map Just (tyConRoleListRepresentational tc))+                               (repeat Nominal)+                               cos)+      (False, Nominal) ->+        mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos)+      (_, Representational) ->+                      -- must use opt_co2 here, because some roles may be P+                      -- See Note [Optimising coercion optimisation]+        mkTyConAppCo r tc (zipWith (opt_co2 env sym)+                                   (tyConRoleListRepresentational tc)  -- the current roles+                                   cos)+      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)++opt_co4' env sym rep r (AppCo co1 co2)+  = mkAppCo (opt_co4 env sym rep r co1)+            (opt_co4 env sym False Nominal co2)++opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                                 , fco_kind = k_co, fco_body = co })+  = mkForAllCo tv' visL' visR' k_co' $+    opt_co4 env' sym rep r co+     -- Use the "mk" functions to check for nested Refls+  where+    !(env', tv', k_co') = optForAllCoBndr env sym tv k_co+    !(visL', visR') = swapSym sym (visL, visR)++opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2)+  = assert (r == _r) $+    mkFunCo2 r' afl' afr' cow' co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    cow' = opt_co1 env sym cow+    !r' | rep       = Representational+        | otherwise = r+    !(afl', afr') = swapSym sym (afl, afr)++opt_co4' env sym rep r (CoVarCo cv)+  | Just co <- lcLookupCoVar env cv   -- see Note [Forall over coercion] for why+                                      -- this is the right thing here+  = -- pprTrace "CoVarCo" (ppr cv $$ ppr co) $+    opt_co4 (zapLiftingContext env) sym rep r co++  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]+  = mkReflCo (chooseRole rep r) ty1++  | otherwise+  = assert (isCoVar cv1) $+    wrapRole rep r $ wrapSym sym $+    CoVarCo cv1++  where+    Pair ty1 ty2 = coVarTypes cv1++    cv1 = case lookupInScope (lcInScopeSet env) cv of+             Just cv1 -> cv1+             Nothing  -> warnPprTrace True+                          "opt_co: not in scope"+                          (ppr cv $$ ppr env)+                          cv+          -- cv1 might have a substituted kind!++opt_co4' _ _ _ _ (HoleCo h)+  = pprPanic "opt_univ fell into a hole" (ppr h)++opt_co4' env sym rep r (AxiomCo con cos)+    -- Do *not* push sym inside top-level axioms+    -- e.g. if g is a top-level axiom+    --   g a : f a ~ a+    -- then (sym (g ty)) /= g (sym ty) !!+  = assert (r == coAxiomRuleRole con )+    wrapRole rep (coAxiomRuleRole con) $+    wrapSym sym $+                       -- some sub-cos might be P: use opt_co2+                       -- See Note [Optimising coercion optimisation]+    AxiomCo con (zipWith (opt_co2 env NotSwapped)+                         (coAxiomRuleArgRoles con)+                         cos)+      -- Note that the_co does *not* have sym pushed into it++opt_co4' env sym rep r (UnivCo { uco_prov = prov, uco_lty = t1+                              , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps (chooseRole rep r) t1 t2++opt_co4' env sym rep r (TransCo co1 co2)+  -- sym (g `o` h) = sym h `o` sym g+  | isSwapped sym = opt_trans in_scope co2' co1'+  | otherwise     = opt_trans in_scope co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    in_scope = lcInScopeSet env++opt_co4' env sym rep r (SelCo cs co)+  -- Historical note 1: we used to check `co` for Refl, TyConAppCo etc+  -- before optimising `co`; but actually the SelCo will have been built+  -- with mkSelCo, so these tests always fail.++  -- Historical note 2: if rep=True and r=Nominal, we used to recursively+  -- call opt_co4 to re-optimse the result. But (a) that is inefficient+  -- and (b) wrapRole uses mkSubCo which does much the same job+  = wrapRole rep r $ mkSelCo cs $ opt_co1 env sym co++opt_co4' env sym rep r (LRCo lr co)+  | Just pr_co <- splitAppCo_maybe co+  = assert (r == Nominal )+    opt_co4 env sym rep Nominal (pick_lr lr pr_co)+  | Just pr_co <- splitAppCo_maybe co'+  = assert (r == Nominal) $+    if rep+    then opt_co4 (zapLiftingContext env) NotSwapped True Nominal (pick_lr lr pr_co)+    else pick_lr lr pr_co+  | otherwise+  = wrapRole rep Nominal $ LRCo lr co'+  where+    co' = opt_co4 env sym False Nominal co++    pick_lr CLeft  (l, _) = l+    pick_lr CRight (_, r) = r++{-+Note [Forall over coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example:+  type (:~:) :: forall k. k -> k -> Type+  Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b+  k1,k2,k3,k4 :: Type+  eta :: (k1 ~# k2) ~# (k3 ~# k4)    ==    ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4)+  co1_3 :: k1 ~# k3+  co2_4 :: k2 ~# k4+  nth 2 eta :: k1 ~# k3+  nth 3 eta :: k2 ~# k4+  co11_31 :: <k1> ~# (sym co1_3)+  co22_24 :: <k2> ~# co2_4+  (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) ::+    (forall (cv :: k1 ~# k2). Refl Type k1 k2 (<k1> ;; cv ;; <k2>) ~#+    (forall (cv :: k3 ~# k4). Refl Type k3 k4+       (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))+  co1_2 :: k1 ~# k2+  co3_4 :: k3 ~# k4+  co5 :: co1_2 ~# co3_4+  InstCo (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 ::+   (Refl Type k1 k2 (<k1> ;; cv ;; <k2>))[cv |-> co1_2] ~#+   (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4]+      ==+   (Refl Type k1 k2 (<k1> ;; co1_2 ;; <k2>)) ~#+    (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4))+      ==>+   Refl <Type> co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24)+Conclusion: Because of the way this all works, we want to put in the *left-hand*+coercion in co5's type. (In the code, co5 is called `arg`.)+So we extend the environment binding cv to arg's left-hand type.+-}++-- See Note [Optimising InstCo]+opt_co4' env sym rep r (InstCo fun_co arg_co)+    -- forall over type...+  | Just (tv, _visL, _visR, k_co, body_co) <- splitForAllCo_ty_maybe fun_co+    -- tv      :: k1+    -- k_co    :: k1 ~ k2+    -- body_co :: t1 ~ t2+    -- arg_co  :: (s1:k1) ~ (s2:k2)+  , let arg_co'  = opt_co4 env NotSwapped False Nominal arg_co+                  -- Do /not/ push Sym into the arg_co, hence sym=False+                  -- see (LC2) of Note [The LiftingContext in optCoercion]+        k_co' = opt_co4 env NotSwapped False Nominal k_co+        s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+                   -- mkSymCo kind_co :: k2 ~ k1+                   -- tv_co   :: (s1 :: k1) ~ (((s2 :: k2) |> (sym kind_co)) :: k1)+  = opt_co4 (extendLiftingContext env tv tv_co) sym rep r body_co++    -- See Note [Forall over coercion]+  | Just (cv, _visL, _visR, _kind_co, body_co) <- splitForAllCo_co_maybe fun_co+  , CoercionTy h1 <- coercionLKind arg_co+  , let h1' = opt_co4 env NotSwapped False Nominal h1+  = opt_co4 (extendLiftingContextCvSubst env cv h1') sym rep r body_co++  -- OK so those cases didn't work.  See if it is a forall /after/ optimization+  -- If so, do an inefficient one-variable substitution, then re-optimize++    -- forall over type...+  | Just (tv', _visL, _visR, k_co', body_co') <- splitForAllCo_ty_maybe fun_co'+  , let s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+        env'  = extendLiftingContext (zapLiftingContext env) tv' tv_co+  = opt_co4 env' NotSwapped False r' body_co'++    -- See Note [Forall over coercion]+  | Just (cv', _visL, _visR, _kind_co', body_co') <- splitForAllCo_co_maybe fun_co'+  , CoercionTy h1' <- coercionLKind arg_co'+  , let env' = extendLiftingContextCvSubst (zapLiftingContext env) cv' h1'+  = opt_co4 env' NotSwapped False r' body_co'++  -- Those cases didn't work either, so rebuild the InstCo+  -- Push Sym into /both/ function /and/ arg_coument+  | otherwise = InstCo fun_co' arg_co'++  where+    -- fun_co' arg_co' are both optimised, /and/ we have pushed `sym` into both+    -- So no more sym'ing on th results of fun_co' arg_co'+    fun_co' = opt_co4 env sym rep r fun_co+    arg_co' = opt_co4 env sym False Nominal arg_co+    r'   = chooseRole rep r++opt_co4' env sym _rep r (KindCo co)+  = assert (r == Nominal) $+    let kco' = promoteCoercion co in+    case kco' of+      KindCo co' -> promoteCoercion (opt_co1 env sym co')+      _          -> opt_co4 env sym False Nominal kco'+  -- This might be able to be optimized more to do the promotion+  -- and substitution/optimization at the same time++opt_co4' env sym _ r (SubCo co)+  = assert (r == Representational) $+    opt_co4 env sym True Nominal co++{- Note [Optimise CoVarCo to Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (c :: t~t) we can optimise it to Refl. That increases the+chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)++We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]+in GHC.Core.Coercion.+-}++-------------+-- | Optimize a phantom coercion. The input coercion may not necessarily+-- be a phantom, but the output sure will be.+opt_phantom :: LiftingContext -> SwapFlag -> Coercion -> NormalCo+opt_phantom env sym (UnivCo { uco_prov = prov, uco_lty = t1+                            , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps Phantom t1 t2++opt_phantom env sym co+  = opt_univ env sym PhantomProv [mkKindCo co] Phantom ty1 ty2+  where+    Pair ty1 ty2 = coercionKind co++{- Note [Differing kinds]+   ~~~~~~~~~~~~~~~~~~~~~~+The two types may not have the same kind (although that would be very unusual).+But even if they have the same kind, and the same type constructor, the number+of arguments in a `CoTyConApp` can differ. Consider++  Any :: forall k. k++  Any @Type Int                :: Type+  Any @(Type->Type) Maybe Int  :: Type++Hence the need to compare argument lengths; see #13658++Note [opt_univ needs injectivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it+by producing a TyConAppCo for T, and pushing the UnivCo into the arguments.  But+this works only if T is injective. Otherwise we can have something like++  type family F x where+    F Int  = Int+    F Bool = Int++where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an+alternative representation for a couple of uses of AxiomInstCos) but we do not+want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly+inconsistent.  Hence the opt_univ case for TyConApps checks isInjectiveTyCon.+See #19509.++ -}++opt_univ :: LiftingContext -> SwapFlag -> UnivCoProvenance+         -> [Coercion]+         -> Role -> Type -> Type -> Coercion+opt_univ env sym prov deps role ty1 ty2+  = let ty1'  = substTyUnchecked (lcSubstLeft  env) ty1+        ty2'  = substTyUnchecked (lcSubstRight env) ty2+        deps' = map (opt_co1 env sym) deps+        (ty1'', ty2'') = swapSym sym (ty1', ty2')+    in+    mkUnivCo prov deps' role ty1'' ty2''++{-+opt_univ env PhantomProv cvs _r ty1 ty2+  = mkUnivCo PhantomProv cvs Phantom ty1' ty2'+  where+    ty1' = substTy (lcSubstLeft  env) ty1+    ty2' = substTy (lcSubstRight env) ty2++opt_univ1 env prov cvs' role oty1 oty2+  | Just (tc1, tys1) <- splitTyConApp_maybe oty1+  , Just (tc2, tys2) <- splitTyConApp_maybe oty2+  , tc1 == tc2+  , isInjectiveTyCon tc1 role  -- see Note [opt_univ needs injectivity]+  , equalLength tys1 tys2 -- see Note [Differing kinds]+      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);+      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps+  = let roles    = tyConRoleListX role tc1+        arg_cos  = zipWith3 (mkUnivCo prov cvs') roles tys1 tys2+        arg_cos' = zipWith (opt_co4 env False False) roles arg_cos+    in+    mkTyConAppCo role tc1 arg_cos'++  -- can't optimize the AppTy case because we can't build the kind coercions.++  | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isTyVar tv2+      -- NB: prov isn't interesting here either+  = let k1   = tyVarKind tv1+        k2   = tyVarKind tv2+        eta  = mkUnivCo prov cvs' Nominal k1 k2+          -- eta gets opt'ed soon, but not yet.+        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2++        (env', tv1', eta') = optForAllCoBndr env False tv1 eta+    in+    mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isCoVar cv2+      -- NB: prov isn't interesting here either+  = let k1    = varType cv1+        k2    = varType cv2+        r'    = coVarRole cv1+        eta   = mkUnivCo prov cvs' Nominal k1 k2+        eta_d = downgradeRole r' Nominal eta+          -- eta gets opt'ed soon, but not yet.+        n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`+                (mkCoVarCo cv1) `mkTransCo`+                (mkSelCo (SelTyCon 3 r') eta_d)+        ty2'  = substTyWithCoVars [cv2] [n_co] ty2++        (env', cv1', eta') = optForAllCoBndr env False cv1 eta+    in+    mkForAllCo cv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | otherwise+  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1+        ty2 = substTyUnchecked (lcSubstRight env) oty2+    in+    mkUnivCo prov cvs' role ty1 ty2+-}++-------------+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]+opt_transList is = zipWithEqual (opt_trans is)+  -- The input lists must have identical length.++opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo++-- opt_trans just allows us to add some debug tracing+-- Usually it just goes to opt_trans'+opt_trans is co1 co2+  = -- (if coercionRKind co1 `eqType` coercionLKind co2+    --  then (\x -> x) else+    --  pprTrace "opt_trans" (vcat [ text "co1" <+> ppr co1+    --                             , text "co2" <+> ppr co2+    --                             , text "co1 kind" <+> ppr (coercionKind co1)+    --                             , text "co2 kind" <+> ppr (coercionKind co2)+    --                             , callStackDoc ])) $+    opt_trans' is co1 co2++{-+opt_trans is co1 co2+  = assertPpr (r1==r2) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2]) $+    assertPpr (rres == r1) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2, text "res" <+> ppr rres <+> ppr res ]) $+    res+  where+    res = opt_trans' is co1 co2+    rres = coercionRole res+    r1 = coercionRole co1+    r2 = coercionRole co1+-}++opt_trans' :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo+opt_trans' is co1 co2+  | isReflCo co1 = co2+    -- optimize when co1 is a Refl Co+  | otherwise    = opt_trans1 is co1 co2++opt_trans1 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo+-- First arg is not the identity+opt_trans1 is co1 co2+  | isReflCo co2 = co1+    -- optimize when co2 is a Refl Co+  | otherwise    = opt_trans2 is co1 co2++opt_trans2 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo+-- Neither arg is the identity+opt_trans2 is (TransCo co1a co1b) co2+    -- Don't know whether the sub-coercions are the identity+  = opt_trans is co1a (opt_trans is co1b co2)++opt_trans2 is co1 co2+  | Just co <- opt_trans_rule is co1 co2+  = co++opt_trans2 is co1 (TransCo co2a co2b)+  | Just co1_2a <- opt_trans_rule is co1 co2a+  = if isReflCo co1_2a+    then co2b+    else opt_trans1 is co1_2a co2b++opt_trans2 _ co1 co2+  = mk_trans_co co1 co2+++------+-- Optimize coercions with a top-level use of transitivity.+opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo++opt_trans_rule _ in_co1 in_co2+  | assertPpr (coercionRKind in_co1 `eqType` coercionLKind in_co2)+              (vcat [ text "in_co1" <+> ppr in_co1+                   , text "in_co2" <+> ppr in_co2+                   , text "in_co1 kind" <+> ppr (coercionKind in_co1)+                   , text "in_co2 kind" <+> ppr (coercionKind in_co2)+                   , callStackDoc ]) $+    False+  = panic "opt_trans_rule"  -- This entire equation is purely assertion checking++opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _t2 (MCo co2))+  = assert (r1 == r2) $+    fireTransRule "GRefl" in_co1 in_co2 $+    mk_grefl_right_co r1 t1 (opt_trans is co1 co2)++-- Push transitivity through matching destructors+opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)+  | d1 == d2+  , coercionRole co1 == coercionRole co2+  , co1 `compatible_co` co2+  = fireTransRule "PushNth" in_co1 in_co2 $+    mkSelCo d1 (opt_trans is co1 co2)++opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushLR" in_co1 in_co2 $+    mkLRCo d1 (opt_trans is co1 co2)++-- Push transitivity inside instantiation+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)+  | ty1 `eqCoercion` ty2+  , co1 `compatible_co` co2+  = fireTransRule "TrPushInst" in_co1 in_co2 $+    mkInstCo (opt_trans is co1 co2) ty1++opt_trans_rule _+    in_co1@(UnivCo { uco_prov = p1, uco_role = r1, uco_lty = tyl1, uco_deps = deps1 })+    in_co2@(UnivCo { uco_prov = p2, uco_role = r2, uco_rty = tyr2, uco_deps = deps2 })+  | p1 == p2    -- If the provenances are different, opt'ing will be very confusing+  = assert (r1 == r2) $+    fireTransRule "UnivCo" in_co1 in_co2 $+    mkUnivCo p1 (deps1 ++ deps2) r1 tyl1 tyr2++-- Push transitivity down through matching top-level constructors.+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)+  | tc1 == tc2+  = assert (r1 == r2) $+    fireTransRule "PushTyConApp" in_co1 in_co2 $+    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)++opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)+                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)+  = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case+    assert (afr1 == afl2) $+    fireTransRule "PushFun" in_co1 in_co2 $+    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)+                          (opt_trans is co1a co2a)+                          (opt_trans is co1b co2b)++opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)+  -- Must call opt_trans_rule_app; see Note [EtaAppCo]+  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]++-- Eta rules+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2+  | Just cos2 <- etaTyConAppCo_maybe tc co2+  = fireTransRule "EtaCompL" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)+  | Just cos1 <- etaTyConAppCo_maybe tc co1+  = fireTransRule "EtaCompR" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1@(AppCo co1a co1b) co2+  | Just (co2a,co2b) <- etaAppCo_maybe co2+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++opt_trans_rule is co1 co2@(AppCo co2a co2b)+  | Just (co1a,co1b) <- etaAppCo_maybe co1+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++-- Push transitivity inside forall+-- forall over types.+opt_trans_rule is co1 co2+  | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1+  , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2+  , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  where+  push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ tv1 : eta1 <visL, visM>. r1+    --   co2 = /\ tv2 : eta2 <visM, visR>. r2+    -- Wanted:+    --   /\tv1 : (eta1;eta2) <visL, visR>.  (r1; r2[tv2 |-> tv1 |> eta1])+    = fireTransRule "EtaAllTy_ty" co1 co2 $+      mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is' = is `extendInScopeSet` tv1+      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2++-- Push transitivity inside forall+-- forall over coercions.+opt_trans_rule is co1 co2+  | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1+  , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2+  , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  where+  push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ (cv1 : eta1) <visL, visM>. r1+    --   co2 = /\ (cv2 : eta2) <visM, visR>. r2+    -- Wanted:+    --   n1 = nth 2 eta1+    --   n2 = nth 3 eta1+    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])+    = fireTransRule "EtaAllTy_co" co1 co2 $+      mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is'  = is `extendInScopeSet` cv1+      role = coVarRole cv1+      eta1' = downgradeRole role Nominal eta1+      n1   = mkSelCo (SelTyCon 2 role) eta1'+      n2   = mkSelCo (SelTyCon 3 role) eta1'+      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co`+                                        (mkCoVarCo cv1) `mk_trans_co` n2])+                    r2++-- Push transitivity inside axioms+opt_trans_rule is co1 co2++  -- TrPushAxSym/TrPushSymAx+  -- Put this first!  Otherwise (#23619) we get+  --    newtype N a = MkN a+  --    axN :: forall a. N a ~ a+  -- Now consider (axN ty ; sym (axN ty))+  -- If we put TrPushSymAxR first, we'll get+  --    (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl+  --    --> axN (sym (axN ty))  :: N ty ~ N ty -- Very stupid+  | Just (sym1, axr1, cos1) <- isAxiomCo_maybe co1+  , Just (sym2, axr2, cos2) <- isAxiomCo_maybe co2+  , axr1 == axr2+  , sym1 == flipSwap sym2+  , Just (tc, role, branch) <- coAxiomRuleBranch_maybe axr1+  , let qtvs   = coAxBranchTyVars branch ++ coAxBranchCoVars branch+        lhs    = mkTyConApp tc (coAxBranchLHS branch)+        rhs    = coAxBranchRHS branch+        pivot_tvs = exactTyCoVarsOfType (pickSwap sym2 lhs rhs)+  , all (`elemVarSet` pivot_tvs) qtvs+  = fireTransRule "TrPushAxSym" co1 co2 $+    if isSwapped sym2+       -- TrPushAxSym+    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs+       -- TrPushSymAx+    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs++  -- See Note [Push transitivity inside axioms] and+  -- Note [Push transitivity inside newtype axioms only]+  -- TrPushSymAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , isSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is (map mkSymCo cos2) cos1)+  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst++  -- TrPushAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , notSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxR" co1 co2 newAxInst++  -- TrPushSymAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , isSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos2 (map mkSymCo cos1))+  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst++  -- TrPushAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , notSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxL" co1 co2 newAxInst+++opt_trans_rule _ co1 co2        -- Identity rule+  | let ty1 = coercionLKind co1+        r   = coercionRole co1+        ty2 = coercionRKind co2+  , ty1 `eqType` ty2+  = fireTransRule "RedTypeDirRefl" co1 co2 $+    mkReflCo r ty2++opt_trans_rule _ _ _ = Nothing++-- See Note [EtaAppCo]+opt_trans_rule_app :: InScopeSet+                   -> Coercion   -- original left-hand coercion (printing only)+                   -> Coercion   -- original right-hand coercion (printing only)+                   -> Coercion   -- left-hand coercion "function"+                   -> [Coercion] -- left-hand coercion "args"+                   -> Coercion   -- right-hand coercion "function"+                   -> [Coercion] -- right-hand coercion "args"+                   -> Maybe Coercion+opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs+  | AppCo co1aa co1ab <- co1a+  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | AppCo co2aa co2ab <- co2a+  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | otherwise+  = assert (co1bs `equalLength` co2bs) $+    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $+    let rt1a = coercionRKind co1a++        lt2a = coercionLKind co2a+        rt2a = coercionRole  co2a++        rt1bs = map coercionRKind co1bs+        lt2bs = map coercionLKind co2bs+        rt2bs = map coercionRole co2bs++        kcoa = mkKindCo $ buildCoercion lt2a rt1a+        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs++        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a+        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs+        co2bs'' = zipWith mk_trans_co co2bs' co2bs+    in+    mkAppCos (opt_trans is co1a co2a')+             (zipWith (opt_trans is) co1bs co2bs'')++fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion+fireTransRule _rule _co1 _co2 res+  = Just res++{-+Note [Push transitivity inside axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+opt_trans_rule tries to push transitivity inside axioms to deal with cases like+the following:++    newtype N a = MkN a++    axN :: N a ~R# a++    covar :: a ~R# b+    co1 = axN <a> :: N a ~R# a+    co2 = axN <b> :: N b ~R# b++    co :: a ~R# b+    co = sym co1 ; N covar ; co2++When we are optimising co, we want to notice that the two axiom instantiations+cancel out. This is implemented by rules such as TrPushSymAxR, which transforms+    sym (axN <a>) ; N covar+into+    sym (axN covar)+so that TrPushSymAx can subsequently transform+    sym (axN covar) ; axN <b>+into+    covar+which is much more compact. In some perf test cases this kind of pattern can be+generated repeatedly during simplification, so it is very important we squash it+to stop coercions growing exponentially.  For more details see the paper:++    Evidence normalisation in System FC+    Dimitrios Vytiniotis and Simon Peyton Jones+    RTA'13, 2013+    https://www.microsoft.com/en-us/research/publication/evidence-normalization-system-fc-2/+++Note [Push transitivity inside newtype axioms only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The optimization described in Note [Push transitivity inside axioms] is possible+for both newtype and type family axioms.  However, for type family axioms it is+relatively common to have transitive sequences of axioms instantiations, for+example:++    data Nat = Zero | Suc Nat++    type family Index (n :: Nat) (xs :: [Type]) :: Type where+      Index Zero    (x : xs) = x+      Index (Suc n) (x : xs) = Index n xs++    axIndex :: { forall x::Type. forall xs::[Type]. Index Zero (x : xs) ~ x+               ; forall n::Nat. forall x::Type. forall xs::[Type]. Index (Suc n) (x : xs) ~ Index n xs }++    co :: Index (Suc (Suc Zero)) [a, b, c] ~ c+    co = axIndex[1] <Suc Zero> <a> <[b, c]>+       ; axIndex[1] <Zero> <b> <[c]>+       ; axIndex[0] <c> <[]>++Not only are there no cancellation opportunities here, but calling matchAxiom+repeatedly down the transitive chain is very expensive.  Hence we do not attempt+to push transitivity inside type family axioms.  See #8095, !9210 and related tickets.++This is implemented by opt_trans_rule checking that the axiom is for a newtype+constructor (i.e. not a type family).  Adding these guards substantially+improved performance (reduced bytes allocated by more than 10%) for the tests+CoOpt_Singletons, LargeRecord, T12227, T12545, T13386, T15703, T5030, T8095.++A side benefit is that we do not risk accidentally creating an ill-typed+coercion; see Note [Why call checkAxInstCo during optimisation].++There may exist programs that previously relied on pushing transitivity inside+type family axioms to avoid creating huge coercions, which will regress in+compile time performance as a result of this change.  We do not currently know+of any examples, but if any come to light we may need to reconsider this+behaviour.+++Note [Why call checkAxInstCo during optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: The following is no longer relevant, because we no longer push transitivity+into type family axioms (Note [Push transitivity inside newtype axioms only]).+It is retained for reference in case we change this behaviour in the future.++It is possible that otherwise-good-looking optimisations meet with disaster+in the presence of axioms with multiple equations. Consider++type family Equal (a :: *) (b :: *) :: Bool where+  Equal a a = True+  Equal a b = False+type family Id (a :: *) :: * where+  Id a = a++axEq :: { [a::*].       Equal a a ~ True+        ; [a::*, b::*]. Equal a b ~ False }+axId :: [a::*]. Id a ~ a++co1 = Equal (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool+co2 = axEq[1] <Int> <Bool>+  :: Equal Int Bool ~ False++We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that+co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what+happens when we push the coercions inside? We get++co3 = axEq[1] (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~ False++which is bogus! This is because the type system isn't smart enough to know+that (Id Int) and (Id Bool) are SurelyApart, as they're headed by type+families. At the time of writing, I (Richard Eisenberg) couldn't think of+a way of detecting this any more efficient than just building the optimised+coercion and checking.++Note [EtaAppCo]+~~~~~~~~~~~~~~~+Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd+like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that+the resultant coercions might not be well kinded. Here is an example (things+labeled with x don't matter in this example):++  k1 :: Type+  k2 :: Type++  a :: k1 -> Type+  b :: k1++  h :: k1 ~ k2++  co1a :: x1 ~ (a |> (h -> <Type>)+  co1b :: x2 ~ (b |> h)++  co2a :: a ~ x3+  co2b :: b ~ x4++First, convince yourself of the following:++  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)+  co2a co2b :: a b   ~ x3 x4++  (a |> (h -> <Type>)) (b |> h) `eqType` a b++That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,+where we ignore coercions in types as long as two types' kinds are the same.+In our case, we meet this last condition, because++  (a |> (h -> <Type>)) (b |> h) :: Type+    and+  a b :: Type++So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the+suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the+kinds don't match up.++The solution here is to twiddle the kinds in the output coercions. First, we+need to find coercions++  ak :: kind(a |> (h -> <Type>)) ~ kind(a)+  bk :: kind(b |> h)             ~ kind(b)++This can be done with mkKindCo and buildCoercion. The latter assumes two+types are identical modulo casts and builds a coercion between them.++Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the+output coercions. These are well-kinded.++Also, note that all of this is done after accumulated any nested AppCo+parameters. This step is to avoid quadratic behavior in calling coercionKind.++The problem described here was first found in dependent/should_compile/dynamic-paper.++-}++-----------+swapSym :: SwapFlag -> (a,a) -> (a,a)+swapSym IsSwapped  (x,y) = (y,x)+swapSym NotSwapped (x,y) = (x,y)++wrapSym :: SwapFlag -> Coercion -> Coercion+wrapSym IsSwapped  co = mkSymCo co+wrapSym NotSwapped co = co++-- | Conditionally set a role to be representational+wrapRole :: ReprFlag+         -> Role         -- ^ current role+         -> Coercion -> Coercion+wrapRole False _       = id+wrapRole True  current = downgradeRole Representational current++-- | If we require a representational role, return that. Otherwise,+-- return the "default" role provided.+chooseRole :: ReprFlag+           -> Role    -- ^ "default" role+           -> Role+chooseRole True _ = Representational+chooseRole _    r = r++-----------+isAxiomCo_maybe :: Coercion -> Maybe (SwapFlag, CoAxiomRule, [Coercion])+-- We don't expect to see nested SymCo; and that lets us write a simple,+-- non-recursive function. (If we see a nested SymCo we'll just fail,+-- which is ok.)+isAxiomCo_maybe (SymCo (AxiomCo ax cos)) = Just (IsSwapped,  ax, cos)+isAxiomCo_maybe (AxiomCo ax cos)         = Just (NotSwapped, ax, cos)+isAxiomCo_maybe _                        = Nothing++matchNewtypeBranch :: SwapFlag -- IsSwapped = match LHS, NotSwapped = match RHS+                   -> CoAxiomRule+                   -> Coercion -> Maybe [Coercion]+matchNewtypeBranch sym axr co+  | Just (tc,branch) <- isNewtypeAxiomRule_maybe axr+  , CoAxBranch { cab_tvs = qtvs+               , cab_cvs = []   -- can't infer these, so fail if there are any+               , cab_roles = roles+               , cab_lhs = lhs+               , cab_rhs = rhs } <- branch+  , Just subst <- liftCoMatch (mkVarSet qtvs)+                              (pickSwap sym rhs (mkTyConApp tc lhs))+                              co+  , all (`isMappedByLC` subst) qtvs+  = zipWithM (liftCoSubstTyVar subst) roles qtvs++  | otherwise+  = Nothing++-------------+compatible_co :: Coercion -> Coercion -> Bool+-- Check whether (co1 . co2) will be well-kinded+compatible_co co1 co2+  = x1 `eqType` x2+  where+    x1 = coercionRKind co1+    x2 = coercionLKind co2++-------------+{-+etaForAllCo+~~~~~~~~~~~~~~~~~+(1) etaForAllCo_ty_maybe+Suppose we have++  g : all a1:k1.t1  ~  all a2:k2.t2++but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:++  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))++Call the kind coercion h1 and the body coercion h2. We can see that++  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]++According to the typing rule for ForAllCo, we get that++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])++or++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])++as desired.++(2) etaForAllCo_co_maybe+Suppose we have++  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2++Similarly, we do this++  g' = all c1:h1. h2+     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]+                                              [c1 |-> eta1;c1;sym eta2]++Here,++  h1   = mkSelCo Nominal 0 g       :: (s1~s2)~(s3~s4)+  eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3)+  eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)+  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))+-}+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall tv:kind_co. co)+etaForAllCo_ty_maybe co+  | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co+  = Just (tv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isTyVar tv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal) || (vis1 `eqForAllVis` vis2)+  , let kind_co = mkSelCo SelForAll co+  = Just ( tv1, vis1, vis2, kind_co+         , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co))++  | otherwise+  = Nothing++etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall cv:kind_co. co)+etaForAllCo_co_maybe co+  | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co+  = Just (cv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isCoVar cv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal)+  = let kind_co  = mkSelCo SelForAll co+        r        = coVarRole cv1+        l_co     = mkCoVarCo cv1+        kind_co' = downgradeRole r Nominal kind_co+        r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')+                   `mk_trans_co` l_co+                   `mk_trans_co` mkSelCo (SelTyCon 3 r) kind_co'+    in Just ( cv1, vis1, vis2, kind_co+            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))++  | otherwise+  = Nothing++etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)+-- If possible, split a coercion+--   g :: t1a t1b ~ t2a t2b+-- into a pair of coercions (left g, right g)+etaAppCo_maybe co+  | Just (co1,co2) <- splitAppCo_maybe co+  = Just (co1,co2)+  | (Pair ty1 ty2, Nominal) <- coercionKindRole co+  , Just (_,t1) <- splitAppTy_maybe ty1+  , Just (_,t2) <- splitAppTy_maybe ty2+  , let isco1 = isCoercionTy t1+  , let isco2 = isCoercionTy t2+  , isco1 == isco2+  = Just (LRCo CLeft co, LRCo CRight co)+  | otherwise+  = Nothing++etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]+-- If possible, split a coercion+--       g :: T s1 .. sn ~ T t1 .. tn+-- into [ SelCo (SelTyCon 0)     g :: s1~t1+--      , ...+--      , SelCo (SelTyCon (n-1)) g :: sn~tn ]+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)+  = assert (tc == tc2) $ Just cos2++etaTyConAppCo_maybe tc co+  | not (tyConMustBeSaturated tc)+  , (Pair ty1 ty2, r) <- coercionKindRole co+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2+  , tc1 == tc2+  , isInjectiveTyCon tc r  -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+  , let n = length tys1+  , tys2 `lengthIs` n      -- This can fail in an erroneous program+                           -- E.g. T a ~# T a b+                           -- #14607+  = assert (tc == tc1) $+    Just (decomposeCo n co (tyConRolesX r tc1))+    -- NB: n might be <> tyConArity tc+    -- e.g.   data family T a :: * -> *+    --        g :: T a b ~ T c d++  | otherwise+  = Nothing++{-+Note [Eta for AppCo]+~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: s1 t1 ~ s2 t2++Then we can't necessarily make+   left  g :: s1 ~ s2+   right g :: t1 ~ t2+because it's possible that+   s1 :: * -> *         t1 :: *+   s2 :: (*->*) -> *    t2 :: * -> *+and in that case (left g) does not have the same+kind on either side.++It's enough to check that+  kind t1 = kind t2+because if g is well-kinded then+  kind (s1 t2) = kind (s2 t2)+and these two imply+  kind s1 = kind s2++-}++{- Note [Optimising ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If sym=NotSwapped, optimising ForAllCo is relatively easy:+   opt env (ForAllCo tcv kco bodyco)+     = ForAllCo tcv' (opt env kco) (opt env' bodyco)+     where+       (env', tcv') = substBndr env tcv++Just apply the substitution to the kind of the binder, deal with+shadowing etc, and recurse.  Remember in (ForAllCo tcv kco bodyco)+    varKind tcv = coercionLKind kco++But if sym=Swapped, things are trickier.  Here is an identity that helps:+   Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco)+   = ForAllCo (tv:k2) (Sym kco : k2~k1)+              (Sym (bodyco[tv:->tv:k2 |> Sym kco]))++* We re-type tv:k1 to become tv:k2.+* We push Sym into kco+* We push Sym into bodyco+* BUT we must /also/ remember to replace all occurrences of+      of tv:k1 in bodyco by (tv:k2 |> Sym kco)+  This mirrors what happens in the typing rule for ForAllCo+  See Note [ForAllCo] in GHC.Core.TyCo.Rep++-}+optForAllCoBndr :: LiftingContext -> SwapFlag+                -> TyCoVar -> Coercion+                -> (LiftingContext, TyCoVar, Coercion)+-- See Note [Optimising ForAllCo]+optForAllCoBndr env sym tcv kco+  = (env', tcv', kco')+  where+    kco' = opt_co4 env sym False Nominal kco  -- Push sym into kco+    (env', tcv') = updateLCSubst env upd_subst++    upd_subst :: Subst -> (Subst, TyCoVar)+    upd_subst subst+      | isTyVar tcv = upd_subst_tv subst+      | otherwise   = upd_subst_cv subst++    upd_subst_tv subst+      | notSwapped sym || isReflCo kco' = (subst1, tv1)+      | otherwise                       = (subst2, tv2)+      where+        -- subst1,tv1: apply the substitution to the binder and its kind+        -- NB: varKind tv = coercionLKind kco+        (subst1, tv1) = substTyVarBndr subst tcv+        -- In the Swapped case, we re-kind the type variable, AND+        -- override the substitution for the original variable to the+        -- re-kinded one, suitably casted+        tv2    = tv1 `setTyVarKind` coercionLKind kco'+        subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))+                 `extendSubstInScope` tv2++    upd_subst_cv subst   -- ToDo: probably not right yet+      | notSwapped sym || isReflCo kco' = (subst1, cv1)+      | otherwise                       = (subst2, cv2)+      where+        (subst1, cv1) = substCoVarBndr subst tcv+        cv2    = cv1 `setTyVarKind` coercionLKind kco'+        subst2 = subst1 `extendSubstInScope` cv2+++{- **********************************************************************+%*                                                                      *+       Assertion-checking versions of functions in Coercion.hs+%*                                                                      *+%********************************************************************* -}++-- We can't check the assertions in the "main" functions of these+-- functions, because the assertions don't hold during zonking.+-- But they are fantastically helpful in finding bugs in the coercion+-- optimiser itself, so I have copied them here with assertions.++mk_trans_co :: HasDebugCallStack => Coercion -> Coercion -> Coercion+-- Do assertion checking in mk_trans_co+mk_trans_co co1 co2+  = assertPpr (coercionRKind co1 `eqType` coercionLKind co2)+              (vcat [ text "co1" <+> ppr co1+                    , text "co2" <+> ppr co2+                    , text "co1 kind" <+> ppr (coercionKind co1)+                    , text "co2 kind" <+> ppr (coercionKind co2)+                    , callStackDoc ]) $+    mkTransCo co1 co2++mk_coherence_right_co :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mk_coherence_right_co r ty co co2+  = assertGRefl ty co $+    mkCoherenceRightCo r ty co co2++assertGRefl :: HasDebugCallStack => Type -> Coercion -> r -> r+assertGRefl ty co res+  = assertPpr (typeKind ty `eqType` coercionLKind co)+              (vcat [ pp_ty "ty" ty+                    , pp_co "co" co+                    , callStackDoc ]) $+    res++mk_grefl_right_co :: Role -> Type -> CoercionN -> Coercion+mk_grefl_right_co r ty co+  = assertGRefl ty co $+    mkGReflRightCo r ty co++pp_co :: String -> Coercion -> SDoc+pp_co s co = text s <+> hang (ppr co) 2 (dcolon <+> ppr (coercionKind co))++pp_ty :: String -> Type -> SDoc+pp_ty s ty = text s <+> hang (ppr ty) 2 (dcolon <+> ppr (typeKind ty))+
+ GHC/Core/ConLike.hs view
@@ -0,0 +1,241 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[ConLike]{@ConLike@: Constructor-like things}+-}++++module GHC.Core.ConLike (+          ConLike(..)+        , conLikeConLikeName+        , isVanillaConLike+        , conLikeArity+        , conLikeVisArity+        , conLikeFieldLabels+        , conLikeConInfo+        , conLikeInstOrigArgTys+        , conLikeUserTyVarBinders+        , conLikeExTyCoVars+        , conLikeName+        , conLikeStupidTheta+        , conLikeImplBangs+        , conLikeFullSig+        , conLikeResTy+        , conLikeFieldType+        , conLikeIsInfix+        , conLikeHasBuilder+    ) where++import GHC.Prelude++import GHC.Core.DataCon+import GHC.Core.Multiplicity+import GHC.Core.PatSyn+import GHC.Core.TyCo.Rep (Type, ThetaType)+import GHC.Core.TyCon (tyConDataCons)+import GHC.Core.Type(mkTyConApp)+import GHC.Types.Unique+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Basic++import GHC.Types.GREInfo+import GHC.Types.Var+import GHC.Utils.Misc+import GHC.Utils.Outputable++import Data.Maybe( isJust )+import qualified Data.Data as Data++{-+************************************************************************+*                                                                      *+\subsection{Constructor-like things}+*                                                                      *+************************************************************************+-}++-- | A constructor-like thing+data ConLike = RealDataCon DataCon+             | PatSynCon PatSyn++-- | Is this a \'vanilla\' constructor-like thing+-- (no existentials, no provided constraints)?+isVanillaConLike :: ConLike -> Bool+isVanillaConLike (RealDataCon con) = isVanillaDataCon con+isVanillaConLike (PatSynCon   ps ) = isVanillaPatSyn  ps++conLikeConLikeName :: ConLike -> ConLikeName+conLikeConLikeName (RealDataCon dc) = DataConName (dataConName dc)+conLikeConLikeName (PatSynCon   ps) = PatSynName  (patSynName  ps)++{-+************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq ConLike where+    (==) = eqConLike++eqConLike :: ConLike -> ConLike -> Bool+eqConLike x y = getUnique x == getUnique y++-- There used to be an Ord ConLike instance here that used Unique for ordering.+-- It was intentionally removed to prevent determinism problems.+-- See Note [Unique Determinism] in GHC.Types.Unique.++instance Uniquable ConLike where+    getUnique (RealDataCon dc) = getUnique dc+    getUnique (PatSynCon ps)   = getUnique ps++instance NamedThing ConLike where+    getName (RealDataCon dc) = getName dc+    getName (PatSynCon ps)   = getName ps++instance Outputable ConLike where+    ppr (RealDataCon dc) = ppr dc+    ppr (PatSynCon ps) = ppr ps++instance OutputableBndr ConLike where+    pprInfixOcc (RealDataCon dc) = pprInfixOcc dc+    pprInfixOcc (PatSynCon ps) = pprInfixOcc ps+    pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc+    pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps++instance Data.Data ConLike where+    -- don't traverse?+    toConstr _   = abstractConstr "ConLike"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "ConLike"++-- | Number of value arguments+conLikeArity :: ConLike -> Arity+conLikeArity (RealDataCon data_con) = dataConSourceArity data_con+conLikeArity (PatSynCon pat_syn)    = patSynArity pat_syn++-- | Number of visible arguments+conLikeVisArity :: ConLike -> VisArity+conLikeVisArity (RealDataCon data_con) = dataConVisArity data_con+conLikeVisArity (PatSynCon pat_syn)    = patSynVisArity pat_syn++-- | Names of fields used for selectors+conLikeFieldLabels :: ConLike -> [FieldLabel]+conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con+conLikeFieldLabels (PatSynCon pat_syn)    = patSynFieldLabels pat_syn++-- | The 'ConInfo' (arity and field labels) associated to a 'ConLike'.+conLikeConInfo :: ConLike -> ConInfo+conLikeConInfo con =+  mkConInfo (conLikeConLikeInfo con) (conLikeArity con) (conLikeFieldLabels con)++-- | Compute a 'ConLikeInfo' from a 'ConLike'.+conLikeConLikeInfo :: ConLike -> ConLikeInfo+conLikeConLikeInfo (RealDataCon con)+  = ConIsData { conLikeDataCons = getName <$> tyConDataCons (dataConTyCon con) }+conLikeConLikeInfo (PatSynCon {})+  = ConIsPatSyn++-- | Returns just the instantiated /value/ argument types of a 'ConLike',+-- (excluding dictionary args)+conLikeInstOrigArgTys :: ConLike -> [Type] -> [Scaled Type]+conLikeInstOrigArgTys (RealDataCon data_con) tys =+    dataConInstOrigArgTys data_con tys+conLikeInstOrigArgTys (PatSynCon pat_syn) tys =+    map unrestricted $ patSynInstArgTys pat_syn tys++-- | 'TyVarBinder's for the type variables of the 'ConLike'. For pattern+-- synonyms, this will always consist of the universally quantified variables+-- followed by the existentially quantified type variables. For data+-- constructors, the situation is slightly more complicated—see+-- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon".+conLikeUserTyVarBinders :: ConLike -> [TyVarBinder]+conLikeUserTyVarBinders (RealDataCon data_con) =+    dataConUserTyVarBinders data_con+conLikeUserTyVarBinders (PatSynCon pat_syn) =+    tyVarSpecToBinders $+    patSynUnivTyVarBinders pat_syn ++ patSynExTyVarBinders pat_syn+    -- The order here is because of the order in `GHC.Tc.TyCl.PatSyn`.++-- | Existentially quantified type/coercion variables+conLikeExTyCoVars :: ConLike -> [TyCoVar]+conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1+conLikeExTyCoVars (PatSynCon psyn1)   = patSynExTyVars psyn1++conLikeName :: ConLike -> Name+conLikeName (RealDataCon data_con) = dataConName data_con+conLikeName (PatSynCon pat_syn)    = patSynName pat_syn++-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+-- It is empty for `PatSynCon` as they do not allow such contexts.+-- See @Note [The stupid context]@ in "GHC.Core.DataCon".+conLikeStupidTheta :: ConLike -> ThetaType+conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con+conLikeStupidTheta (PatSynCon {})         = []++-- | 'conLikeHasBuilder' returns True except for+-- uni-directional pattern synonyms, which have no builder+conLikeHasBuilder :: ConLike -> Bool+conLikeHasBuilder (RealDataCon {})    = True+conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn)++-- | Returns the strictness information for each constructor+conLikeImplBangs :: ConLike -> [HsImplBang]+conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con+conLikeImplBangs (PatSynCon pat_syn)    =+    replicate (patSynArity pat_syn) HsLazy++-- | Returns the type of the whole pattern+conLikeResTy :: ConLike -> [Type] -> Type+conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys+conLikeResTy (PatSynCon ps)    tys = patSynInstResTy ps tys++-- | The \"full signature\" of the 'ConLike' returns, in order:+--+-- 1) The universally quantified type variables+--+-- 2) The existentially quantified type/coercion variables+--+-- 3) The equality specification+--+-- 4) The provided theta (the constraints provided by a match)+--+-- 5) The required theta (the constraints required for a match)+--+-- 6) The original argument types (i.e. before+--    any change of the representation of the type)+--+-- 7) The original result type+conLikeFullSig :: ConLike+               -> ([TyVar], [TyCoVar]+                   -- Why tyvars for universal but tycovars for existential?+                   -- See Note [Existential coercion variables] in GHC.Core.DataCon+                  , [EqSpec]+                  , ThetaType      -- Provided theta+                  , ThetaType      -- Required theta+                  , [Scaled Type]  -- Arguments+                  , Type )         -- Result+conLikeFullSig (RealDataCon con) =+  let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con+  -- Required theta is empty as normal data cons require no additional+  -- constraints for a match+  in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty)+conLikeFullSig (PatSynCon pat_syn) =+ let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn+ -- eqSpec is empty+ in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty)++-- | Extract the type for any given labelled field of the 'ConLike'+conLikeFieldType :: ConLike -> FieldLabelString -> Type+conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label+conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label++conLikeIsInfix :: ConLike -> Bool+conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc+conLikeIsInfix (PatSynCon ps)   = patSynIsInfix  ps
+ GHC/Core/DataCon.hs view
@@ -0,0 +1,2016 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[DataCon]{@DataCon@: Data Constructors}+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary++module GHC.Core.DataCon (+        -- * Main data types+        DataCon, DataConRep(..),+        SrcStrictness(..), SrcUnpackedness(..),+        HsSrcBang(..), HsImplBang(..),+        StrictnessMark(..),+        ConTag,+        DataConEnv,++        -- ** Equality specs+        EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,+        eqSpecPair, eqSpecPreds,++        -- ** Field labels+        FieldLabel(..), flLabel, FieldLabelString,++        -- ** Type construction+        mkDataCon, fIRST_TAG,++        -- ** Type deconstruction+        dataConRepType, dataConInstSig, dataConFullSig,+        dataConName, dataConIdentity, dataConTag, dataConTagZ,+        dataConTyCon, dataConOrigTyCon,+        dataConWrapperType,+        dataConNonlinearType,+        dataConDisplayType,+        dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,+        dataConConcreteTyVars,+        dataConUserTyVars, dataConUserTyVarBinders,+        dataConTheta,+        dataConStupidTheta,+        dataConOtherTheta,+        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,+        dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,+        dataConInstUnivs,+        dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,+        dataConSrcBangs,+        dataConSourceArity, dataConVisArity, dataConRepArity,+        dataConIsInfix,+        dataConWorkId, dataConWrapId, dataConWrapId_maybe,+        dataConImplicitTyThings,+        dataConRepStrictness,+        dataConImplBangs, dataConBoxer,++        splitDataProductType_maybe,++        -- ** Predicates on DataCons+        isNullarySrcDataCon, isNullaryRepDataCon,+        isLazyDataConRep,+        isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,+        isUnboxedSumDataCon, isCovertGadtDataCon, isUnaryClassDataCon,+        isVanillaDataCon, isNewDataCon, isTypeDataCon,+        classDataCon, dataConCannotMatch,+        dataConUserTyVarBindersNeedWrapper, checkDataConTyVars,+        isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,+        specialPromotedDc,++        -- ** Promotion related functions+        promoteDataCon+    ) where++import GHC.Prelude++import Language.Haskell.Syntax.Basic+import Language.Haskell.Syntax.Module.Name++import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer )+import GHC.Core.Type as Type+import GHC.Core.Coercion+import GHC.Core.Unify+import GHC.Core.TyCon+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType, eqForAllVis )+import GHC.Core.Multiplicity+import {-# SOURCE #-} GHC.Types.TyThing+import GHC.Types.FieldLabel+import GHC.Types.SourceText+import GHC.Core.Class+import GHC.Types.Name+import GHC.Builtin.Names+import GHC.Core.Predicate+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Basic+import GHC.Data.FastString+import GHC.Unit.Types+import GHC.Utils.Binary+import GHC.Types.Unique.FM ( UniqFM )+import GHC.Types.Unique.Set+import GHC.Builtin.Uniques( mkAlphaTyVarUnique )+import GHC.Data.Graph.UnVar  -- UnVarSet and operations++import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy    as LBS+import qualified Data.Data as Data+import Data.Char+import Data.List( find )+import Control.DeepSeq++{-+Note [Data constructor representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following Haskell data type declaration++        data T = T !Int ![Int]++Using the strictness annotations, GHC will represent this as++        data T = T Int# [Int]++That is, the Int has been unboxed.  Furthermore, the Haskell source construction++        T e1 e2++is translated to++        case e1 of { I# x ->+        case e2 of { r ->+        T x r }}++That is, the first argument is unboxed, and the second is evaluated.  Finally,+pattern matching is translated too:++        case e of { T a b -> ... }++becomes++        case e of { T a' b -> let a = I# a' in ... }++To keep ourselves sane, we name the different versions of the data constructor+differently, as follows in Note [Data Constructor Naming].++The `dcRepType` field of a `DataCon` contains the type of the representation of+the constructor /worker/, also called the Core representation.++The Core representation may differ from the type of the constructor /wrapper/+(built by `mkDataConRep`). Besides unpacking (as seen in the example above),+dictionaries and coercions become explict arguments in the Core representation+of a constructor.++Note that this representation is still *different* from runtime+representation. (Which is what STG uses after unarise).+See Note [Constructor applications in STG] in GHC.Stg.Syntax.+++Note [Data Constructor Naming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each data constructor C has two, and possibly up to four, Names associated with it:++                   OccName   Name space   Name of   Notes+ ---------------------------------------------------------------------------+ The "data con itself"   C     DataName   DataCon   In dom( GlobalRdrEnv )+ The "worker data con"   C     VarName    Id        The worker+ The "wrapper data con"  $WC   VarName    Id        The wrapper+ The "newtype coercion"  :CoT  TcClsName  TyCon++EVERY data constructor (incl for newtypes) has the former two (the+data con itself, and its worker.  But only some data constructors have a+wrapper (see Note [The need for a wrapper]).++Each of these three has a distinct Unique.  The "data con itself" name+appears in the output of the renamer, and names the Haskell-source+data constructor.  The type checker translates it into either the wrapper Id+(if it exists) or worker Id (otherwise).++The data con has one or two Ids associated with it:++The "worker Id", is the actual data constructor.+* Every data constructor (newtype or data type) has a worker++* The worker is very like a primop, in that it has no binding.++* For a *data* type, the worker *is* the data constructor;+  it has no unfolding++* For a *newtype*, the worker has a compulsory unfolding which+  does a cast, e.g.+        newtype T = MkT Int+        The worker for MkT has unfolding+                \\(x:Int). x `cast` sym CoT+  Here CoT is the type constructor, witnessing the FC axiom+        axiom CoT : T = Int++The "wrapper Id", \$WC, goes as follows++* Its type is exactly what it looks like in the source program.++* It is an ordinary function, and it gets a top-level binding+  like any other function.++* The wrapper Id isn't generated for a data type if there is+  nothing for the wrapper to do.  That is, if its defn would be+        \$wC = C++Note [Data constructor workers and wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Algebraic data types+  - Always have a worker, with no unfolding+  - May or may not have a wrapper; see Note [The need for a wrapper]++* Newtypes+  - Always have a worker, which has a compulsory unfolding (just a cast)+  - May or may not have a wrapper; see Note [The need for a wrapper]++* INVARIANT: the dictionary constructor for a class+             never has a wrapper.++* See Note [Data Constructor Naming] for how the worker and wrapper+  are named++* The workers don't take the dcStupidTheta dicts as arguments, while the+  wrappers currently do++* The wrapper (if it exists) takes dcOrigArgTys as its arguments.+  The worker takes dataConRepArgTys as its arguments+  If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys++* The 'NoDataConRep' case of DataConRep is important. Not only is it+  efficient, but it also ensures that the wrapper is replaced by the+  worker (because it *is* the worker) even when there are no+  args. E.g. in+               f (:) x+  the (:) *is* the worker.  This is really important in rule matching,+  (We could match on the wrappers, but that makes it less likely that+  rules will match when we bring bits of unfoldings together.)++Note [The need for a wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why might the wrapper have anything to do?  The full story is+in wrapper_reqd in GHC.Types.Id.Make.mkDataConRep.++* Unboxing strict fields (with -funbox-strict-fields)+        data T = MkT !(Int,Int)+        \$wMkT :: (Int,Int) -> T+        \$wMkT (x,y) = MkT x y+  Notice that the worker has two fields where the wrapper has+  just one.  That is, the worker has type+                MkT :: Int -> Int -> T++* Equality constraints for GADTs+        data T a where { MkT :: a -> T [a] }++  The worker gets a type with explicit equality+  constraints, thus:+        MkT :: forall a b. (a=[b]) => b -> T a++  The wrapper has the programmer-specified type:+        \$wMkT :: a -> T [a]+        \$wMkT a x = MkT [a] a [a] x+  The third argument is a coercion+        [a] :: [a]~[a]++* Data family instances may do a cast on the result++* Type variables may be permuted; see MkId+  Note [Data con wrappers and GADT syntax]++* Datatype contexts require dropping some dictionary arguments.+  See Note [Instantiating stupid theta].++Note [The stupid context]+~~~~~~~~~~~~~~~~~~~~~~~~~+Data types can have a context:++        data (Eq a, Ord b) => T a b = T1 a b | T2 a++And that makes the constructors have a context too. A constructor's context+isn't necessarily the same as the data type's context, however. Per the+Haskell98 Report, the part of the datatype context that is used in a data+constructor is the largest subset of the datatype context that constrains+only the type variables free in the data constructor's field types. For+example, here are the types of T1 and T2:++        T1 :: (Eq a, Ord b) => a -> b -> T a b+        T2 :: (Eq a) => a -> T a b++Notice that T2's context is "thinned". Since its field is of type `a`, only+the part of the datatype context that mentions `a`—that is, `Eq a`—is+included in T2's context. On the other hand, T1's fields mention both `a`+and `b`, so T1's context includes all of the datatype context.++Furthermore, this context pops up when pattern matching+(though GHC hasn't implemented this, but it is in H98, and+I've fixed GHC so that it now does):++        f (T2 x) = x+gets inferred type+        f :: Eq a => T a b -> a++I say the context is "stupid" because the dictionaries passed+are immediately discarded -- they do nothing and have no benefit.+(See Note [Instantiating stupid theta].)+It's a flaw in the language.++GHC has made some efforts to correct this flaw. In GHC, datatype contexts+are not available by default. Instead, one must explicitly opt in to them by+using the DatatypeContexts extension. To discourage their use, GHC has+deprecated DatatypeContexts.++Some other notes about stupid contexts:++* Stupid contexts can interact badly with `deriving`. For instance, it's+  unclear how to make this derived Functor instance typecheck:++    data Eq a => T a = MkT a+      deriving Functor++  This is because the derived instance would need to look something like+  `instance Functor T where ...`, but there is nowhere to mention the+  requisite `Eq a` constraint. For this reason, GHC will throw an error if a+  user attempts to derive an instance for Functor (or a Functor-like class)+  where the last type variable is used in a datatype context. For Generic(1),+  the requirements are even harsher, as stupid contexts are not allowed at all+  in derived Generic(1) instances. (We could consider relaxing this requirement+  somewhat, although no one has asked for this yet.)++  Stupid contexts are permitted when deriving instances of non-Functor-like+  classes, or when deriving instances of Functor-like classes where the last+  type variable isn't mentioned in the stupid context. For example, the+  following is permitted:++    data Show a => T a = MkT deriving Eq++  Note that because of the "thinning" behavior mentioned above, the generated+  Eq instance should not mention `Show a`, as the type of MkT doesn't require+  it. That is, the following should be generated (#20501):++    instance Eq (T a) where+      (MkT == MkT) = True++* It's not obvious how stupid contexts should interact with GADTs. For this+  reason, GHC disallows combining datatype contexts with GADT syntax. As a+  result, dcStupidTheta is always empty for data types defined using GADT+  syntax.++Note [Instantiating stupid theta]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a data type with a "stupid theta" (see+Note [The stupid context]):++  data Ord a => T a = MkT (Maybe a)++We want to generate an Ord constraint for every use of MkT; but+we also want to allow visible type application, such as++   MkT @Int++To achieve this, the wrapper for a data (or newtype) constructor+with a datatype context contains a lambda which drops the dictionary+argments corresponding to the datatype context:++   /\a \(_d:Ord a). MkT @a++Notice that the wrapper discards the dictionary argument d.+We don't need it; it was only there to generate a Wanted constraint.+(That is why it is stupid.)++This all happens in GHC.Types.Id.Make.mkDataConRep.++************************************************************************+*                                                                      *+\subsection{Data constructors}+*                                                                      *+************************************************************************+-}++-- | A data constructor+data DataCon+  = MkData {+        dcName    :: Name,      -- This is the name of the *source data con*+                                -- (see "Note [Data Constructor Naming]" above)+        dcUnique :: Unique,     -- Cached from Name+        dcTag    :: ConTag,     -- ^ Tag, used for ordering 'DataCon's++        -- Running example:+        --+        --      *** As declared by the user+        --  data T a b c where+        --    MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c++        --      *** As represented internally+        --  data T a b c where+        --    MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x)+        --        => x -> y -> T a b c+        --+        -- The next six fields express the type of the constructor, in pieces+        -- e.g.+        --+        --      dcUnivTyVars       = [a,b,c]+        --      dcExTyCoVars       = [x,y]+        --      dcUserTyVarBinders = [c,y,x,b]+        --      dcEqSpec           = [a~(x,y)]+        --      dcOtherTheta       = [x~y, Ord x]+        --      dcOrigArgTys       = [x,y]+        --      dcRepTyCon         = T++        -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE+        -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously,+        -- vanilla datacons guaranteed to have the same type variables as their+        -- parent TyCon, but that seems ugly.) They can be different in the case+        -- where a GADT constructor uses different names for the universal+        -- tyvars than does the tycon. For example:+        --+        --   data H a where+        --     MkH :: b -> H b+        --+        -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH+        -- will be [b].++        dcVanilla :: Bool,      -- True <=> This is a vanilla Haskell 98 data constructor+                                --          Its type is of form+                                --              forall a1..an . t1 -> ... tm -> T a1..an+                                --          No existentials, no coercions, nothing.+                                -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = []+                -- NB 1: newtypes always have a vanilla data con+                -- NB 2: a vanilla constructor can still be declared in GADT-style+                --       syntax, provided its type looks like the above.+                --       The declaration format is held in the TyCon (algTcGadtSyntax)++        -- dcUnivTyVars: Universally-quantified type vars [a,b,c]+        -- INVARIANT: length matches arity of the dcRepTyCon+        -- INVARIANT: result type of data con worker is exactly (T a b c)+        -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with+        --            the tyConTyVars of the parent TyCon+        dcUnivTyVars     :: [TyVar],++        -- Existentially-quantified type and coercion vars [x,y]+        -- For an example involving coercion variables,+        -- Why TyCoVars? See Note [Existential coercion variables]+        dcExTyCoVars     :: [TyCoVar],++        -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames+        -- Reason: less confusing, and easier to generate Iface syntax++        -- The type variables of this data constructor that must be+        -- instantiated to concrete types. For example: the RuntimeRep+        -- variables of unboxed tuples and unboxed sums.+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Utils.Concrete.+        dcConcreteTyVars :: ConcreteTyVars,++        -- The type/coercion vars in the order the user wrote them [c,y,x,b]+        -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is+        --    exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned+        --    with the set of dcUnivTyVars whose tyvars do not appear in dcEqSpec+        -- So dcUserTyVarBinders is a subset of (dcUnivTyVars ++ dcExTyCoVars)+        -- See Note [DataCon user type variable binders]+        dcUserTyVarBinders :: [TyVarBinder],++        dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,+                                -- _as written by the programmer_.+                                -- Only non-dependent GADT equalities (dependent+                                -- GADT equalities are in the covars of+                                -- dcExTyCoVars).++                -- This field allows us to move conveniently between the two ways+                -- of representing a GADT constructor's type:+                --      MkT :: forall a b. (a ~ [b]) => b -> T a+                --      MkT :: forall b. b -> T [b]+                -- Each equality is of the form (a ~ ty), where 'a' is one of+                -- the universally quantified type variables. Moreover, the+                -- only place in the DataCon where this 'a' will occur is in+                -- dcUnivTyVars. See [The dcEqSpec domain invariant].++                -- The next two fields give the type context of the data constructor+                --      (aside from the GADT constraints,+                --       which are given by the dcExpSpec)+                -- In GADT form, this is *exactly* what the programmer writes, even if+                -- the context constrains only universally quantified variables+                --      MkT :: forall a b. (a ~ b, Ord b) => a -> T a b+        dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type+                                    -- other than those in the dcEqSpec++        dcStupidTheta :: ThetaType,     -- The context of the data type declaration+                                        --      data Eq a => T a = ...+                                        -- or, rather, a "thinned" version thereof+                -- "Thinned", because the Report says+                -- to eliminate any constraints that don't mention+                -- tyvars free in the arg types for this constructor.+                -- See Note [The stupid context].+                --+                -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars+                -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon+                --+                -- "Stupid", because the dictionaries aren't used for anything.+                -- Indeed, [as of March 02] they are no longer in the type of+                -- the wrapper Id, because that makes it harder to use the wrap-id+                -- to rebuild values after record selection or in generics.++        dcOrigArgTys :: [Scaled Type],  -- Original argument types+                                        -- (before unboxing and flattening of strict fields)+        dcOrigResTy :: Type,            -- Original result type, as seen by the user+                -- NB: for a data instance, the original user result type may+                -- differ from the DataCon's representation TyCon.  Example+                --      data instance T [a] where MkT :: a -> T [a]+                -- The dcOrigResTy is T [a], but the dcRepTyCon might be R:TList++        -- Now the strictness annotations and field labels of the constructor+        dcSrcBangs :: [HsSrcBang],+                -- See Note [Bangs on data constructor arguments]+                --+                -- The [HsSrcBang] as written by the programmer.+                --+                -- Matches 1-1 with dcOrigArgTys+                -- Hence length = dataConSourceArity dataCon++        dcImplBangs :: [HsImplBang],+                -- The actual decisions made (including failures)+                -- about the original arguments; 1-1 with orig_arg_tys+                -- See Note [Bangs on data constructor arguments]++        dcStricts :: [StrictnessMark],+                -- One mark for every field of the DataCon worker;+                -- if it's empty, then all fields are lazy,+                -- otherwise 1-1 with dataConRepArgTys.+                -- See also Note [Strict fields in Core] in GHC.Core+                -- for the effect on the strictness signature++        dcFields  :: [FieldLabel],+                -- Field labels for this constructor, in the+                -- same order as the dcOrigArgTys;+                -- length = 0 (if not a record) or dataConSourceArity.++        -- The curried worker function that corresponds to the constructor:+        -- It doesn't have an unfolding; the code generator saturates these Ids+        -- and allocates a real constructor when it finds one.+        dcWorkId :: Id,++        -- Constructor representation+        dcRep      :: DataConRep,++        -- Cached; see Note [DataCon arities]+        -- INVARIANT: dcRepArity    == length dataConRepArgTys + count isCoVar (dcExTyCoVars)+        -- INVARIANT: dcSourceArity == length dcOrigArgTys+        dcRepArity    :: Arity,+        dcSourceArity :: Arity,++        -- Result type of constructor is T t1..tn+        dcRepTyCon  :: TyCon,           -- Result tycon, T++        dcRepType   :: Type,    -- Type of the constructor+                                --      forall a x y. (a~(x,y), x~y, Ord x) =>+                                --        x -> y -> T a+                                -- (this is *not* of the constructor wrapper Id:+                                --  see Note [Data constructor representation])+        -- Notice that the existential type parameters come *second*.+        -- Reason: in a case expression we may find:+        --      case (e :: T t) of+        --        MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ...+        -- It's convenient to apply the rep-type of MkT to 't', to get+        --      forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t+        -- and use that to check the pattern.  Mind you, this is really only+        -- used in GHC.Core.Lint.+++        dcInfix :: Bool,        -- True <=> declared infix+                                -- Used for Template Haskell and 'deriving' only+                                -- The actual fixity is stored elsewhere++        dcPromoted :: TyCon    -- The promoted TyCon+                               -- See Note [Promoted data constructors] in GHC.Core.TyCon+  }+++{- Note [Existential coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For now (Aug 2018) we can't write coercion quantifications in source Haskell, but+we can in Core. Consider having:++  data T :: forall k. k -> k -> Constraint where+    MkT :: forall k (a::k) (b::k).+           forall k' (c::k') (co::k'~k).+           (b ~# (c|>co)) => T k a b++  dcUnivTyVars       = [k,a,b]+  dcExTyCoVars       = [k',c,co]+  dcUserTyVarBinders = [k,a,k',c]+  dcEqSpec           = [b ~# (c|>co)]+  dcOtherTheta       = []+  dcOrigArgTys       = []+  dcRepTyCon         = T++Function call 'dataConKindEqSpec' returns [k'~k]++Note [DataCon arities]+~~~~~~~~~~~~~~~~~~~~~~+A `DataCon`'s source and core representation may differ, meaning the source+arity (`dcSourceArity`) and the core representation arity (`dcRepArity`) may+differ too.++Note that the source arity isn't exactly the number of arguments the data con+/wrapper/ has, since `dcSourceArity` doesn't count constraints -- which may+appear in the wrapper through `DatatypeContexts`, or if the constructor stores a+dictionary. In this sense, the source arity counts the number of non-constraint+arguments that appear at the source level.+  On the other hand, the Core representation arity is the number of arguments+of the data constructor in its Core representation, which is also the number+of arguments of the data con /worker/.++The arity might differ since `dcRepArity` takes into account arguments such as+quantified dictionaries and coercion arguments, lifted and unlifted (despite+the unlifted coercion arguments having a zero-width runtime representation).+For example:+   MkT :: Ord a => a -> T a+    dcSourceArity = 1+    dcRepArity    = 2++   MkU :: (b ~ '[]) => U b+    dcSourceArity = 0+    dcRepArity    = 1++The arity might also differ due to unpacking, for example, consider the+following datatype and its wrapper and worker's type:+   data V = MkV !() !Int+   $WMkV :: () -> Int -> V+     MkV :: Int# -> V+As you see, because of unpacking we have both dropped the unit argument and+unboxed the Int. In this case, the source arity (which is the arity of the+wrapper) is 2, while the Core representation arity (the arity of the worker) is 1.+++Note [DataCon user type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A DataCon has two different sets of type variables:++* dcUserTyVarBinders, for the type variables binders in the order in which they+  originally arose in the user-written type signature, and with user-specified+  visibilities.++  - They are the forall'd binders of the data con /wrapper/, which the user calls.++  - With RequiredTypeArguments, some of the foralls may be visible, e.g.+      MkT :: forall a b. forall c -> (a, b, c) -> T a b c+    so the binders are full TyVarBinders, complete with visibilities.++  - Even if we only consider invisible foralls, the order and specificity of+    binders matter for TypeApplications.++* dcUnivTyVars and dcExTyCoVars, for the "true underlying" (i.e. of the data+  con worker) universal type variable and existential type/coercion variables,+  respectively.++  - They (i.e. univ ++ ex) are the forall'd variables of the data con /worker/++  - They do not come equipped with visibilities:+        dcUnivTyVars :: [TyVar]     -- not [TyVarBinder]+        dcExTyCoVars :: [TyCoVar]   -- not [ForAllTyBinder]+    Instead, we treat them as having the Specified (coreTyLamForAllTyFlag)+    visibility. For example:+        wrapper type: forall {a} b. forall c -> ...+        worker type:  forall a b c. ...+    This is a design choice. Reasons:+      * Workers are never called by the user. They are part of the Core+        language where visibilities don't matter as much.+      * Consistency with type lambdas in Core. As Note [Required foralls in Core]+        in GHC.Core.TyCo.Rep explains, (/\a. e) :: (forall a. e_ty), and we need+        a coercion to cast it to (forall a -> e_ty).+    As a consequence, we may need to adjust visibilities with a cast in the+    wrapper. See Note [Flag cast in data con wrappers].++Often (dcUnivTyVars ++ dcExTyCoVars) = binderVars dcUserTyVarBinders; but they+may differ for two reasons, coming next:++--- Reason (R1): Order of quantification in GADT syntax ---++In System FC, data constructor type signatures always quantify over all of+their universal type variables, followed by their existential type variables.+Normally, this isn't a problem, as most datatypes naturally quantify their type+variables in this order anyway. For example:++  data T a b = forall c. MkT b c++Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`,+where k, a, and b are universal and c is existential. (The inferred variable k+isn't available for TypeApplications, hence why it's in braces.) This is a+perfectly reasonable order to use, as the syntax of H98-style datatypes+(+ ExistentialQuantification) suggests it.++Things become more complicated when GADT syntax enters the picture. Consider+this example:++  data X a where+    MkX :: forall b a. b -> Proxy a -> X a++If we adopt the earlier approach of quantifying all the universal variables+followed by all the existential ones, GHC would come up with this type+signature for MkX:++  MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a++But this is not what we want at all! After all, if a user were to use+TypeApplications on MkX, they would expect to instantiate `b` before `a`,+as that's the order in which they were written in the `forall`. (See #11721.)+Instead, we'd like GHC to come up with this type signature:++  MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a++In fact, even if we left off the explicit forall:++  data X a where+    MkX :: b -> Proxy a -> X a++Then a user should still expect `b` to be quantified before `a`, since+according to the rules of TypeApplications, in the absence of `forall` GHC+performs a stable topological sort on the type variables in the user-written+type signature, which would place `b` before `a`.++--- Reason (R2): GADT constructors quantify over different variables ---++GADT constructors may quantify over different variables than the worker+would.  Consider+   data T a b where+      MkT :: forall c d. c -> T [c] d++The dcUserTyVarBinders must be [c, d] -- that's what the user quantified over.+But c is actually existential, as it is not equal to either of the two+universal variables.++Here is what we'll get:++  dcUserTyVarBinders = [c, d]+  dcUnivTyVars = [a, d]+  dcExTyCoVars = [c]++Note that dcUnivTyVars contains `a` from the type header (the `data T a b`)+and `d` from the signature for MkT. This is done because d is used in place+of b in the result of MkT, and so we use the name d for the universal, as that+might improve error messages. On the other hand, we need to use a fresh name+for the first universal (recalling that the result of a worker must be the+type constructor applied to a sequence of plain variables), so we use `a`, from+the header. This choice of universals is made in GHC.Tc.TyCl.mkGADTVars.++Because c is not a universal, it is an existential. Here, we see that (even+ignoring order) dcUserTyVarBinders is not dcUnivTyVars ⋃ dcExTyCoVars, because+the latter has `a` while the former does not. To understand this better, let's+look at this type for the "true underlying" worker data con:++      MkT :: forall a d. forall c. (a ~# [c]) => c -> T a d++We see here that the `a` universal is connected with the `c` existential via+an equality constraint. It will always be the case (see the code in mkGADTVars)+that the universals not mentioned in dcUserTyVarBinders will be used in a+GADT equality -- that is, used on the left-hand side of an element of dcEqSpec:++  dcEqSpec = [a ~# [c]]++Putting this all together, all variables used on the left-hand side of an+equation in the dcEqSpec will be in dcUnivTyVars but *not* in+dcUserTyVarBinders.++--- End of Reasons ---++INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders+consists of:++* The set of tyvars in dcUnivTyVars whose type variables do not appear in+  dcEqSpec, unioned with:++* The set of tyvars (*not* covars) in dcExTyCoVars+  No covars here because because they're not user-written++When comparing for equality, we ignore differences concerning type variables+whose kinds have kind Constraint.++The word "set" is used above because the order in which the tyvars appear in+dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or+dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of+(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the+ordering, they in fact share the same type variables (with the same Uniques). We+sometimes refer to this as "the dcUserTyVarBinders invariant". It is checked+in checkDataConTyVars.++dcUserTyVarBinders, as the name suggests, is the one that users will+see most of the time. It's used when computing the type signature of a+data constructor wrapper (see dataConWrapperType), and as a result,+it's what matters from a TypeApplications perspective.++Note [The dcEqSpec domain invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example of a GADT constructor:++  data Y a where+    MkY :: Bool -> Y Bool++The user-written type of MkY is `Bool -> Y Bool`, but what is the underlying+Core type for MkY? There are two conceivable possibilities:++1. MkY :: forall a. (a ~# Bool) => Bool -> Y a+2. MkY :: forall a. (a ~# Bool) => a    -> Y a++In practice, GHC picks (1) as the Core type for MkY. This is because we+maintain an invariant that the type variables in the domain of dcEqSpec will+only ever appear in the dcUnivTyVars. As a consequence, the type variables in+the domain of dcEqSpec will /never/ appear in the dcExTyCoVars, dcOtherTheta,+dcOrigArgTys, or dcOrigResTy; these can only ever mention variables from+dcUserTyVarBinders, which excludes things in the domain of dcEqSpec.+(See Note [DataCon user type variable binders].) This explains why GHC would+not pick (2) as the Core type, since the argument type `a` mentions a type+variable in the dcEqSpec.++There are certain parts of the codebase where it is convenient to apply the+substitution arising from the dcEqSpec to the dcUnivTyVars in order to obtain+the user-written return type of a GADT constructor. A consequence of the+dcEqSpec domain invariant is that you /never/ need to apply the substitution+to any other part of the constructor type, as they don't require it.+-}++-- | Data Constructor Representation+-- See Note [Data constructor workers and wrappers]+data DataConRep+  = -- NoDataConRep means that the data con has no wrapper+    NoDataConRep++    -- DCR means that the data con has a wrapper+  | DCR { dcr_wrap_id :: Id   -- Takes src args, unboxes/flattens,+                              -- and constructs the representation++        , dcr_boxer   :: DataConBoxer++        , dcr_arg_tys :: [Scaled Type]    -- Final, representation argument types,+                                          -- after unboxing and flattening,+                                          -- and *including* all evidence args++    }++type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon++-------------------------++-- | Haskell Source Bang+--+-- Bangs on data constructor arguments as written by the user, including the+-- source code for exact-printing.+--+-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and+-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we+-- emit a warning (in checkValidDataCon) and treat it like+-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@+--+-- In the AST, the @SourceText@ is hidden inside the extension point+-- 'Language.Haskell.Syntax.Extension.XConDeclField'.+data HsSrcBang+  = HsSrcBang SourceText SrcUnpackedness SrcStrictness -- See Note [Pragma source text] in "GHC.Types.SourceText"+  deriving Data.Data++-- | Haskell Implementation Bang+--+-- Bangs of data constructor arguments as generated by the compiler+-- after consulting HsSrcBang, flags, etc.+data HsImplBang+  = HsLazy    -- ^ Lazy field, or one with an unlifted type+  | HsStrict Bool -- ^ Strict but not unpacked field+                  -- True <=> we could have unpacked, but opted not to+                  -- because of -O0.+                  -- See Note [Detecting useless UNPACK pragmas]+  | HsUnpack (Maybe Coercion)+    -- ^ Strict and unpacked field+    -- co :: arg-ty ~ product-ty HsBang+  deriving Data.Data++++-------------------------+-- StrictnessMark is used to indicate strictness+-- of the DataCon *worker* fields+data StrictnessMark = MarkedStrict | NotMarkedStrict+    deriving Eq++-- | An 'EqSpec' is a tyvar/type pair representing an equality made in+-- rejigging a GADT constructor+data EqSpec = EqSpec TyVar Type++-- | Make a non-dependent 'EqSpec'+mkEqSpec :: TyVar -> Type -> EqSpec+mkEqSpec tv ty = EqSpec tv ty++eqSpecTyVar :: EqSpec -> TyVar+eqSpecTyVar (EqSpec tv _) = tv++eqSpecType :: EqSpec -> Type+eqSpecType (EqSpec _ ty) = ty++eqSpecPair :: EqSpec -> (TyVar, Type)+eqSpecPair (EqSpec tv ty) = (tv, ty)++eqSpecPreds :: [EqSpec] -> ThetaType+eqSpecPreds spec = [ mkNomEqPred (mkTyVarTy tv) ty+                   | EqSpec tv ty <- spec ]++instance Outputable EqSpec where+  ppr (EqSpec tv ty) = ppr (tv, ty)++{- Note [Bangs on data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Int {-# UNPACK #-} !Int Bool++When compiling the module, GHC will decide how to represent+MkT, depending on the optimisation level, and settings of+flags like -funbox-small-strict-fields.++Terminology:+  * HsSrcBang:  What the user wrote+                Constructors: HsSrcBang++  * HsImplBang: What GHC decided+                Constructors: HsLazy, HsStrict, HsUnpack++* If T was defined in this module, MkT's dcSrcBangs field+  records the [HsSrcBang] of what the user wrote; in the example+    [ HsSrcBang _ NoSrcUnpack SrcStrict+    , HsSrcBang _ SrcUnpack SrcStrict+    , HsSrcBang _ NoSrcUnpack NoSrcStrictness]++* However, if T was defined in an imported module, the importing module+  must follow the decisions made in the original module, regardless of+  the flag settings in the importing module.+  Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make++* The dcImplBangs field records the [HsImplBang]+  If T was defined in this module, Without -O the dcImplBangs might be+    [HsStrict _, HsStrict _, HsLazy]+  With -O it might be+    [HsStrict _, HsUnpack _, HsLazy]+  With -funbox-small-strict-fields it might be+    [HsUnpack, HsUnpack _, HsLazy]+  With -XStrictData it might be+    [HsStrict _, HsUnpack _, HsStrict _]++* Core passes will often need to know whether the DataCon worker or wrapper in+  an application is strict in some (lifted) field or not. This is tracked in the+  demand signature attached to a DataCon's worker resp. wrapper Id.++  So if you've got a DataCon dc, you can get the demand signature by+  `idDmdSig (dataConWorkId dc)` and make out strict args by testing with+  `isStrictDmd`. Similarly, `idDmdSig <$> dataConWrapId_maybe dc` gives+  you the demand signature of the wrapper, if it exists.++  These demand signatures are set in GHC.Types.Id.Make.mkDataConWorkId,+  computed from the single source of truth `dataConRepStrictness`, which is+  generated from `dcStricts`.+  Note that `dataConRepStrictness` lines up 1-1 with `idDmdSig (dataConWorkId dc)`.++Note [Detecting useless UNPACK pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to issue a warning when there's an UNPACK pragma in the source code,+but we decided not to unpack.+However, when compiling with -O0, we never unpack, and that'd generate+spurious warnings.+Therefore, we remember in HsStrict a boolean flag, whether we _could_+have unpacked. This flag is set in GHC.Types.Id.Make.dataConSrcToImplBang.+Then, in GHC.Tc.TyCl.checkValidDataCon (sub-function check_bang),+if the user wrote an `{-# UNPACK #-}` pragma (i.e. HsSrcBang contains SrcUnpack)+we consult HsImplBang:++  HsUnpack _     => field unpacked, no warning+                    Example: data T = MkT {-# UNPACK #-} !Int   [with -O]+  HsStrict True  => field not unpacked because -O0, no warning+                    Example: data T = MkT {-# UNPACK #-} !Int   [with -O0]+  HsStrict False => field not unpacked, warning+                    Example: data T = MkT {-# UNPACK #-} !(Int -> Int)+  HsLazy         => field not unpacked, warning+                    This can happen in two scenarios:++                    1) UNPACK without a bang+                    Example: data T = MkT {-# UNPACK #-} Int+                    This will produce a warning about missing ! before UNPACK.++                    2) UNPACK of an unlifted datatype+                    Because of bug #20204, we currently do not unpack type T,+                    and therefore issue a warning:+                    type IntU :: UnliftedType+                    data IntU = IntU Int#+                    data T = Test {-# UNPACK #-} IntU++The boolean flag is used only for this warning.+See #11270 for motivation.++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq DataCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable DataCon where+    getUnique = dcUnique++instance NamedThing DataCon where+    getName = dcName++instance Outputable DataCon where+    ppr con = ppr (dataConName con)++instance OutputableBndr DataCon where+    pprInfixOcc con = pprInfixName (dataConName con)+    pprPrefixOcc con = pprPrefixName (dataConName con)++instance Data.Data DataCon where+    -- don't traverse?+    toConstr _   = abstractConstr "DataCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "DataCon"++instance Outputable HsSrcBang where+    ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark++instance Outputable HsImplBang where+    ppr HsLazy                  = text "Lazy"+    ppr (HsUnpack Nothing)      = text "Unpacked"+    ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)+    ppr (HsStrict b)            = text "StrictNotUnpacked" <> parens (ppr b)++instance Outputable SrcStrictness where+    ppr SrcLazy     = char '~'+    ppr SrcStrict   = char '!'+    ppr NoSrcStrict = empty++instance Outputable SrcUnpackedness where+    ppr SrcUnpack   = text "{-# UNPACK #-}"+    ppr SrcNoUnpack = text "{-# NOUNPACK #-}"+    ppr NoSrcUnpack = empty++instance Outputable StrictnessMark where+    ppr MarkedStrict    = text "!"+    ppr NotMarkedStrict = empty++instance Binary StrictnessMark where+    put_ bh NotMarkedStrict = putByte bh 0+    put_ bh MarkedStrict    = putByte bh 1+    get bh =+      do h <- getByte bh+         case h of+           0 -> return NotMarkedStrict+           1 -> return MarkedStrict+           _ -> panic "Invalid binary format"++instance Binary SrcStrictness where+    put_ bh SrcLazy     = putByte bh 0+    put_ bh SrcStrict   = putByte bh 1+    put_ bh NoSrcStrict = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcLazy+           1 -> return SrcStrict+           _ -> return NoSrcStrict++instance Binary SrcUnpackedness where+    put_ bh SrcNoUnpack = putByte bh 0+    put_ bh SrcUnpack   = putByte bh 1+    put_ bh NoSrcUnpack = putByte bh 2++    get bh =+      do h <- getByte bh+         case h of+           0 -> return SrcNoUnpack+           1 -> return SrcUnpack+           _ -> return NoSrcUnpack++instance NFData SrcStrictness where+  rnf SrcLazy = ()+  rnf SrcStrict = ()+  rnf NoSrcStrict = ()++instance NFData SrcUnpackedness where+  rnf SrcNoUnpack = ()+  rnf SrcUnpack = ()+  rnf NoSrcUnpack = ()++-- | Compare strictness annotations+eqHsBang :: HsImplBang -> HsImplBang -> Bool+eqHsBang HsLazy               HsLazy              = True+eqHsBang (HsStrict _)         (HsStrict _)        = True+eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True+eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))+  = eqType (coercionType c1) (coercionType c2)+eqHsBang _ _                                       = False++isBanged :: HsImplBang -> Bool+isBanged (HsUnpack {}) = True+isBanged (HsStrict {}) = True+isBanged HsLazy        = False++isUnpacked :: HsImplBang -> Bool+isUnpacked (HsUnpack {}) = True+isUnpacked (HsStrict {}) = False+isUnpacked HsLazy        = False++isSrcStrict :: SrcStrictness -> Bool+isSrcStrict SrcStrict = True+isSrcStrict _ = False++isSrcUnpacked :: SrcUnpackedness -> Bool+isSrcUnpacked SrcUnpack = True+isSrcUnpacked _ = False++isMarkedStrict :: StrictnessMark -> Bool+isMarkedStrict NotMarkedStrict = False+isMarkedStrict _               = True   -- All others are strict++cbvFromStrictMark :: StrictnessMark -> CbvMark+cbvFromStrictMark NotMarkedStrict = NotMarkedCbv+cbvFromStrictMark MarkedStrict = MarkedCbv+++{- *********************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+********************************************************************* -}++-- | Build a new data constructor+mkDataCon :: Name+          -> Bool               -- ^ Is the constructor declared infix?+          -> TyConRepName       -- ^  TyConRepName for the promoted TyCon+          -> [HsSrcBang]        -- ^ Strictness/unpack annotations, from user+          -> [HsImplBang]       -- ^ Strictness/unpack annotations, as inferred by the compiler+          -> [StrictnessMark]   -- ^ Strictness marks for the DataCon worker's fields in Core+          -> [FieldLabel]       -- ^ Field labels for the constructor,+                                -- if it is a record, otherwise empty+          -> [TyVar]            -- ^ Universals.+          -> [TyCoVar]          -- ^ Existentials.+          -> ConcreteTyVars+                                -- ^ TyVars which must be instantiated with+                                -- concrete types+          -> [TyVarBinder]      -- ^ User-written 'TyVarBinder's+          -> [EqSpec]           -- ^ GADT equalities+          -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper+          -> [KnotTied (Scaled Type)]    -- ^ Original argument types+          -> KnotTied Type      -- ^ Original result type+          -> PromDataConInfo    -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo'+          -> KnotTied TyCon     -- ^ Representation type constructor+          -> ConTag             -- ^ Constructor tag+          -> ThetaType          -- ^ The "stupid theta", context of the data+                                -- declaration e.g. @data Eq a => T a ...@+          -> Id                 -- ^ Worker Id+          -> DataConRep         -- ^ Representation+          -> DataCon+  -- Can get the tag from the TyCon++mkDataCon name declared_infix prom_info+          arg_stricts  -- Must match orig_arg_tys 1-1+          impl_bangs   -- Must match orig_arg_tys 1-1+          str_marks    -- Must be empty or match dataConRepArgTys 1-1+          fields+          univ_tvs ex_tvs conc_tvs user_tvbs+          eq_spec theta+          orig_arg_tys orig_res_ty rep_info rep_tycon tag+          stupid_theta work_id rep+-- Warning: mkDataCon is not a good place to check certain invariants.+-- If the programmer writes the wrong result type in the decl, thus:+--      data T a where { MkT :: S }+-- then it's possible that the univ_tvs may hit an assertion failure+-- if you pull on univ_tvs.  This case is checked by checkValidDataCon,+-- so the error is detected properly... it's just that assertions here+-- are a little dodgy.++  = con+  where+    is_vanilla = null ex_tvs && null eq_spec && null theta+    str_marks' | not $ any isMarkedStrict str_marks = []+               | otherwise                          = str_marks++    con = MkData {dcName = name, dcUnique = nameUnique name,+                  dcVanilla = is_vanilla, dcInfix = declared_infix,+                  dcUnivTyVars = univ_tvs,+                  dcExTyCoVars = ex_tvs,+                  dcConcreteTyVars = conc_tvs,+                  dcUserTyVarBinders = user_tvbs,+                  dcEqSpec = eq_spec,+                  dcOtherTheta = theta,+                  dcStupidTheta = stupid_theta,+                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,+                  dcRepTyCon = rep_tycon,+                  dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs,+                  dcStricts = str_marks',+                  dcFields = fields, dcTag = tag, dcRepType = rep_ty,+                  dcWorkId = work_id,+                  dcRep = rep,+                  dcSourceArity = length orig_arg_tys,+                  dcRepArity = length rep_arg_tys + count isCoVar ex_tvs,+                  dcPromoted = promoted }++        -- The 'arg_stricts' passed to mkDataCon are simply those for the+        -- source-language arguments.  We add extra ones for the+        -- dictionary arguments right here.++    rep_arg_tys = dataConRepArgTys con++    rep_ty =+      case rep of+        -- If the DataCon has no wrapper, then the worker's type *is* the+        -- user-facing type, so we can simply use dataConWrapperType.+        NoDataConRep -> dataConWrapperType con+        -- If the DataCon has a wrapper, then the worker's type is never seen+        -- by the user. The visibilities we pick do not matter here.+        DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $+                 mkScaledFunctionTys rep_arg_tys $+                 mkTyConApp rep_tycon (mkTyVarTys univ_tvs)+                 -- res_arg_tys is a mixture of TypeLike and ConstraintLike,+                 -- so we don't know which FunTyFlag to use+                 -- Hence using mkScaledFunctionTys.++      -- See Note [Promoted data constructors] in GHC.Core.TyCon+    prom_tv_bndrs = [ mkNamedTyConBinder vis tv+                    | Bndr tv vis <- user_tvbs ]++    fresh_names = freshNames (map getName user_tvbs)+      -- fresh_names: make sure that the "anonymous" tyvars don't+      -- clash in name or unique with the universal/existential ones.+      -- Tiresome!  And unnecessary because these tyvars are never looked at+    prom_arg_bndrs   = [ mkAnonTyConBinder (mkTyVar n t)+     {- Visible -}     | (n,t) <- dropList theta fresh_names `zip` map scaledThing orig_arg_tys ]+    prom_bndrs       = prom_tv_bndrs ++ prom_arg_bndrs+    prom_res_kind    = orig_res_ty+    promoted         = mkPromotedDataCon con name prom_info prom_bndrs+                                         prom_res_kind roles rep_info++    roles = map (\tv -> if isTyVar tv then Nominal else Phantom)+                (univ_tvs ++ ex_tvs)+            ++ map (const Representational) (theta ++ map scaledThing orig_arg_tys)++freshNames :: [Name] -> [Name]+-- Make an infinite list of Names whose Uniques and OccNames+-- differ from those in the 'avoid' list+freshNames avoids+  = [ mkSystemName uniq occ+    | n <- [0..]+    , let uniq = mkAlphaTyVarUnique n+          occ = mkTyVarOccFS (mkFastString ('x' : show n))++    , not (uniq `memberUniqueSet` avoid_uniqs)+    , not (occ `elemOccSet` avoid_occs) ]++  where+    avoid_uniqs :: UniqueSet+    avoid_uniqs = fromListUniqueSet (map getUnique avoids)++    avoid_occs :: OccSet+    avoid_occs = mkOccSet (map getOccName avoids)++-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification+dataConName :: DataCon -> Name+dataConName = dcName++-- | The tag used for ordering 'DataCon's+dataConTag :: DataCon -> ConTag+dataConTag  = dcTag++dataConTagZ :: DataCon -> ConTagZ+dataConTagZ con = dataConTag con - fIRST_TAG++-- | The type constructor that we are building via this data constructor+dataConTyCon :: DataCon -> TyCon+dataConTyCon = dcRepTyCon++-- | The original type constructor used in the definition of this data+-- constructor.  In case of a data family instance, that will be the family+-- type constructor.+dataConOrigTyCon :: DataCon -> TyCon+dataConOrigTyCon dc+  | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc+  | otherwise                                          = dcRepTyCon dc++-- | The representation type of the data constructor, i.e. the sort+-- type that will represent values of this type at runtime+dataConRepType :: DataCon -> Type+dataConRepType = dcRepType++-- | Should the 'DataCon' be presented infix?+dataConIsInfix :: DataCon -> Bool+dataConIsInfix = dcInfix++-- | The universally-quantified type variables of the constructor+dataConUnivTyVars :: DataCon -> [TyVar]+dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs++-- | The existentially-quantified type/coercion variables of the constructor+-- including dependent (kind-) GADT equalities+dataConExTyCoVars :: DataCon -> [TyCoVar]+dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs++-- | Both the universal and existential type/coercion variables of the constructor+dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar]+dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })+  = univ_tvs ++ ex_tvs++-- | Which type variables of this data constructor that must be+-- instantiated to concrete types?+-- For example: the RuntimeRep variables of unboxed tuples and unboxed sums.+--+-- See Note [Representation-polymorphism checking built-ins]+-- in GHC.Tc.Utils.Concrete+dataConConcreteTyVars :: DataCon -> ConcreteTyVars+dataConConcreteTyVars (MkData { dcConcreteTyVars = concs }) = concs++-- See Note [DataCon user type variable binders]+-- | The type variables of the constructor, in the order the user wrote them+dataConUserTyVars :: DataCon -> [TyVar]+dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs++-- See Note [DataCon user type variable binders]+-- | 'TyVarBinder's for the type variables of the constructor, in the order the+-- user wrote them+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]+dataConUserTyVarBinders = dcUserTyVarBinders++-- | Dependent (kind-level) equalities in a constructor.+-- There are extracted from the existential variables.+-- See Note [Existential coercion variables]+dataConKindEqSpec :: DataCon -> [EqSpec]+dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs})+  -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future),+  -- which are frequently used functions.+  -- For now (Aug 2018) this function always return empty set as we don't really+  -- have coercion variables.+  -- In the future when we do, we might want to cache this information in DataCon+  -- so it won't be computed every time when aforementioned functions are called.+  = [ EqSpec tv ty+    | cv <- ex_tcvs+    , isCoVar cv+    , let (ty1, ty, _) = coVarTypesRole cv+          tv = getTyVar ty1+    ]++-- | The *full* constraints on the constructor type, including dependent GADT+-- equalities.+dataConTheta :: DataCon -> ThetaType+dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })+  = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta++-- | Get the Id of the 'DataCon' worker: a function that is the "actual"+-- constructor and has no top level binding in the program. The type may+-- be different from the obvious one written in the source program. Panics+-- if there is no such 'Id' for this 'DataCon'+dataConWorkId :: DataCon -> Id+dataConWorkId dc = dcWorkId dc++-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"+-- constructor so it has the type visible in the source program: c.f.+-- 'dataConWorkId'.+-- Returns Nothing if there is no wrapper, which occurs for an algebraic data+-- constructor and also for a newtype (whose constructor is inlined+-- compulsorily)+dataConWrapId_maybe :: DataCon -> Maybe Id+dataConWrapId_maybe dc = case dcRep dc of+                           NoDataConRep -> Nothing+                           DCR { dcr_wrap_id = wrap_id } -> Just wrap_id++-- | Returns an Id which looks like the Haskell-source constructor by using+-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to+-- the worker (see 'dataConWorkId')+dataConWrapId :: DataCon -> Id+dataConWrapId dc = case dcRep dc of+                     NoDataConRep-> dcWorkId dc    -- worker=wrapper+                     DCR { dcr_wrap_id = wrap_id } -> wrap_id++-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,+-- the union of the 'dataConWorkId' and the 'dataConWrapId'+dataConImplicitTyThings :: DataCon -> [TyThing]+dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })+  = [mkAnId work] ++ wrap_ids+  where+    wrap_ids = case rep of+                 NoDataConRep               -> []+                 DCR { dcr_wrap_id = wrap } -> [mkAnId wrap]++-- | The labels for the fields of this particular 'DataCon'+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConFieldLabels = dcFields++-- | Extract the type for any given labelled field of the 'DataCon'+dataConFieldType :: DataCon -> FieldLabelString -> Type+dataConFieldType con label = case dataConFieldType_maybe con label of+      Just (_, ty) -> ty+      Nothing      -> pprPanic "dataConFieldType" (ppr con <+> ppr label)++-- | Extract the label and type for any given labelled field of the+-- 'DataCon', or return 'Nothing' if the field does not belong to it+dataConFieldType_maybe :: DataCon -> FieldLabelString+                       -> Maybe (FieldLabel, Type)+dataConFieldType_maybe con label+  = find ((== label) . flLabel . fst) (dcFields con `zip` (scaledThing <$> dcOrigArgTys con))++-- | Strictness/unpack annotations, from user; or, for imported+-- DataCons, from the interface file+-- The list is in one-to-one correspondence with the arity of the 'DataCon'++dataConSrcBangs :: DataCon -> [HsSrcBang]+dataConSrcBangs = dcSrcBangs++-- | Number of value arguments of the data constructor+dataConSourceArity :: DataCon -> Arity+dataConSourceArity (MkData { dcSourceArity = arity }) = arity++-- | Number of visible arguments of the data constructor+dataConVisArity :: DataCon -> VisArity+dataConVisArity (MkData { dcUserTyVarBinders = tvbs, dcSourceArity = arity })+  = n_of_required_ty_args + n_of_val_args+  where+    n_of_val_args         = arity+    n_of_required_ty_args = count isVisibleForAllTyBinder tvbs++-- | Gives the number of value arguments (including zero-width coercions)+-- stored by the given `DataCon`'s worker in its Core representation. This may+-- differ from the number of arguments that appear in the source code; see also+-- Note [DataCon arities]+dataConRepArity :: DataCon -> Arity+dataConRepArity (MkData { dcRepArity = arity }) = arity++-- | Return whether there are any argument types for this 'DataCon's original source type+-- See Note [DataCon arities]+isNullarySrcDataCon :: DataCon -> Bool+isNullarySrcDataCon dc = dataConSourceArity dc == 0++-- | Return whether this `DataCon`'s worker, in its Core representation, takes+-- any value arguments.+--+-- In particular, remember that we include coercion arguments in the arity of+-- the Core representation of the `DataCon` -- both lifted and unlifted+-- coercions, despite the latter having zero-width runtime representation.+--+-- See also Note [DataCon arities].+isNullaryRepDataCon :: DataCon -> Bool+isNullaryRepDataCon dc = dataConRepArity dc == 0++isLazyDataConRep :: DataCon -> Bool+-- ^ True <==> All fields are lazy+isLazyDataConRep dc = null (dcStricts dc)++dataConRepStrictness :: DataCon -> [StrictnessMark]+-- ^ Give the demands on the runtime arguments of a Core DataCon worker+-- application.+-- The length of the list matches `dataConRepArgTys` (e.g., the number+-- of runtime arguments).+dataConRepStrictness dc+  | isLazyDataConRep dc+  = replicate (dataConRepArity dc) NotMarkedStrict+  | otherwise+  = dcStricts dc++dataConImplBangs :: DataCon -> [HsImplBang]+-- The implementation decisions about the strictness/unpack of each+-- source program argument to the data constructor+dataConImplBangs dc = dcImplBangs dc++dataConBoxer :: DataCon -> Maybe DataConBoxer+dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer+dataConBoxer _ = Nothing++dataConInstSig+  :: DataCon+  -> [Type]    -- Instantiate the *universal* tyvars with these types+  -> ([TyCoVar], ThetaType, [Type])  -- Return instantiated existentials+                                     -- theta and arg tys+-- ^ Instantiate the universal tyvars of a data con,+--   returning+--     ( instantiated existentials+--     , instantiated constraints including dependent GADT equalities+--         which are *also* listed in the instantiated existentials+--     , instantiated args)+dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs+                           , dcOrigArgTys = arg_tys })+               univ_tys+  = ( ex_tvs'+    , substTheta subst (dataConTheta con)+    , substTys subst (map scaledThing arg_tys))+  where+    univ_subst = zipTvSubst univ_tvs univ_tys+    (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs+++-- | The \"full signature\" of the 'DataCon' returns, in order:+--+-- 1) The result of 'dataConUnivTyVars'+--+-- 2) The result of 'dataConExTyCoVars'+--+-- 3) The non-dependent GADT equalities.+--    Dependent GADT equalities are implied by coercion variables in+--    return value (2).+--+-- 4) The other constraints of the data constructor type, excluding GADT+-- equalities+--+-- 5) The original argument types to the 'DataCon' (i.e. before+--    any change of the representation of the type) with linearity+--    annotations+--+-- 6) The original result type of the 'DataCon'+dataConFullSig :: DataCon+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs,+                        dcEqSpec = eq_spec, dcOtherTheta = theta,+                        dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})+  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)++dataConOrigResTy :: DataCon -> Type+dataConOrigResTy dc = dcOrigResTy dc++-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in:+--+-- > data Eq a => T a = ...+--+-- See @Note [The stupid context]@.+dataConStupidTheta :: DataCon -> ThetaType+dataConStupidTheta dc = dcStupidTheta dc++{-+Note [Displaying linear fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A constructor with a linear field can be written either as+MkT :: a %1 -> T a (with -XLinearTypes)+or+MkT :: a  -> T a (with -XNoLinearTypes)++There are three different methods to retrieve a type of a datacon.+They differ in how linear fields are handled.++1. dataConWrapperType:+The type of the wrapper in Core.+For example, dataConWrapperType for Maybe is a %1 -> Just a.++2. dataConNonlinearType:+The type of the constructor, with linear arrows replaced by unrestricted ones.+Used when we don't want to introduce linear types to user (in holes+and in types in hie used by haddock).++3. dataConDisplayType (takes a boolean indicating if -XLinearTypes is enabled):+The type we'd like to show in error messages, :info and -ddump-types.+Ideally, it should reflect the type written by the user;+the function returns a type with arrows that would be required+to write this constructor under the current setting of -XLinearTypes.+In principle, this type can be different from the user's source code+when the value of -XLinearTypes has changed, but we don't+expect this to cause much trouble.++Due to internal plumbing in checkValidDataCon, we can't just return a Doc.+The multiplicity of arrows returned by dataConDisplayType and+dataConDisplayType is used only for pretty-printing.+-}++dataConWrapperType :: DataCon -> Type+-- ^ The user-declared type of the data constructor+-- in the nice-to-read form:+--+-- > T :: forall a b. a -> b -> T [a]+--+-- rather than:+--+-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c+--+-- The type variables are quantified in the order that the user wrote them.+-- See @Note [DataCon user type variable binders]@.+--+-- NB: If the constructor is part of a data instance, the result type+-- mentions the family tycon, not the internal one.+dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs,+                             dcOtherTheta = theta, dcOrigArgTys = arg_tys,+                             dcOrigResTy = res_ty,+                             dcStupidTheta = stupid_theta })+  = mkForAllTys user_tvbs $+    mkInvisFunTys (stupid_theta ++ theta) $+    mkScaledFunTys arg_tys $+    res_ty++dataConNonlinearType :: DataCon -> Type+-- Just like dataConWrapperType, but with the+-- linearity on the arguments all zapped to Many+dataConNonlinearType (MkData { dcUserTyVarBinders = user_tvbs,+                               dcOtherTheta = theta, dcOrigArgTys = arg_tys,+                               dcOrigResTy = res_ty,+                               dcStupidTheta = stupid_theta })+  = mkForAllTys user_tvbs $+    mkInvisFunTys (stupid_theta ++ theta) $+    mkScaledFunTys arg_tys' $+    res_ty+  where+    arg_tys' = map (\(Scaled w t) -> Scaled (case w of OneTy -> ManyTy; _ -> w) t) arg_tys++dataConDisplayType :: Bool -> DataCon -> Type+dataConDisplayType show_linear_types dc+  = if show_linear_types+    then dataConWrapperType dc+    else dataConNonlinearType dc++-- | Finds the instantiated types of the arguments required to construct a+-- 'DataCon' representation+-- NB: these INCLUDE any dictionary args+--     but EXCLUDE the data-declaration context, which is discarded+-- It's all post-flattening etc; this is a representation type+dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality constraints+                                -- However, it can have a dcTheta (notably it can be a+                                -- class dictionary, with superclasses)+                  -> [Type]     -- ^ Instantiated at these types+                  -> [Scaled Type]+dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,+                              dcExTyCoVars = ex_tvs}) inst_tys+ = assertPpr (univ_tvs `equalLength` inst_tys)+             (text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) $+   assertPpr (null ex_tvs) (ppr dc) $+   map (mapScaledType (substTyWith univ_tvs inst_tys)) (dataConRepArgTys dc)++-- | Returns just the instantiated /value/ argument types of a 'DataCon',+-- (excluding dictionary args)+dataConInstOrigArgTys+        :: DataCon      -- Works for any DataCon+        -> [Type]       -- Includes existential tyvar args, but NOT+                        -- equality constraints or dicts+        -> [Scaled Type]+-- For vanilla datacons, it's all quite straightforward+-- But for the call in GHC.HsToCore.Match.Constructor, we really do want just+-- the value args+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,+                                  dcUnivTyVars = univ_tvs,+                                  dcExTyCoVars = ex_tvs}) inst_tys+  = assertPpr (tyvars `equalLength` inst_tys)+              (text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys) $+    substScaledTys subst arg_tys+  where+    tyvars = univ_tvs ++ ex_tvs+    subst  = zipTCvSubst tyvars inst_tys++-- | Given a data constructor @dc@ with /n/ universally quantified type+-- variables @a_{1}@, @a_{2}@, ..., @a_{n}@, and given a list of argument+-- types @dc_args@ of length /m/ where /m/ <= /n/, then:+--+-- @+-- dataConInstUnivs dc dc_args+-- @+--+-- Will return:+--+-- @+-- [dc_arg_{1}, dc_arg_{2}, ..., dc_arg_{m}, a_{m+1}, ..., a_{n}]+-- @+--+-- That is, return the list of universal type variables with+-- @a_{1}@, @a_{2}@, ..., @a_{m}@ instantiated with+-- @dc_arg_{1}@, @dc_arg_{2}@, ..., @dc_arg_{m}@. It is possible for @m@ to+-- be less than @n@, in which case the remaining @n - m@ elements will simply+-- be universal type variables (with their kinds possibly instantiated).+--+-- Examples:+--+-- * Given the data constructor @D :: forall a b. Foo a b@ and+--   @dc_args@ @[Int, Bool]@, then @dataConInstUnivs D dc_args@ will return+--   @[Int, Bool]@.+--+-- * Given the data constructor @D :: forall a b. Foo a b@ and+--   @dc_args@ @[Int]@, then @@dataConInstUnivs D dc_args@ will return+--   @[Int, b]@.+--+-- * Given the data constructor @E :: forall k (a :: k). Bar k a@ and+--   @dc_args@ @[Type]@, then @@dataConInstUnivs D dc_args@ will return+--   @[Type, (a :: Type)]@.+--+-- This is primarily used in @GHC.Tc.Deriv.*@ in service of instantiating data+-- constructors' field types.+-- See @Note [Instantiating field types in stock deriving]@ for a notable+-- example of this.+dataConInstUnivs :: DataCon -> [Type] -> [Type]+dataConInstUnivs dc dc_args = chkAppend dc_args $ map mkTyVarTy dc_args_suffix+  where+    (dc_univs_prefix, dc_univs_suffix)+                        = -- Assert that m <= n+                          assertPpr (dc_args `leLength` dataConUnivTyVars dc)+                                    (text "dataConInstUnivs"+                                      <+> ppr dc_args+                                      <+> ppr (dataConUnivTyVars dc)) $+                          splitAtList dc_args $ dataConUnivTyVars dc+    (_, dc_args_suffix) = substTyVarBndrs prefix_subst dc_univs_suffix+    prefix_subst        = mkTvSubst prefix_in_scope prefix_env+    prefix_in_scope     = mkInScopeSet $ tyCoVarsOfTypes dc_args+    prefix_env          = zipTyEnv dc_univs_prefix dc_args++-- | Returns the argument types of the wrapper, excluding all dictionary arguments+-- and without substituting for any type variables+dataConOrigArgTys :: DataCon -> [Scaled Type]+dataConOrigArgTys dc = dcOrigArgTys dc++-- | Returns constraints in the wrapper type, other than those in the dataConEqSpec+dataConOtherTheta :: DataCon -> ThetaType+dataConOtherTheta dc = dcOtherTheta dc++-- | Returns the arg types of the worker, including *all* non-dependent+-- evidence, after any flattening has been done and without substituting for+-- any type variables+dataConRepArgTys :: DataCon -> [Scaled Type]+dataConRepArgTys (MkData { dcRep        = rep+                         , dcEqSpec     = eq_spec+                         , dcOtherTheta = theta+                         , dcOrigArgTys = orig_arg_tys+                         , dcRepTyCon   = tc })+  = case rep of+      DCR { dcr_arg_tys = arg_tys } -> arg_tys+      NoDataConRep+        | isTypeDataTyCon tc -> assert (null theta)   $+                                orig_arg_tys+          -- `type data` declarations can be GADTs (and hence have an eq_spec)+          -- but no wrapper.  They cannot have a theta.+          -- See Note [Type data declarations] in GHC.Rename.Module+          -- You might wonder why we ever call dataConRepArgTys for `type data`;+          -- I think it's because of the call in mkDataCon, which in turn feeds+          -- into dcRepArity, which in turn is used in mkDataConWorkId.+          -- c.f. #23022+        | otherwise          -> assert (null eq_spec) $+                                map unrestricted theta ++ orig_arg_tys++-- | The string @package:module.name@ identifying a constructor, which is attached+-- to its info table and used by the GHCi debugger and the heap profiler+dataConIdentity :: DataCon -> ByteString+-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings.+dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat+   [ BSB.shortByteString $ fastStringToShortByteString $+       unitFS $ moduleUnit mod+   , BSB.int8 $ fromIntegral (ord ':')+   , BSB.shortByteString $ fastStringToShortByteString $+       moduleNameFS $ moduleName mod+   , BSB.int8 $ fromIntegral (ord '.')+   , BSB.shortByteString $ fastStringToShortByteString $+       occNameFS $ nameOccName name+   ]+  where name = dataConName dc+        mod  = assert (isExternalName name) $ nameModule name++isTupleDataCon :: DataCon -> Bool+isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc++isBoxedTupleDataCon :: DataCon -> Bool+isBoxedTupleDataCon (MkData {dcRepTyCon = tc}) = isBoxedTupleTyCon tc++isUnboxedTupleDataCon :: DataCon -> Bool+isUnboxedTupleDataCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc++isUnboxedSumDataCon :: DataCon -> Bool+isUnboxedSumDataCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc++-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors+isVanillaDataCon :: DataCon -> Bool+isVanillaDataCon dc = dcVanilla dc++-- | Is this the 'DataCon' of a newtype?+isNewDataCon :: DataCon -> Bool+isNewDataCon dc = isNewTyCon (dataConTyCon dc)++-- | Is this data constructor in a "type data" declaration?+-- See Note [Type data declarations] in GHC.Rename.Module.+isTypeDataCon :: DataCon -> Bool+isTypeDataCon dc = isTypeDataTyCon (dataConTyCon dc)++isCovertGadtDataCon :: DataCon -> Bool+-- See Note [isCovertGadtDataCon]+isCovertGadtDataCon (MkData { dcUnivTyVars  = univ_tvs+                            , dcEqSpec     = eq_spec+                            , dcRepTyCon   = rep_tc })+  =  not (null eq_spec)                -- There are some constraints+  && not (any is_visible_spec eq_spec) -- But none of them are visible+  where+    visible_univ_tvs :: [TyVar]  -- Visible arguments in result type+    visible_univ_tvs+      = [ univ_tv | (univ_tv, tcb) <- univ_tvs `zip` tyConBinders rep_tc+                  , isVisibleTyConBinder tcb ]++    is_visible_spec :: EqSpec -> Bool+    is_visible_spec (EqSpec univ_tv ty)+       = univ_tv `elem` visible_univ_tvs+         && not (isTyVarTy ty)  -- See Note [isCovertGadtDataCon] for+                                -- an example where 'ty' is a tyvar++isUnaryClassDataCon :: DataCon -> Bool+isUnaryClassDataCon dc = isUnaryClassTyCon (dataConTyCon dc)++{- Note [isCovertGadtDataCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(isCovertGadtDataCon K) returns True if K is a GADT data constructor, but+does not /look/ like it. It is used only to help in error message printing.++Consider (#21447)+    type T :: TYPE r -> Type+    data T a where { MkT :: b -> T b }+Here MkT doesn't look GADT-like, but it is. If we make the kind applications+explicit we'd see:+    data T a where { MkT :: b -> T @LiftedRep b }++The test for covert-ness is bit tricky, because we want to see if+  - dcEqSpec is non-empty+  - dcEqSpec does not constrain any of the /required/ (i.e. visible)+    arguments of the TyCon to a non-tyvar++In the example above, the DataCon for MkT will have+    dcUnivTyVars: [(r::RuntimeRep), (a :: TYPE r)]+    dcExTyVars:   [(b :: Type)]+    dcEqSpec:     [(r, LiftedRep), (a, b)]+Here+  * `r :: RuntimeRep` is constrained by dcEqSpec to LiftedRep+  * `a :: TYPE r` is constrained by dcEqSpec to `b :: Type`+But the constraint on `a` is not visible to the user, so this counts+as a covert GADT data con.  The declaration+     MkT :: forall (b :: Type). b -> T b+looks entirely non-GADT-ish.++Wrinkles:+* The visibility or otherwise is a property of the /TyCon/ binders+* The dcUnivTyVars may or may not be the same as the TyCon binders+* So we have to zip them together.+* For a data family the TyCon in question is the /representation/ TyCon+  hence dcRepTyCon+-}+++-- | Should this DataCon be allowed in a type even without -XDataKinds?+-- Currently, only Lifted & Unlifted+specialPromotedDc :: DataCon -> Bool+specialPromotedDc = isKindTyCon . dataConTyCon++classDataCon :: Class -> DataCon+classDataCon clas = case tyConDataCons (classTyCon clas) of+                      (dict_constr:no_more) -> assert (null no_more) dict_constr+                      [] -> panic "classDataCon"++dataConCannotMatch :: [Type] -> DataCon -> Bool+-- Returns True iff the data con *definitely cannot* match a+--                  scrutinee of type (T tys)+--                  where T is the dcRepTyCon for the data con+dataConCannotMatch tys con+  -- See (U6) in Note [Implementing unsafeCoerce]+  -- in base:Unsafe.Coerce+  | dataConName con == unsafeReflDataConName+                      = False+  | null inst_theta   = False   -- Common+  | all isTyVarTy tys = False   -- Also common+  | otherwise         = typesCantMatch (concatMap predEqs inst_theta)+  where+    (_, inst_theta, _) = dataConInstSig con tys++    -- TODO: could gather equalities from superclasses too+    predEqs pred = case classifyPredType pred of+                     EqPred NomEq ty1 ty2         -> [(ty1, ty2)]+                     ClassPred eq args+                       | eq `hasKey` eqTyConKey+                       , [_, ty1, ty2] <- args    -> [(ty1, ty2)]+                       | eq `hasKey` heqTyConKey+                       , [_, _, ty1, ty2] <- args -> [(ty1, ty2)]+                     _                            -> []++-- | Were the type variables of the data con written in a different order+-- than the regular order (universal tyvars followed by existential tyvars)?+--+-- This is not a cheap test, so we minimize its use in GHC as much as possible.+-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in+-- "MkId", and so 'dataConUserTyVarsNeedWrapper' is only called at most once+-- during a data constructor's lifetime.++dataConResRepTyArgs :: DataCon -> [Type]+-- Returns the arguments of a GADT version of the /representation/ TyCon+-- Thus   data instance T [(x,y)] z where+--           MkT :: forall p q. Int -> T [(Int,p)] (Maybe q)+-- The "GADT version of the representation type" is+--        data R:T x y z where+--           MkT :: forall p q. Int -> R:T Int p (Maybe q)+-- so dataConResRepTyArgs for MkT returns [Int, p, Maybe q]+-- This is almost the same as (subst eq_spec univ_tvs); but not quite,+--   because eq_spec omits constraint-kinded equalities+dataConResRepTyArgs dc@(MkData { dcRepTyCon = rep_tc, dcOrigResTy = orig_res_ty })+  | Just (fam_tc, fam_args) <- tyConFamInst_maybe rep_tc+  = -- fvs(fam_args) = tyConTyVars rep_tc+    -- These tyvars are the domain of subst+    -- Fvs(range(subst)) = tvars of the datacon+    case  tcMatchTy (mkTyConApp fam_tc fam_args) orig_res_ty of+       Just subst -> map (substTyVar subst) (tyConTyVars rep_tc)+       Nothing    -> pprPanic "datacOnResRepTyArgs" $+                     vcat [ ppr dc, ppr fam_tc <+> ppr fam_args+                          , ppr orig_res_ty ]+  | otherwise+  = tyConAppArgs orig_res_ty++checkDataConTyVars :: DataCon -> Bool+-- Check that the worker and wrapper have the same set of type variables+-- See Note [DataCon user type variable binders]+-- Also ensures that no user tyvar is in the eq_spec (the eq_spec should+-- only relate fresh universals from (R2) of the note)+checkDataConTyVars dc@(MkData { dcUnivTyVars = univ_tvs+                              , dcExTyCoVars = ex_tvs+                              , dcEqSpec = eq_spec })+     -- use of sets here: (R1) from the Note+  = mkUnVarSet depleted_worker_vars == mkUnVarSet wrapper_vars &&+    all (not . is_eq_spec_var) wrapper_vars+  where+    worker_vars = univ_tvs ++ ex_tvs+    eq_spec_tvs = mkUnVarSet (map eqSpecTyVar eq_spec)+    is_eq_spec_var = (`elemUnVarSet` eq_spec_tvs)  -- (R2) from the Note+    depleted_worker_vars = filterOut is_eq_spec_var worker_vars++    wrapper_vars = dataConUserTyVars dc++dataConUserTyVarBindersNeedWrapper :: DataCon -> Bool+-- Check whether the worker and wrapper have the same type variables+-- in the same order and with the same visibility. If not, we need a+-- wrapper to swizzle them.+-- See Note [DataCon user type variable binders], as well as+-- Note [Data con wrappers and GADT syntax] for an explanation of what+-- mkDataConRep is doing with this function.+dataConUserTyVarBindersNeedWrapper (MkData { dcUnivTyVars = univ_tvs+                                           , dcExTyCoVars = ex_tvs+                                           , dcUserTyVarBinders = user_tvbs+                                           , dcEqSpec = eq_spec })+  = assert (null eq_spec || answer)  -- all GADTs should say "yes" here+    answer+  where+    answer = need_reorder || need_flag_cast+    need_reorder   = (univ_tvs ++ ex_tvs) /= binderVars user_tvbs+    need_flag_cast = any (not . eqForAllVis coreTyLamForAllTyFlag)+                         (binderFlags user_tvbs)+      -- See Note [Flag cast in data con wrappers]++{- Note [Flag cast in data con wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the data declaration++  data G a where+    MkG :: forall a -> a -> G a++The user-facing type of MkG has a 'Required' forall. Workers, on the other hand,+always use 'Specified' foralls (coreTyLamForAllTyFlag). So we need a wrapper:++  wrapper type: forall a -> a -> G a+  worker type:  forall a.   a -> G a++Concretely, it looks like this:++   $WMkG = /\a. \(x:a). MkG a x |> co++where 'co' is a coercion constructed by GHC.Core.Coercion.mkForAllVisCos.+The cast is added by the call to mkCoreTyLams in GHC.Types.Id.Make.mkDataConRep.++In general, wrappers may use 'Inferred', 'Specified', or 'Required' foralls.+However, we do /not/ need a cast to convert 'Inferred' to 'Specified' because they are+'eqType'-equal. Only a 'Required' forall necessitates a cast in the wrapper.++See Note [ForAllTy and type equality], Note [Comparing visibility],+and Note [Required foralls in Core].+-}++{-+%************************************************************************+%*                                                                      *+        Promoting of data types to the kind level+*                                                                      *+************************************************************************++-}++promoteDataCon :: DataCon -> TyCon+promoteDataCon (MkData { dcPromoted = tc }) = tc++{-+************************************************************************+*                                                                      *+\subsection{Splitting products}+*                                                                      *+************************************************************************+-}++-- | Extract the type constructor, type argument, data constructor and it's+-- /representation/ argument types from a type if it is a product type.+--+-- Precisely, we return @Just@ for any data type that is all of:+--+--  * Concrete (i.e. constructors visible)+--  * Single-constructor+--  * ... which has no existentials+--+-- Whether the type is a @data@ type or a @newtype@.+splitDataProductType_maybe+        :: Type                         -- ^ A product type, perhaps+        -> Maybe (TyCon,                -- The type constructor+                  [Type],               -- Type args of the tycon+                  DataCon,              -- The data constructor+                  [Scaled Type])        -- Its /representation/ arg types++        -- Rejecting existentials means we don't have to worry about+        -- freshening and substituting type variables+        -- (See "GHC.Type.Id.Make.dataConArgUnpack")++splitDataProductType_maybe ty+  | Just (tycon, ty_args) <- splitTyConApp_maybe ty+  , Just con <- tyConSingleDataCon_maybe tycon+  , null (dataConExTyCoVars con) -- no existentials! See above+  = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)+  | otherwise+  = Nothing
+ GHC/Core/DataCon.hs-boot view
@@ -0,0 +1,39 @@+module GHC.Core.DataCon where++import GHC.Prelude+import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, TyVarBinder )+import {-# SOURCE #-} GHC.Types.Name( Name, NamedThing )+import {-# SOURCE #-} GHC.Core.TyCon( TyCon )+import GHC.Types.FieldLabel ( FieldLabel )+import GHC.Types.Unique ( Uniquable )+import GHC.Utils.Outputable ( Outputable, OutputableBndr )+import GHC.Types.Basic (Arity)+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, ThetaType, Scaled )++data DataCon+data DataConRep+data EqSpec++dataConName      :: DataCon -> Name+dataConWorkId    :: DataCon -> Id+dataConTyCon     :: DataCon -> TyCon+dataConExTyCoVars :: DataCon -> [TyCoVar]+dataConUserTyVars :: DataCon -> [TyVar]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder]+dataConSourceArity  :: DataCon -> Arity+dataConFieldLabels :: DataCon -> [FieldLabel]+dataConInstOrigArgTys  :: DataCon -> [Type] -> [Scaled Type]+dataConStupidTheta :: DataCon -> ThetaType+dataConFullSig :: DataCon+               -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)+isUnboxedSumDataCon :: DataCon -> Bool+isTypeDataCon :: DataCon -> Bool++instance Eq DataCon+instance Uniquable DataCon+instance NamedThing DataCon+instance Outputable DataCon+instance OutputableBndr DataCon++dataConWrapId :: DataCon -> Id+promoteDataCon :: DataCon -> TyCon
+ GHC/Core/FVs.hs view
@@ -0,0 +1,763 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Taken quite directly from the Peyton Jones/Lester paper.+-}++{-# LANGUAGE TypeFamilies #-}++-- | A module concerned with finding the free variables of an expression.+module GHC.Core.FVs (+        -- * Free variables of expressions and binding groups+        exprFreeVars,     exprsFreeVars,+        exprFreeVarsDSet,+        exprFreeVarsList, exprsFreeVarsList,+        exprFreeIds,      exprsFreeIds,+        exprFreeIdsDSet,  exprsFreeIdsDSet,+        exprFreeIdsList,  exprsFreeIdsList,+        bindFreeVars,++        -- * Selective free variables of expressions+        InterestingVarFun,+        exprSomeFreeVars, exprsSomeFreeVars,+        exprSomeFreeVarsList, exprsSomeFreeVarsList,++        -- * Free variables of Rules, Vars and Ids+        varTypeTyCoVars,+        varTypeTyCoFVs,+        idUnfoldingVars, idFreeVars, dIdFreeVars,+        bndrRuleAndUnfoldingVarsDSet,+        bndrRuleAndUnfoldingIds,+        idFVs,+        idRuleVars, stableUnfoldingVars,+        ruleFreeVars, rulesFreeVars,+        rulesFreeVarsDSet, mkRuleInfo,+        ruleLhsFreeIds, ruleLhsFreeIdsList,+        ruleRhsFreeVars, rulesRhsFreeIds,++        exprFVs, exprLocalFVs, addBndrFV, addBndrsFV,++        -- * Orphan names+        orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS,+        orphNamesOfExprs,++        -- * Core syntax tree annotation with free variables+        FVAnn,                  -- annotation, abstract+        CoreExprWithFVs,        -- = AnnExpr Id FVAnn+        CoreExprWithFVs',       -- = AnnExpr' Id FVAnn+        CoreBindWithFVs,        -- = AnnBind Id FVAnn+        CoreAltWithFVs,         -- = AnnAlt Id FVAnn+        freeVars,               -- CoreExpr -> CoreExprWithFVs+        freeVarsBind,           -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs)+        freeVarsOf,             -- CoreExprWithFVs -> DIdSet+        freeVarsOfAnn+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name.Set+import GHC.Types.Name+import GHC.Types.Tickish+import GHC.Types.Var.Set+import GHC.Types.Var+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Builtin.Types( unrestrictedFunTyConName )+import GHC.Builtin.Types.Prim( fUNTyCon )+import GHC.Data.Maybe( orElse )++import GHC.Utils.FV as FV+import GHC.Utils.Misc+import GHC.Utils.Panic.Plain++{-+************************************************************************+*                                                                      *+\section{Finding the free variables of an expression}+*                                                                      *+************************************************************************++This function simply finds the free variables of an expression.+So far as type variables are concerned, it only finds tyvars that are++        * free in type arguments,+        * free in the type of a binder,++but not those that are free in the type of variable occurrence.+-}++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a non-deterministic set.+exprFreeVars :: CoreExpr -> VarSet+exprFreeVars = fvVarSet . exprLocalFVs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV"+-- for why export it.+exprLocalFVs :: CoreExpr -> FV+exprLocalFVs = filterFV isLocalVar . exprFVs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a deterministic set.+exprFreeVarsDSet :: CoreExpr -> DVarSet+exprFreeVarsDSet = fvDVarSet . exprLocalFVs++-- | Find all locally-defined free Ids or type variables in an expression+-- returning a deterministically ordered list.+exprFreeVarsList :: CoreExpr -> [Var]+exprFreeVarsList = fvVarList . exprLocalFVs++-- | Find all locally-defined free Ids in an expression+exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids+exprFreeIds = exprSomeFreeVars isLocalId++exprsFreeIds :: [CoreExpr] -> IdSet        -- Find all locally-defined free Ids+exprsFreeIds = exprsSomeFreeVars isLocalId++-- | Find all locally-defined free Ids in an expression+-- returning a deterministic set.+exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids+exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId++-- | Find all locally-defined free Ids in an expression+-- returning a deterministically ordered list.+exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids+exprFreeIdsList = exprSomeFreeVarsList isLocalId++-- | Find all locally-defined free Ids in several expressions+-- returning a deterministic set.+exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids+exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId++-- | Find all locally-defined free Ids in several expressions+-- returning a deterministically ordered list.+exprsFreeIdsList :: [CoreExpr] -> [Id]   -- Find all locally-defined free Ids+exprsFreeIdsList = exprsSomeFreeVarsList isLocalId++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a non-deterministic set.+exprsFreeVars :: [CoreExpr] -> VarSet+exprsFreeVars = fvVarSet . exprsLocalFVs++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a composable FV computation. See Note [FV naming conventions] in "GHC.Utils.FV"+-- for why export it.+exprsLocalFVs :: [CoreExpr] -> FV+exprsLocalFVs exprs = mapUnionFV exprLocalFVs exprs++-- | Find all locally-defined free Ids or type variables in several expressions+-- returning a deterministically ordered list.+exprsFreeVarsList :: [CoreExpr] -> [Var]+exprsFreeVarsList = fvVarList . exprsLocalFVs++-- | Find all locally defined free Ids in a binding group+bindFreeVars :: CoreBind -> VarSet+bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r)+bindFreeVars (Rec prs)    = fvVarSet $ filterFV isLocalVar $+                                addBndrsFV (map fst prs)+                                     (mapUnionFV rhs_fvs prs)++-- | Finds free variables in an expression selected by a predicate+exprSomeFreeVars :: InterestingVarFun   -- ^ Says which 'Var's are interesting+                 -> CoreExpr+                 -> VarSet+exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ exprFVs e++-- | Finds free variables in an expression selected by a predicate+-- returning a deterministically ordered list.+exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting+                     -> CoreExpr+                     -> [Var]+exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ exprFVs e++-- | Finds free variables in an expression selected by a predicate+-- returning a deterministic set.+exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting+                     -> CoreExpr+                     -> DVarSet+exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ exprFVs e++-- | Finds free variables in several expressions selected by a predicate+exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting+                  -> [CoreExpr]+                  -> VarSet+exprsSomeFreeVars fv_cand es = fvVarSet $ filterFV fv_cand $ mapUnionFV exprFVs es++-- | Finds free variables in several expressions selected by a predicate+-- returning a deterministically ordered list.+exprsSomeFreeVarsList :: InterestingVarFun  -- Says which 'Var's are interesting+                      -> [CoreExpr]+                      -> [Var]+exprsSomeFreeVarsList fv_cand es = fvVarList $ filterFV fv_cand $ mapUnionFV exprFVs es++-- | Finds free variables in several expressions selected by a predicate+-- returning a deterministic set.+exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting+                      -> [CoreExpr]+                      -> DVarSet+exprsSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ mapUnionFV exprFVs e++--      Comment about obsolete code+-- We used to gather the free variables the RULES at a variable occurrence+-- with the following cryptic comment:+--     "At a variable occurrence, add in any free variables of its rule rhss+--     Curiously, we gather the Id's free *type* variables from its binding+--     site, but its free *rule-rhs* variables from its usage sites.  This+--     is a little weird.  The reason is that the former is more efficient,+--     but the latter is more fine grained, and a makes a difference when+--     a variable mentions itself one of its own rule RHSs"+-- Not only is this "weird", but it's also pretty bad because it can make+-- a function seem more recursive than it is.  Suppose+--      f  = ...g...+--      g  = ...+--         RULE g x = ...f...+-- Then f is not mentioned in its own RHS, and needn't be a loop breaker+-- (though g may be).  But if we collect the rule fvs from g's occurrence,+-- it looks as if f mentions itself.  (This bites in the eftInt/eftIntFB+-- code in GHC.Enum.)+--+-- Anyway, it seems plain wrong.  The RULE is like an extra RHS for the+-- function, so its free variables belong at the definition site.+--+-- Deleted code looked like+--     foldVarSet add_rule_var var_itself_set (idRuleVars var)+--     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var+--                          | otherwise                    = set+--      SLPJ Feb06++addBndrFV :: CoreBndr -> FV -> FV+addBndrFV bndr fv fv_cand in_scope acc+  = (varTypeTyCoFVs bndr `unionFV`+        -- Include type variables in the binder's type+        --      (not just Ids; coercion variables too!)+     FV.delFV bndr fv) fv_cand in_scope acc++addBndrsFV :: [CoreBndr] -> FV -> FV+addBndrsFV bndrs fv = foldr addBndrFV fv bndrs++exprsFVs :: [CoreExpr] -> FV+exprsFVs exprs = mapUnionFV exprFVs exprs++exprFVs :: CoreExpr -> FV+exprFVs (Type ty) fv_cand in_scope acc =+  tyCoFVsOfType ty fv_cand in_scope acc+exprFVs (Coercion co) fv_cand in_scope acc =+  tyCoFVsOfCo co fv_cand in_scope acc+exprFVs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc+exprFVs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc+exprFVs (Tick t expr) fv_cand in_scope acc =+  (tickish_fvs t `unionFV` exprFVs expr) fv_cand in_scope acc+exprFVs (App fun arg) fv_cand in_scope acc =+  (exprFVs fun `unionFV` exprFVs arg) fv_cand in_scope acc+exprFVs (Lam bndr body) fv_cand in_scope acc =+  addBndrFV bndr (exprFVs body) fv_cand in_scope acc+exprFVs (Cast expr co) fv_cand in_scope acc =+  (exprFVs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc++exprFVs (Case scrut bndr ty alts) fv_cand in_scope acc+  = (exprFVs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndrFV bndr+      (mapUnionFV alt_fvs alts)) fv_cand in_scope acc+  where+    alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs)++exprFVs (Let (NonRec bndr rhs) body) fv_cand in_scope acc+  = (rhs_fvs (bndr, rhs) `unionFV` addBndrFV bndr (exprFVs body))+      fv_cand in_scope acc++exprFVs (Let (Rec pairs) body) fv_cand in_scope acc+  = addBndrsFV (map fst pairs)+               (mapUnionFV rhs_fvs pairs `unionFV` exprFVs body)+               fv_cand in_scope acc++---------+rhs_fvs :: (Id, CoreExpr) -> FV+rhs_fvs (bndr, rhs) = exprFVs rhs `unionFV`+                      bndrRuleAndUnfoldingFVs bndr+        -- Treat any RULES as extra RHSs of the binding++---------+tickish_fvs :: CoreTickish -> FV+tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids+tickish_fvs _ = emptyFV++{- **********************************************************************+%*                                                                      *+                    Orphan names+%*                                                                      *+%********************************************************************* -}++{- Note [Finding orphan names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions here (orphNamesOfType, orphNamesOfExpr etc) traverse a template:+  * the head of an class instance decl+  * the LHS of a type-family instance+  * the arguments of a RULE+to find TyCons or (in the case of a RULE) Ids, that will be matched against when+matching the template. If none of these orphNames are locally defined, the instance+or RULE is an orphan: see Note [Orphans] in GHC.Core++Wrinkles:+ (ON1) We do not need to look inside coercions, because we never match against+       them.  Indeed, it'd be wrong to do so, because it could make an instance+       into a non-orphan, when it really is an orphan.++ (ON2) These orphNames functions are also (rather separately) used by GHCi, to+       implement :info.  When you say ":info Foo", we show all the instances that+       involve `Foo`; that is, all the instances whose oprhNames include `Foo`.++       To support `:info (->)` we need to ensure that (->) is treated as an orphName+       of FunTy, which is a bit messy since the "real" TyCon is `FUN`+-}++orphNamesOfTyCon :: TyCon -> NameSet+orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of+    Nothing  -> emptyNameSet+    Just cls -> unitNameSet (getName cls)++orphNamesOfType :: Type -> NameSet+orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'+                -- Look through type synonyms (#4912)+orphNamesOfType (TyVarTy _)          = emptyNameSet+orphNamesOfType (LitTy {})           = emptyNameSet+orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)+                                       `unionNameSet` orphNamesOfType res+orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg++orphNamesOfType (TyConApp tycon tys) = func+                                       `unionNameSet` orphNamesOfTyCon tycon+                                       `unionNameSet` orphNamesOfTypes tys+        where func = case tys of+                       arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg+                       _ -> emptyNameSet++orphNamesOfType (FunTy af w arg res) =  func+                                       `unionNameSet` unitNameSet fun_tc+                                       `unionNameSet` orphNamesOfType w+                                       `unionNameSet` orphNamesOfType arg+                                       `unionNameSet` orphNamesOfType res+        where func | isVisibleFunArg af = orph_names_of_fun_ty_con w+                   | otherwise          = emptyNameSet++              fun_tc = tyConName (funTyFlagTyCon af)++-- Coercions: see wrinkle (ON1) of Note [Finding orphan names]+orphNamesOfType (CastTy ty _co)  = orphNamesOfType ty+orphNamesOfType (CoercionTy _co) = emptyNameSet++orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet+orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet++orphNamesOfTypes :: [Type] -> NameSet+orphNamesOfTypes = orphNamesOfThings orphNamesOfType++-- | `orphNamesOfAxiomLHS` collects the names of the concrete types and+-- type constructors that make up the LHS of a type family instance,+-- including the family name itself.+--+-- For instance, given `type family Foo a b`:+-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]+--+-- Used (via orphNamesOfFamInst) in the implementation of ":info" in GHCi.+-- and when determining orphan-hood for a FamInst or module+orphNamesOfAxiomLHS :: CoAxiom br -> NameSet+orphNamesOfAxiomLHS axiom+  = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)+    `extendNameSet` getName (coAxiomTyCon axiom)++-- Detect (FUN 'Many) as an application of (->), so that :i (->) works as expected+-- (see #8535) Issue #16475 describes a more robust solution+-- See wrinkle (ON2) of Note [Finding orphan names]+orph_names_of_fun_ty_con :: Mult -> NameSet+orph_names_of_fun_ty_con ManyTy = unitNameSet unrestrictedFunTyConName+orph_names_of_fun_ty_con _      = emptyNameSet++-- | Finds the free /external/ names of an expression, notably+-- including the names of type constructors (which of course do not show+-- up in 'exprFreeVars').+orphNamesOfExpr :: CoreExpr -> NameSet+-- There's no need to delete local binders, because they will all+-- be /internal/ names.+orphNamesOfExpr e+  = go e+  where+    go (Var v)+      | isExternalName n    = unitNameSet n+      | otherwise           = emptyNameSet+      where n = idName v+    go (Lit _)              = emptyNameSet+    go (Type ty)            = orphNamesOfType ty        -- Don't need free tyvars+    go (Coercion _co)       = emptyNameSet -- See wrinkle (ON1) of Note [Finding orphan names]+    go (App e1 e2)          = go e1 `unionNameSet` go e2+    go (Lam v e)            = go e `delFromNameSet` idName v+    go (Tick _ e)           = go e+    go (Cast e _co)         = go e  -- See wrinkle (ON1) of Note [Finding orphan names]+    go (Let (NonRec _ r) e) = go e `unionNameSet` go r+    go (Let (Rec prs) e)    = orphNamesOfExprs (map snd prs) `unionNameSet` go e+    go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty+                              `unionNameSet` unionNameSets (map go_alt as)++    go_alt (Alt _ _ r)      = go r++-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details+orphNamesOfExprs :: [CoreExpr] -> NameSet+orphNamesOfExprs es = foldr (unionNameSet . orphNamesOfExpr) emptyNameSet es+++{-+************************************************************************+*                                                                      *+\section[freevars-everywhere]{Attaching free variables to every sub-expression}+*                                                                      *+************************************************************************+-}++data RuleFVsFrom+  = LhsOnly+  | RhsOnly+  | BothSides++-- | Those locally-defined variables free in the left and/or right hand sides+-- of the rule, depending on the first argument. Returns an 'FV' computation.+ruleFVs :: RuleFVsFrom -> CoreRule -> FV+ruleFVs !_   (BuiltinRule {}) = emptyFV+ruleFVs from (Rule { ru_fn = _do_not_include+                     -- See Note [Rule free var hack]+                   , ru_bndrs = bndrs+                   , ru_rhs = rhs, ru_args = args })+  = filterFV isLocalVar $ addBndrsFV bndrs (exprsFVs exprs)+  where+    exprs = case from of+      LhsOnly   -> args+      RhsOnly   -> [rhs]+      BothSides -> rhs:args++-- | Those locally-defined variables free in the left and/or right hand sides+-- from several rules, depending on the first argument.+-- Returns an 'FV' computation.+rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV+rulesFVs from = mapUnionFV (ruleFVs from)++-- | Those variables free in the right hand side of a rule returned as a+-- non-deterministic set+ruleRhsFreeVars :: CoreRule -> VarSet+ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly++-- | Those locally-defined free 'Id's in the right hand side of several rules+-- returned as a non-deterministic set+rulesRhsFreeIds :: [CoreRule] -> VarSet+rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly++ruleLhsFreeIds :: CoreRule -> VarSet+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a non-deterministic set+ruleLhsFreeIds = fvVarSet . filterFV isLocalId . ruleFVs LhsOnly++ruleLhsFreeIdsList :: CoreRule -> [Var]+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a deterministically ordered list+ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly++-- | Those variables free in the both the left right hand sides of a rule+-- returned as a non-deterministic set+ruleFreeVars :: CoreRule -> VarSet+ruleFreeVars = fvVarSet . ruleFVs BothSides++-- | Those variables free in the both the left right hand sides of rules+-- returned as a deterministic set+rulesFreeVarsDSet :: [CoreRule] -> DVarSet+rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules++-- | Those variables free in both the left right hand sides of several rules+rulesFreeVars :: [CoreRule] -> VarSet+rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules++-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable+-- for putting into an 'IdInfo'+mkRuleInfo :: [CoreRule] -> RuleInfo+mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)++{-+Note [Rule free var hack]  (Not a hack any more)+~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to include the Id in its own rhs free-var set.+Otherwise the occurrence analyser makes bindings recursive:+        f x y = x+y+        RULE:  f (f x y) z  ==>  f x (f y z)+However, the occurrence analyser distinguishes "non-rule loop breakers"+from "rule-only loop breakers" (see BasicTypes.OccInfo).  So it will+put this 'f' in a Rec block, but will mark the binding as a non-rule loop+breaker, which is perfectly inlinable.+-}++{-+************************************************************************+*                                                                      *+\section[freevars-everywhere]{Attaching free variables to every sub-expression}+*                                                                      *+************************************************************************++The free variable pass annotates every node in the expression with its+NON-GLOBAL free variables and type variables.+-}++type FVAnn = DVarSet  -- See Note [The FVAnn invariant]++{- Note [The FVAnn invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant: a FVAnn, say S, is closed:+  That is: if v is in S,+           then freevars( v's type/kind ) is also in S+-}++-- | Every node in a binding group annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+type CoreBindWithFVs = AnnBind Id FVAnn++-- | Every node in an expression annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+-- NB: see Note [The FVAnn invariant]+type CoreExprWithFVs  = AnnExpr  Id FVAnn+type CoreExprWithFVs' = AnnExpr' Id FVAnn++-- | Every node in an expression annotated with its+-- (non-global) free variables, both Ids and TyVars, and type.+type CoreAltWithFVs = AnnAlt Id FVAnn++freeVarsOf :: CoreExprWithFVs -> DIdSet+-- ^ Inverse function to 'freeVars'+freeVarsOf (fvs, _) = fvs++-- | Extract the vars reported in a FVAnn+freeVarsOfAnn :: FVAnn -> DIdSet+freeVarsOfAnn fvs = fvs++aFreeVar :: Var -> DVarSet+aFreeVar = unitDVarSet++unionFVs :: DVarSet -> DVarSet -> DVarSet+unionFVs = unionDVarSet++unionFVss :: [DVarSet] -> DVarSet+unionFVss = unionDVarSets++delBindersFV :: [Var] -> DVarSet -> DVarSet+delBindersFV bs fvs = foldr delBinderFV fvs bs++delBinderFV :: Var -> DVarSet -> DVarSet+-- This way round, so we can do it multiple times using foldr++-- (b `delBinderFV` s)+--   * removes the binder b from the free variable set s,+--   * AND *adds* to s the free variables of b's type+--+-- This is really important for some lambdas:+--      In (\x::a -> x) the only mention of "a" is in the binder.+--+-- Also in+--      let x::a = b in ...+-- we should really note that "a" is free in this expression.+-- It'll be pinned inside the /\a by the binding for b, but+-- it seems cleaner to make sure that a is in the free-var set+-- when it is mentioned.+--+-- This also shows up in recursive bindings.  Consider:+--      /\a -> letrec x::a = x in E+-- Now, there are no explicit free type variables in the RHS of x,+-- but nevertheless "a" is free in its definition.  So we add in+-- the free tyvars of the types of the binders, and include these in the+-- free vars of the group, attached to the top level of each RHS.+--+-- This actually happened in the defn of errorIO in IOBase.hs:+--      errorIO (ST io) = case (errorIO# io) of+--                          _ -> bottom+--                        where+--                          bottom = bottom -- Never evaluated++delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b+        -- Include coercion variables too!++varTypeTyCoVars :: Var -> TyCoVarSet+-- Find the type/kind variables free in the type of the id/tyvar+varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var++dVarTypeTyCoVars :: Var -> DTyCoVarSet+-- Find the type/kind/coercion variables free in the type of the id/tyvar+dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var++varTypeTyCoFVs :: Var -> FV+-- Find the free variables of a binder.+-- In the case of ids, don't forget the multiplicity field!+varTypeTyCoFVs var+  = tyCoFVsOfType (varType var) `unionFV` mult_fvs+  where+    mult_fvs = case varMultMaybe var of+                 Just mult -> tyCoFVsOfType mult+                 Nothing   -> emptyFV++idFreeVars :: Id -> VarSet+idFreeVars id = assert (isId id) $ fvVarSet $ idFVs id++dIdFreeVars :: Id -> DVarSet+dIdFreeVars id = fvDVarSet $ idFVs id++idFVs :: Id -> FV+-- Type variables, rule variables, and inline variables+idFVs id = assert (isId id) $+           varTypeTyCoFVs id `unionFV`+           bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet+bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingIds :: Id -> IdSet+bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id++bndrRuleAndUnfoldingFVs :: Id -> FV+bndrRuleAndUnfoldingFVs id+  | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id+  | otherwise = emptyFV++idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars+idRuleVars id = fvVarSet $ idRuleFVs id++idRuleFVs :: Id -> FV+idRuleFVs id = assert (isId id) $+  FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))++idUnfoldingVars :: Id -> VarSet+-- Produce free vars for an unfolding, but NOT for an ordinary+-- (non-inline) unfolding, since it is a dup of the rhs+-- and we'll get exponential behaviour if we look at both unf and rhs!+-- But do look at the *real* unfolding, even for loop breakers, else+-- we might get out-of-scope variables+idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id++idUnfoldingFVs :: Id -> FV+idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV++stableUnfoldingVars :: Unfolding -> Maybe VarSet+stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf++stableUnfoldingFVs :: Unfolding -> Maybe FV+stableUnfoldingFVs unf+  = case unf of+      CoreUnfolding { uf_tmpl = rhs, uf_src = src }+         | isStableSource src+         -> Just (exprLocalFVs rhs)+      DFunUnfolding { df_bndrs = bndrs, df_args = args }+         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args)+            -- DFuns are top level, so no fvs from types of bndrs+      _other -> Nothing+++{-+************************************************************************+*                                                                      *+\subsection{Free variables (and types)}+*                                                                      *+************************************************************************+-}++freeVarsBind :: CoreBind+             -> DVarSet                     -- Free vars of scope of binding+             -> (CoreBindWithFVs, DVarSet)  -- Return free vars of binding + scope+freeVarsBind (NonRec binder rhs) body_fvs+  = ( AnnNonRec binder rhs2+    , freeVarsOf rhs2 `unionFVs` body_fvs2+                      `unionFVs` bndrRuleAndUnfoldingVarsDSet binder )+    where+      rhs2      = freeVars rhs+      body_fvs2 = binder `delBinderFV` body_fvs++freeVarsBind (Rec binds) body_fvs+  = ( AnnRec (binders `zip` rhss2)+    , delBindersFV binders all_fvs )+  where+    (binders, rhss) = unzip binds+    rhss2        = map freeVars rhss+    rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2+    binders_fvs  = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders+                   -- See Note [The FVAnn invariant]+    all_fvs      = rhs_body_fvs `unionFVs` binders_fvs+            -- The "delBinderFV" happens after adding the idSpecVars,+            -- since the latter may add some of the binders as fvs++freeVars :: CoreExpr -> CoreExprWithFVs+-- ^ Annotate a 'CoreExpr' with its (non-global) free type+--   and value variables at every tree node.+freeVars = go+  where+    go :: CoreExpr -> CoreExprWithFVs+    go (Var v)+      | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v)+      | otherwise    = (emptyDVarSet,                 AnnVar v)+      where+        mult_vars = tyCoVarsOfTypeDSet (idMult v)+        ty_fvs = dVarTypeTyCoVars v+                 -- See Note [The FVAnn invariant]++    go (Lit lit) = (emptyDVarSet, AnnLit lit)+    go (Lam b body)+      = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs)+        , AnnLam b body' )+      where+        body'@(body_fvs, _) = go body+        b_ty  = idType b+        b_fvs = tyCoVarsOfTypeDSet b_ty+                -- See Note [The FVAnn invariant]++    go (App fun arg)+      = ( freeVarsOf fun' `unionFVs` freeVarsOf arg'+        , AnnApp fun' arg' )+      where+        fun'   = go fun+        arg'   = go arg++    go (Case scrut bndr ty alts)+      = ( (bndr `delBinderFV` alts_fvs)+           `unionFVs` freeVarsOf scrut2+           `unionFVs` tyCoVarsOfTypeDSet ty+          -- Don't need to look at (idType bndr)+          -- because that's redundant with scrut+        , AnnCase scrut2 bndr ty alts2 )+      where+        scrut2 = go scrut++        (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts+        alts_fvs            = unionFVss alts_fvs_s++        fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2),+                                     (AnnAlt con args rhs2))+                              where+                                 rhs2 = go rhs++    go (Let bind body)+      = (bind_fvs, AnnLet bind2 body2)+      where+        (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)+        body2             = go body++    go (Cast expr co)+      = ( freeVarsOf expr2 `unionFVs` cfvs+        , AnnCast expr2 (cfvs, co) )+      where+        expr2 = go expr+        cfvs  = tyCoVarsOfCoDSet co++    go (Tick tickish expr)+      = ( tickishFVs tickish `unionFVs` freeVarsOf expr2+        , AnnTick tickish expr2 )+      where+        expr2 = go expr+        tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids+        tickishFVs _                    = emptyDVarSet++    go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)+    go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)
+ GHC/Core/FamInstEnv.hs view
@@ -0,0 +1,1607 @@+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}++-- (c) The University of Glasgow 2006+--+-- FamInstEnv: Type checked family instance declarations++module GHC.Core.FamInstEnv (+        FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,+        famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,+        pprFamInst, pprFamInsts, orphNamesOfFamInst,+        mkImportedFamInst, mkLocalFamInst,++        FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,+        unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList,+        famInstEnvElts, famInstEnvSize, familyInstances, familyNameInstances,++        -- * CoAxioms+        mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom,+        mkNewTypeCoAxiom,++        FamInstMatch(..),+        lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon,++        isDominatedBy, apartnessCheck, compatibleBranches,++        -- Injectivity+        InjectivityCheckResult(..),+        lookupFamInstEnvInjectivityConflicts, injectiveBranches,++        -- Normalisation+        topNormaliseType, topNormaliseType_maybe,+        normaliseType, normaliseTcApp,+        topReduceTyFamApp_maybe, reduceTyFamApp_maybe+    ) where++import GHC.Prelude++import GHC.Core( IsOrphan, chooseOrphanAnchor )+import GHC.Core.Unify+import GHC.Core.Type as Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.Compare( eqType, eqTypes )+import GHC.Core.TyCon+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom+import GHC.Core.Reduction+import GHC.Core.RoughMap+import GHC.Core.FVs( orphNamesOfAxiomLHS )++import GHC.Builtin.Types.Literals( tryMatchFam )++import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name+import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Name.Set++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.Bag+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import Control.Monad+import Data.List( mapAccumL )+import Data.Array( Array, assocs )++{-+************************************************************************+*                                                                      *+          Type checked family instance heads+*                                                                      *+************************************************************************++Note [FamInsts and CoAxioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* CoAxioms and FamInsts are just like+  DFunIds  and ClsInsts++* A CoAxiom is a System-FC thing: it can relate any two types++* A FamInst is a Haskell source-language thing, corresponding+  to a type/data family instance declaration.+    - The FamInst contains a CoAxiom, which is the evidence+      for the instance++    - The LHS of the CoAxiom is always of form F ty1 .. tyn+      where F is a type family+-}++data FamInst  -- See Note [FamInsts and CoAxioms]+  = FamInst { fi_axiom  :: CoAxiom Unbranched -- The new coercion axiom+                                              -- introduced by this family+                                              -- instance+                 -- INVARIANT: apart from freshening (see below)+                 --    fi_tvs = cab_tvs of the (single) axiom branch+                 --    fi_cvs = cab_cvs ...ditto...+                 --    fi_tys = cab_lhs ...ditto...+                 --    fi_rhs = cab_rhs ...ditto...++            , fi_flavor :: FamFlavor++            -- Everything below here is a redundant,+            -- cached version of the two things above+            -- except that the TyVars are freshened+            , fi_fam   :: Name          -- Family name++                -- Used for "rough matching"; same idea as for class instances+                -- See Note [Rough matching in class and family instances]+                -- in GHC.Core.Unify+            , fi_tcs   :: [RoughMatchTc]  -- Top of type args+                -- INVARIANT: fi_tcs = roughMatchTcs fi_tys++            -- Used for "proper matching"; ditto+            , fi_tvs :: [TyVar]      -- Template tyvars for full match+            , fi_cvs :: [CoVar]      -- Template covars for full match+                 -- Like ClsInsts, these variables are always fresh+                 -- See Note [Template tyvars are fresh] in GHC.Core.InstEnv++            , fi_tys    :: [Type]       --   The LHS type patterns+            -- May be eta-reduced; see Note [Eta reduction for data families]+            -- in GHC.Core.Coercion.Axiom++            , fi_rhs :: Type         --   the RHS, with its freshened vars++            , fi_orphan :: IsOrphan+            }++data FamFlavor+  = SynFamilyInst         -- A synonym family+  | DataFamilyInst TyCon  -- A data family, with its representation TyCon++{-+Note [Arity of data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Data family instances might legitimately be over- or under-saturated.++Under-saturation has two potential causes:+ U1) Eta reduction. See Note [Eta reduction for data families] in+     GHC.Core.Coercion.Axiom.+ U2) When the user has specified a return kind instead of written out patterns.+     Example:++       data family Sing (a :: k)+       data instance Sing :: Bool -> Type++     The data family tycon Sing has an arity of 2, the k and the a. But+     the data instance has only one pattern, Bool (standing in for k).+     This instance is equivalent to `data instance Sing (a :: Bool)`, but+     without the last pattern, we have an under-saturated data family instance.+     On its own, this example is not compelling enough to add support for+     under-saturation, but U1 makes this feature more compelling.++Over-saturation is also possible:+  O1) If the data family's return kind is a type variable (see also #12369),+      an instance might legitimately have more arguments than the family.+      Example:++        data family Fix :: (Type -> k) -> k+        data instance Fix f = MkFix1 (f (Fix f))+        data instance Fix f x = MkFix2 (f (Fix f x) x)++      In the first instance here, the k in the data family kind is chosen to+      be Type. In the second, it's (Type -> Type).++      However, we require that any over-saturation is eta-reducible. That is,+      we require that any extra patterns be bare unrepeated type variables;+      see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.+      Accordingly, the FamInst is never over-saturated.++Why can we allow such flexibility for data families but not for type families?+Because data families can be decomposed -- that is, they are generative and+injective. A Type family is neither and so always must be applied to all its+arguments.+-}++-- Obtain the axiom of a family instance+famInstAxiom :: FamInst -> CoAxiom Unbranched+famInstAxiom = fi_axiom++-- Split the left-hand side of the FamInst+famInstSplitLHS :: FamInst -> (TyCon, [Type])+famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs })+  = (coAxiomTyCon axiom, lhs)++-- Get the RHS of the FamInst+famInstRHS :: FamInst -> Type+famInstRHS = fi_rhs++-- Get the family TyCon of the FamInst+famInstTyCon :: FamInst -> TyCon+famInstTyCon = coAxiomTyCon . famInstAxiom++-- Return the representation TyCons introduced by data family instances, if any+famInstsRepTyCons :: [FamInst] -> [TyCon]+famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis]++-- Extracts the TyCon for this *data* (or newtype) instance+famInstRepTyCon_maybe :: FamInst -> Maybe TyCon+famInstRepTyCon_maybe fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> Just tycon+       SynFamilyInst        -> Nothing++dataFamInstRepTyCon :: FamInst -> TyCon+dataFamInstRepTyCon fi+  = case fi_flavor fi of+       DataFamilyInst tycon -> tycon+       SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)++orphNamesOfFamInst :: FamInst -> NameSet+orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax+++{-+************************************************************************+*                                                                      *+        Pretty printing+*                                                                      *+************************************************************************+-}++instance NamedThing FamInst where+   getName = coAxiomName . fi_axiom++instance Outputable FamInst where+   ppr = pprFamInst++pprFamInst :: FamInst -> SDoc+-- Prints the FamInst as a family instance declaration+-- NB: This function, FamInstEnv.pprFamInst, is used only for internal,+--     debug printing. See GHC.Types.TyThing.Ppr.pprFamInst for printing for the user+pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax+                    , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs })+  = hang (ppr_tc_sort <+> text "instance"+             <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax))+       2 (whenPprDebug debug_stuff)+  where+    ppr_tc_sort = case flavor of+                     SynFamilyInst             -> text "type"+                     DataFamilyInst tycon+                       | isBoxedDataTyCon tycon -> text "data"+                       | isNewTyCon       tycon -> text "newtype"+                       | isAbstractTyCon  tycon -> text "data"+                       | otherwise              -> text "WEIRD" <+> ppr tycon++    debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax+                       , text "Tvs:" <+> ppr tvs+                       , text "LHS:" <+> ppr tys+                       , text "RHS:" <+> ppr rhs ]++pprFamInsts :: [FamInst] -> SDoc+pprFamInsts finsts = vcat (map pprFamInst finsts)++{- *********************************************************************+*                                                                      *+                 Making FamInsts+*                                                                      *+********************************************************************* -}++mkLocalFamInst :: FamFlavor -> CoAxiom Unbranched+               -> [TyVar] -> [CoVar] -> [Type] -> Type+               -> FamInst+mkLocalFamInst flavor axiom tvs cvs lhs rhs+  = FamInst { fi_fam      = fam_tc_name+            , fi_flavor   = flavor+            , fi_tcs      = roughMatchTcs lhs+            , fi_tvs      = tvs+            , fi_cvs      = cvs+            , fi_tys      = lhs+            , fi_rhs      = rhs+            , fi_axiom    = axiom+            , fi_orphan   = chooseOrphanAnchor orph_names }+  where+    mod = assert (isExternalName (coAxiomName axiom)) $+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    orph_names = filterNameSet is_local $+                 orphNamesOfAxiomLHS axiom `extendNameSet` fam_tc_name++    fam_tc_name = tyConName (coAxiomTyCon axiom)+++{-+Note [Lazy axiom match]+~~~~~~~~~~~~~~~~~~~~~~~+It is Vitally Important that mkImportedFamInst is *lazy* in its axiom+parameter. The axiom is loaded lazily, via a forkM, in GHC.IfaceToCore. Sometime+later, mkImportedFamInst is called using that axiom. However, the axiom+may itself depend on entities which are not yet loaded as of the time+of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the+axiom, a dependency loop spontaneously appears and GHC hangs. The solution+is simply for mkImportedFamInst never, ever to look inside of the axiom+until everything else is good and ready to do so. We can assume that this+readiness has been achieved when some other code pulls on the axiom in the+FamInst. Thus, we pattern match on the axiom lazily (in the where clause,+not in the parameter list) and we assert the consistency of names there+also.+-}++-- Make a family instance representation from the information found in an+-- interface file.  In particular, we get the rough match info from the iface+-- (instead of computing it here).+mkImportedFamInst :: Name               -- Name of the family+                  -> [RoughMatchTc]     -- Rough match info+                  -> CoAxiom Unbranched -- Axiom introduced+                  -> IsOrphan+                  -> FamInst            -- Resulting family instance+mkImportedFamInst fam mb_tcs axiom orphan+  = FamInst {+      fi_fam    = fam,+      fi_tcs    = mb_tcs,+      fi_tvs    = tvs,+      fi_cvs    = cvs,+      fi_tys    = tys,+      fi_rhs    = rhs,+      fi_axiom  = axiom,+      fi_flavor = flavor,+      fi_orphan = orphan }+  where+     -- See Note [Lazy axiom match]+     ~(CoAxBranch { cab_lhs = tys+                  , cab_tvs = tvs+                  , cab_cvs = cvs+                  , cab_rhs = rhs }) = coAxiomSingleBranch axiom++         -- Derive the flavor for an imported FamInst rather disgustingly+         -- Maybe we should store it in the IfaceFamInst?+     flavor = case splitTyConApp_maybe rhs of+                Just (tc, _)+                  | Just ax' <- tyConFamilyCoercion_maybe tc+                  , ax' == axiom+                  -> DataFamilyInst tc+                _ -> SynFamilyInst++{-+************************************************************************+*                                                                      *+                FamInstEnv+*                                                                      *+************************************************************************++Note [FamInstEnv]+~~~~~~~~~~~~~~~~~+A FamInstEnv is a RoughMap of instance heads. Specifically, the keys are formed+by the family name and the instance arguments. That is, an instance:++    type instance Fam (Maybe Int) a++would insert into the instance environment an instance with a key of the form++  [RM_KnownTc Fam, RM_KnownTc Maybe, RM_WildCard]++See Note [RoughMap] in GHC.Core.RoughMap.+++The same FamInstEnv includes both 'data family' and 'type family' instances.+Type families are reduced during type inference, but not data families;+the user explains when to use a data family instance by using constructors+and pattern matching.++Nevertheless it is still useful to have data families in the FamInstEnv:++ - For finding overlaps and conflicts++ - For finding the representation type...see FamInstEnv.topNormaliseType+   and its call site in GHC.Core.Opt.Simplify.Iteration++ - In standalone deriving instance Eq (T [Int]) we need to find the+   representation type for T [Int]++Note [Varying number of patterns for data family axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For data families, the number of patterns may vary between instances.+For example+   data family T a b+   data instance T Int a = T1 a | T2+   data instance T Bool [a] = T3 a++Then we get a data type for each instance, and an axiom:+   data TInt a = T1 a | T2+   data TBoolList a = T3 a++   axiom ax7   :: T Int ~ TInt   -- Eta-reduced+   axiom ax8 a :: T Bool [a] ~ TBoolList a++These two axioms for T, one with one pattern, one with two;+see Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom++Note [FamInstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn FamInstEnvs into a list in some places that don't directly affect+the ABI. That happens in family consistency checks and when producing output+for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard+to tell what it affects without following a chain of functions. It's also+easy to accidentally make that nondeterminism affect the ABI. Furthermore+the envs should be relatively small, so it should be free to use deterministic+maps here. Testing with nofib and validate detected no difference between+UniqFM and UniqDFM.+See Note [Deterministic UniqFM].+-}++type FamInstEnvs = (FamInstEnv, FamInstEnv)+     -- External package inst-env, Home-package inst-env++data FamInstEnv+  = FamIE !Int -- The number of instances, used to choose the smaller environment+               -- when checking type family consistency of home modules.+          !(RoughMap FamInst)+     -- See Note [FamInstEnv]+     -- See Note [FamInstEnv determinism]+++instance Outputable FamInstEnv where+  ppr (FamIE _ fs) = text "FamIE" <+> vcat (map ppr $ elemsRM fs)++famInstEnvSize :: FamInstEnv -> Int+famInstEnvSize (FamIE sz _) = sz++-- | Create a 'FamInstEnv' from 'Name' indices.+-- INVARIANTS:+--  * The fs_tvs are distinct in each FamInst+--      of a range value of the map (so we can safely unify them)++emptyFamInstEnvs :: (FamInstEnv, FamInstEnv)+emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv)++emptyFamInstEnv :: FamInstEnv+emptyFamInstEnv = FamIE 0 emptyRM++famInstEnvElts :: FamInstEnv -> [FamInst]+famInstEnvElts (FamIE _ rm) = elemsRM rm+  -- See Note [FamInstEnv determinism]++  -- It's OK to use nonDetStrictFoldUDFM here since we're just computing the+  -- size.++familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst]+familyInstances envs tc+  = familyNameInstances envs (tyConName tc)++familyNameInstances :: (FamInstEnv, FamInstEnv) -> Name -> [FamInst]+familyNameInstances (pkg_fie, home_fie) fam+  = get home_fie ++ get pkg_fie+  where+    get :: FamInstEnv -> [FamInst]+    get (FamIE _ env) = lookupRM [RML_KnownTc fam] env+++-- | Makes no particular effort to detect conflicts.+unionFamInstEnv :: FamInstEnv -> FamInstEnv -> FamInstEnv+unionFamInstEnv (FamIE sa a) (FamIE sb b) = FamIE (sa + sb) (a `unionRM` b)++extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv+extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis++extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv+extendFamInstEnv (FamIE s inst_env)+                 ins_item@(FamInst {fi_fam = cls_nm})+  = FamIE (s+1) $ insertRM rough_tmpl ins_item inst_env+  where+    rough_tmpl = RM_KnownTc cls_nm : fi_tcs ins_item++{-+************************************************************************+*                                                                      *+                Compatibility+*                                                                      *+************************************************************************++Note [Apartness]+~~~~~~~~~~~~~~~~+In dealing with closed type families, we must be able to check that one type+will never reduce to another. This check is called /apartness/. The check+is always between a target (which may be an arbitrary type) and a pattern.+Here is how we do it:++apart(target, pattern) = not (unify(flatten(target), pattern))++where flatten (implemented in flattenTys, below) converts all type-family+applications into fresh variables. (See Note [Apartness and type families]+in GHC.Core.Unify.)++Note [Compatibility]+~~~~~~~~~~~~~~~~~~~~+Two patterns are /compatible/ if either of the following conditions hold:+1) The patterns are apart.+2) The patterns unify with a substitution S, and their right hand sides+equal under that substitution.++For open type families, only compatible instances are allowed. For closed+type families, the story is slightly more complicated. Consider the following:++type family F a where+  F Int = Bool+  F a   = Int++g :: Show a => a -> F a+g x = length (show x)++Should that type-check? No. We need to allow for the possibility that 'a'+might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int+only when we can be sure that 'a' is not Int.++To achieve this, after finding a possible match within the equations, we have to+go back to all previous equations and check that, under the substitution induced+by the match, other branches are surely apart, using `tcUnifyTysFG`. (See+Note [Apartness and type families] in GHC.Core.Unify.) This is similar to what+happens with class instance selection, when we need to guarantee that there is+only a match and no unifiers. The exact algorithm is different here because the+potentially-overlapping group is closed.++As another example, consider this:++type family G x where+  G Int = Bool+  G a   = Double++type family H y+-- no instances++Now, we want to simplify (G (H Char)). We can't, because (H Char) might later+simplify to be Int. So, (G (H Char)) is stuck, for now.++While everything above is quite sound, it isn't as expressive as we'd like.+Consider this:++type family J a where+  J Int = Int+  J a   = a++Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if+b is instantiated with Int, but the RHSs coincide there, so it's all OK.++So, the rule is this: when looking up a branch in a closed type family, we+find a branch that matches the target, but then we make sure that the target+is apart from every previous *incompatible* branch. We don't check the+branches that are compatible with the matching branch, because they are either+irrelevant (clause 1 of compatible) or benign (clause 2 of compatible).++Note [Compatibility of eta-reduced axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In newtype instances of data families we eta-reduce the axioms,+See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom. This means that+we sometimes need to test compatibility of two axioms that were eta-reduced to+different degrees, e.g.:+++data family D a b c+newtype instance D a Int c = DInt (Maybe a)+  -- D a Int ~ Maybe+  -- lhs = [a, Int]+newtype instance D Bool Int Char = DIntChar Float+  -- D Bool Int Char ~ Float+  -- lhs = [Bool, Int, Char]++These are obviously incompatible. We could detect this by saturating+(eta-expanding) the shorter LHS with fresh tyvars until the lists are of+equal length, but instead we can just remove the tail of the longer list, as+those types will simply unify with the freshly introduced tyvars.++By doing this, in case the LHS are unifiable, the yielded substitution won't+mention the tyvars that appear in the tail we dropped off, and we might try+to test equality RHSes of different kinds, but that's fine since this case+occurs only for data families, where the RHS is a unique tycon and the equality+fails anyway.+-}++-- See Note [Compatibility]+compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool+compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })+                   (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+  = case tcUnifyTysFG alwaysBindFam alwaysBindTv commonlhs1 commonlhs2 of+      -- Here we need the cab_tvs of the two branches to be disinct.+      -- See Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom.+      SurelyApart     -> True+      MaybeApart {}   -> False+      Unifiable subst -> Type.substTyAddInScope subst rhs1 `eqType`+                         Type.substTyAddInScope subst rhs2+  where+     (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2+     -- See Note [Compatibility of eta-reduced axioms]++-- | Result of testing two type family equations for injectiviy.+data InjectivityCheckResult+   = InjectivityAccepted+    -- ^ Either RHSs are distinct or unification of RHSs leads to unification of+    -- LHSs+   | InjectivityUnified CoAxBranch CoAxBranch+    -- ^ RHSs unify but LHSs don't unify under that substitution.  Relevant for+    -- closed type families where equation after unification might be+    -- overlapped (in which case it is OK if they don't unify).  Constructor+    -- stores axioms after unification.++-- | Check whether two type family axioms don't violate injectivity annotation.+injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch+                  -> InjectivityCheckResult+injectiveBranches injectivity+                  ax1@(CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })+                  ax2@(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })+  -- See Note [Verifying injectivity annotation], case 1.+  = let getInjArgs  = filterByList injectivity+        in_scope    = mkInScopeSetList (tvs1 ++ tvs2)+    in case tcUnifyTyForInjectivity True in_scope rhs1 rhs2 of+             -- True = two-way pre-unification+       Nothing -> InjectivityAccepted+         -- RHS are different, so equations are injective.+         -- This is case 1A from Note [Verifying injectivity annotation]++       Just subst -- RHS unify under a substitution+          -- If LHSs are equal under the substitution used for RHSs then this pair+          -- of equations does not violate injectivity annotation. If LHSs are not+          -- equal under that substitution then this pair of equations violates+          -- injectivity annotation, but for closed type families it still might+          -- be the case that one LHS after substitution is unreachable.+          | eqTypes lhs1Subst lhs2Subst  -- check case 1B1 from Note.+          -> InjectivityAccepted+          | otherwise+          -> InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1+                                      , cab_rhs = Type.substTy  subst rhs1 })+                                ( ax2 { cab_lhs = Type.substTys subst lhs2+                                      , cab_rhs = Type.substTy  subst rhs2 })+                  -- Payload of InjectivityUnified used only for check 1B2, only+                  -- for closed type families+        where+          lhs1Subst = Type.substTys subst (getInjArgs lhs1)+          lhs2Subst = Type.substTys subst (getInjArgs lhs2)++-- takes a CoAxiom with unknown branch incompatibilities and computes+-- the compatibilities+-- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom+computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch]+computeAxiomIncomps branches+  = snd (mapAccumL go [] branches)+  where+    go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)+    go prev_brs cur_br+       = (new_br : prev_brs, new_br)+       where+         new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br }++    mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch]+    mk_incomps prev_brs cur_br+       = filter (not . compatibleBranches cur_br) prev_brs++{-+************************************************************************+*                                                                      *+           Constructing axioms+    These functions are here because tidyType / tcUnifyTysFG+    are not available in GHC.Core.Coercion.Axiom++    Also computeAxiomIncomps is too sophisticated for CoAxiom+*                                                                      *+************************************************************************++Note [Tidy axioms when we build them]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Like types and classes, we build axioms fully quantified over all+their variables, and tidy them when we build them. For example,+we print out axioms and don't want to print stuff like+    F k k a b = ...+Instead we must tidy those kind variables.  See #7524.++We could instead tidy when we print, but that makes it harder to get+things like injectivity errors to come out right. Danger of+     Type family equation violates injectivity annotation.+     Kind variable ‘k’ cannot be inferred from the right-hand side.+     In the type family equation:+        PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2++Note [Always number wildcard types in CoAxBranch]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example (from the DataFamilyInstanceLHS test case):++  data family Sing (a :: k)+  data instance Sing (_ :: MyKind) where+      SingA :: Sing A+      SingB :: Sing B++If we're not careful during tidying, then when this program is compiled with+-ddump-types, we'll get the following information:++  COERCION AXIOMS+    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::+      Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _++It's misleading to have a wildcard type appearing on the RHS like+that. To avoid this issue, when building a CoAxiom (which is what eventually+gets printed above), we tidy all the variables in an env that already contains+'_'. Thus, any variable named '_' will be renamed, giving us the nicer output+here:++  COERCION AXIOMS+    axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 ::+      Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1++Which is at least legal syntax.++See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom; note that we+are tidying (changing OccNames only), not freshening, in accordance with+that Note.+-}++-- all axiom roles are Nominal, as this is only used with type families+mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars+             -> [TyVar] -- Extra eta tyvars+             -> [CoVar] -- possibly stale covars+             -> [Type]  -- LHS patterns+             -> Type    -- RHS+             -> [Role]+             -> SrcSpan+             -> CoAxBranch+mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc+  = CoAxBranch { cab_tvs     = tvs'+               , cab_eta_tvs = eta_tvs'+               , cab_cvs     = cvs'+               , cab_lhs     = tidyTypes env lhs+               , cab_roles   = roles+               , cab_rhs     = tidyType env rhs+               , cab_loc     = loc+               , cab_incomps = placeHolderIncomps }+  where+    (env1, tvs')     = tidyVarBndrs init_tidy_env tvs+    (env2, eta_tvs') = tidyVarBndrs env1          eta_tvs+    (env,  cvs')     = tidyVarBndrs env2          cvs+    -- See Note [Tidy axioms when we build them]+    -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom++    init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")]+    init_tidy_env = mkEmptyTidyEnv init_occ_env+    -- See Note [Always number wildcard types in CoAxBranch]++-- all of the following code is here to avoid mutual dependencies with+-- Coercion+mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched+mkBranchedCoAxiom ax_name fam_tc branches+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = manyBranches (computeAxiomIncomps branches) }++mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched+mkUnbranchedCoAxiom ax_name fam_tc branch+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = Nominal+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }++mkSingleCoAxiom :: Role -> Name+                -> [TyVar] -> [TyVar] -> [CoVar]+                -> TyCon -> [Type] -> Type+                -> CoAxiom Unbranched+-- Make a single-branch CoAxiom, including making the branch itself+-- Used for both type family (Nominal) and data family (Representational)+-- axioms, hence passing in the Role+mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique ax_name+            , co_ax_name     = ax_name+            , co_ax_tc       = fam_tc+            , co_ax_role     = role+            , co_ax_implicit = False+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty+                          (map (const Nominal) tvs)+                          (getSrcSpan ax_name)++-- | Create a coercion constructor (axiom) suitable for the given+--   newtype 'TyCon'. The 'Name' should be that of a new coercion+--   'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and+--   the type the appropriate right hand side of the @newtype@, with+--   the free variables a subset of those 'TyVar's.+mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched+mkNewTypeCoAxiom name tycon tvs roles rhs_ty+  = CoAxiom { co_ax_unique   = nameUnique name+            , co_ax_name     = name+            , co_ax_implicit = True  -- See Note [Implicit axioms] in GHC.Core.TyCon+            , co_ax_role     = Representational+            , co_ax_tc       = tycon+            , co_ax_branches = unbranched (branch { cab_incomps = [] }) }+  where+    branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty+                          roles (getSrcSpan name)++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match.+Multiple matches are only possible in case of type families (not data+families), and then, it doesn't matter which match we choose (as the+instances are guaranteed confluent).++We return the matching family instances and the type instance at which it+matches.  For example, if we lookup 'T [Int]' and have a family instance++  data instance T [a] = ..++desugared to++  data :R42T a = ..+  coe :Co:R42T a :: T [a] ~ :R42T a++we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'.+-}++-- when matching a type family application, we get a FamInst,+-- and the list of types the axiom should be applied to+data FamInstMatch = FamInstMatch { fim_instance :: FamInst+                                 , fim_tys      :: [Type]+                                 , fim_cos      :: [Coercion]+                                 }+  -- See Note [Over-saturated matches]++instance Outputable FamInstMatch where+  ppr (FamInstMatch { fim_instance = inst+                    , fim_tys      = tys+                    , fim_cos      = cos })+    = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos++lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst]+lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc+  = get pkg_ie ++ get home_ie+  where+    get (FamIE _ rm) = lookupRM [RML_KnownTc (tyConName fam_tc)] rm++lookupFamInstEnv+    :: FamInstEnvs+    -> TyCon -> [Type]          -- What we are looking for+    -> [FamInstMatch]           -- Successful matches+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnv+   = lookup_fam_inst_env WantMatches++lookupFamInstEnvConflicts+    :: FamInstEnvs+    -> FamInst          -- Putative new instance+    -> [FamInst]   -- Conflicting matches (don't look at the fim_tys field)+-- E.g. when we are about to add+--    f : type instance F [a] = a->a+-- we do (lookupFamInstConflicts f [b])+-- to find conflicting matches+--+-- Precondition: the tycon is saturated (or over-saturated)++lookupFamInstEnvConflicts envs fam_inst+  = lookup_fam_inst_env (WantConflicts fam_inst) envs fam tys+  where+    (fam, tys) = famInstSplitLHS fam_inst++--------------------------------------------------------------------------------+--                 Type family injectivity checking bits                      --+--------------------------------------------------------------------------------++{- Note [Verifying injectivity annotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Injectivity means that the RHS of a type family uniquely determines the LHS (see+Note [Type inference for type families with injectivity]).  The user informs us about+injectivity using an injectivity annotation and it is GHC's task to verify that+this annotation is correct w.r.t. type family equations. Whenever we see a new+equation of a type family we need to make sure that adding this equation to the+already known equations of a type family does not violate the injectivity annotation+supplied by the user (see Note [Injectivity annotation]).  Of course if the type+family has no injectivity annotation then no check is required.  But if a type+family has injectivity annotation we need to make sure that the following+conditions hold:++1. For each pair of *different* equations of a type family, one of the following+   conditions holds:++   A:  RHSs are different. (Check done in GHC.Core.FamInstEnv.injectiveBranches)++   B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution+       then it must be possible to unify the LHSs under the same substitution.+       Example:++          type family FunnyId a = r | r -> a+          type instance FunnyId Int = Int+          type instance FunnyId a = a++       RHSs of these two equations unify under [ a |-> Int ] substitution.+       Under this substitution LHSs are equal therefore these equations don't+       violate injectivity annotation. (Check done in GHC.Core.FamInstEnv.injectiveBranches)++   B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some+       substitution then either the LHSs unify under the same substitution or+       the LHS of the latter equation is overlapped by earlier equations.+       Example 1:++          type family SwapIntChar a = r | r -> a where+              SwapIntChar Int  = Char+              SwapIntChar Char = Int+              SwapIntChar a    = a++       Say we are checking the last two equations. RHSs unify under [ a |->+       Int ] substitution but LHSs don't. So we apply the substitution to LHS+       of last equation and check whether it is overlapped by any of previous+       equations. Since it is overlapped by the first equation we conclude+       that pair of last two equations does not violate injectivity+       annotation. (Check done in GHC.Tc.Validity.checkValidCoAxiom#gather_conflicts)++   A special case of B is when RHSs unify with an empty substitution ie. they+   are identical.++   If any of the above two conditions holds we conclude that the pair of+   equations does not violate injectivity annotation. But if we find a pair+   of equations where neither of the above holds we report that this pair+   violates injectivity annotation because for a given RHS we don't have a+   unique LHS. (Note that (B) actually implies (A).)++   Note that we only take into account these LHS patterns that were declared+   as injective.++2. If an RHS of a type family equation is a bare type variable then+   all LHS variables (including implicit kind variables) also have to be bare.+   In other words, this has to be a sole equation of that type family and it has+   to cover all possible patterns.  So for example this definition will be+   rejected:++      type family W1 a = r | r -> a+      type instance W1 [a] = a++   If it were accepted we could call `W1 [W1 Int]`, which would reduce to+   `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`,+   which is bogus. Checked FamInst.bareTvInRHSViolated.++3. If the RHS of a type family equation is a type family application then the type+   family is rejected as not injective. This is checked by FamInst.isTFHeaded.++4. If a LHS type variable that is declared as injective is not mentioned in an+   injective position in the RHS then the type family is rejected as not+   injective.  "Injective position" means either an argument to a type+   constructor or argument to a type family on injective position.+   There are subtleties here. See Note [Coverage condition for injective type families]+   in GHC.Tc.Instance.Family.++Check (1) must be done for all family instances (transitively) imported. Other+checks (2-4) should be done just for locally written equations, as they are checks+involving just a single equation, not about interactions. Doing the other checks for+imported equations led to #17405, as the behavior of check (4) depends on+-XUndecidableInstances (see Note [Coverage condition for injective type families] in+FamInst), which may vary between modules.++See also Note [Injective type families] in GHC.Core.TyCon+-}+++-- | Check whether an open type family equation can be added to already existing+-- instance environment without causing conflicts with supplied injectivity+-- annotations.  Returns list of conflicting axioms (type instance+-- declarations).+lookupFamInstEnvInjectivityConflicts+    :: [Bool]         -- injectivity annotation for this type family instance+                      -- INVARIANT: list contains at least one True value+    ->  FamInstEnvs   -- all type instances seen so far+    ->  FamInst       -- new type instance that we're checking+    -> [CoAxBranch]   -- conflicting instance declarations+lookupFamInstEnvInjectivityConflicts injList fam_inst_envs+                             fam_inst@(FamInst { fi_axiom = new_axiom })+  | not $ isOpenFamilyTyCon fam+  = []++  | otherwise+  -- See Note [Verifying injectivity annotation]. This function implements+  -- check (1.B1) for open type families described there.+  = map (coAxiomSingleBranch . fi_axiom) $+    filter isInjConflict $+    familyInstances fam_inst_envs fam+    where+      fam        = famInstTyCon fam_inst+      new_branch = coAxiomSingleBranch new_axiom++      -- filtering function used by `lookup_inj_fam_conflicts` to check whether+      -- a pair of equations conflicts with the injectivity annotation.+      isInjConflict (FamInst { fi_axiom = old_axiom })+          | InjectivityAccepted <-+            injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch+          = False -- no conflict+          | otherwise = True+++--------------------------------------------------------------------------------+--                    Type family overlap checking bits                       --+--------------------------------------------------------------------------------++{-+Note [Family instance overlap conflicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+- In the case of data family instances, any overlap is fundamentally a+  conflict (as these instances imply injective type mappings).++- In the case of type family instances, overlap is admitted as long as+  the right-hand sides of the overlapping rules coincide under the+  overlap substitution.  eg+       type instance F a Int = a+       type instance F Int b = b+  These two overlap on (F Int Int) but then both RHSs are Int,+  so all is well. We require that they are syntactically equal;+  anything else would be difficult to test for at this stage.+-}++------------------------------------------------------------+-- Might be a one-way match or a unifier+data FamInstLookupMode a where+  -- The FamInst we are trying to find conflicts against+  WantConflicts :: FamInst -> FamInstLookupMode FamInst+  WantMatches  :: FamInstLookupMode FamInstMatch++lookup_fam_inst_env'          -- The worker, local to this module+    :: forall a . FamInstLookupMode a+    -> FamInstEnv+    -> TyCon -> [Type]        -- What we are looking for+    -> [a]+lookup_fam_inst_env' lookup_mode (FamIE _ ie) fam match_tys+  | isOpenFamilyTyCon fam+  , let xs = rm_fun (lookupRM' rough_tmpl ie)   -- The common case+    -- Avoid doing any of the allocation below if there are no instances to look at.+  , not $ null xs+  = mapMaybe' check_fun xs+  | otherwise = []+  where+    rough_tmpl :: [RoughMatchLookupTc]+    rough_tmpl = RML_KnownTc (tyConName fam) : map typeToRoughMatchLookupTc match_tys++    rm_fun :: (Bag FamInst, [FamInst]) -> [FamInst]+    (rm_fun, check_fun) = case lookup_mode of+                            WantConflicts fam_inst -> (snd, unify_fun fam_inst)+                            WantMatches -> (bagToList . fst, match_fun)++    -- Function used for finding unifiers+    unify_fun orig_fam_inst item@(FamInst { fi_axiom = old_axiom, fi_tys = tpl_tys, fi_tvs = tpl_tvs })++       = assertPpr (tyCoVarsOfTypes tys `disjointVarSet` mkVarSet tpl_tvs)+                   ((ppr fam <+> ppr tys) $$+                    (ppr tpl_tvs <+> ppr tpl_tys)) $+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+         if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch+           then Nothing+           else Just item+      -- See Note [Family instance overlap conflicts]+      where+        new_branch = coAxiomSingleBranch (famInstAxiom orig_fam_inst)+        (fam, tys) = famInstSplitLHS orig_fam_inst++    -- Function used for checking matches+    match_fun item@(FamInst { fi_tvs = tpl_tvs, fi_cvs = tpl_cvs+                            , fi_tys = tpl_tys }) =  do+      subst <- tcMatchTys tpl_tys match_tys1+      return (FamInstMatch { fim_instance = item+                             , fim_tys      = substTyVars subst tpl_tvs `chkAppend` match_tys2+                             , fim_cos      = assert (all (isJust . lookupCoVar subst) tpl_cvs) $+                                               substCoVars subst tpl_cvs+                             })+        where+          (match_tys1, match_tys2) = split_tys tpl_tys++    -- Precondition: the tycon is saturated (or over-saturated)++    -- Deal with over-saturation+    -- See Note [Over-saturated matches]+    split_tys tpl_tys+      | isTypeFamilyTyCon fam+      = pre_rough_split_tys++      | otherwise+      = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys+        in (match_tys1, match_tys2)++    (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys+    pre_rough_split_tys+      = (pre_match_tys1, pre_match_tys2)++lookup_fam_inst_env           -- The worker, local to this module+    :: FamInstLookupMode a+    -> FamInstEnvs+    -> TyCon -> [Type]        -- What we are looking for+    -> [a]         -- Successful matches++-- Precondition: the tycon is saturated (or over-saturated)++lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys+  =  lookup_fam_inst_env' match_fun home_ie fam tys+  ++ lookup_fam_inst_env' match_fun pkg_ie  fam tys++{-+Note [Over-saturated matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's ok to look up an over-saturated type constructor.  E.g.+     type family F a :: * -> *+     type instance F (a,b) = Either (a->b)++The type instance gives rise to a newtype TyCon (at a higher kind+which you can't do in Haskell!):+     newtype FPair a b = FP (Either (a->b))++Then looking up (F (Int,Bool) Char) will return a FamInstMatch+     (FPair, [Int,Bool,Char])+The "extra" type argument [Char] just stays on the end.++We handle data families and type families separately here:++ * For type families, all instances of a type family must have the+   same arity, so we can precompute the split between the match_tys+   and the overflow tys. This is done in pre_rough_split_tys.++ * For data family instances, though, we need to re-split for each+   instance, because the breakdown might be different for each+   instance.  Why?  Because of eta reduction; see+   Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.+-}++-- checks if one LHS is dominated by a list of other branches+-- in other words, if an application would match the first LHS, it is guaranteed+-- to match at least one of the others. The RHSs are ignored.+-- This algorithm is conservative:+--   True -> the LHS is definitely covered by the others+--   False -> no information+-- It is currently (Oct 2012) used only for generating errors for+-- inaccessible branches. If these errors go unreported, no harm done.+-- This is defined here to avoid a dependency from CoAxiom to Unify+isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool+isDominatedBy branch branches+  = or $ map match branches+    where+      lhs = coAxBranchLHS branch+      match (CoAxBranch { cab_lhs = tys })+        = isJust $ tcMatchTys tys lhs++{-+************************************************************************+*                                                                      *+                Choosing an axiom application+*                                                                      *+************************************************************************++The lookupFamInstEnv function does a nice job for *open* type families,+but we also need to handle closed ones when normalising a type:+-}++reduceTyFamApp_maybe :: FamInstEnvs+                     -> Role              -- Desired role of result coercion+                     -> TyCon -> [Type]+                     -> Maybe Reduction+-- Attempt to do a *one-step* reduction of a type-family application+--    but *not* newtypes+-- Works on type-synonym families always; data-families only if+--     the role we seek is representational+-- It does *not* normalise the type arguments first, so this may not+--     go as far as you want. If you want normalised type arguments,+--     use topReduceTyFamApp_maybe+--+-- The TyCon can be oversaturated.+-- Works on both open and closed families+--+-- Always returns a *homogeneous* coercion -- type family reductions are always+-- homogeneous+reduceTyFamApp_maybe envs role tc tys+  | Phantom <- role+  = Nothing++  | case role of+      Representational -> isOpenFamilyTyCon     tc+      _                -> isOpenTypeFamilyTyCon tc+       -- If we seek a representational coercion+       -- (e.g. the call in topNormaliseType_maybe) then we can+       -- unwrap data families as well as type-synonym families;+       -- otherwise only type-synonym families+  , FamInstMatch { fim_instance = FamInst { fi_axiom = ax }+                 , fim_tys      = inst_tys+                 , fim_cos      = inst_cos } : _ <- lookupFamInstEnv envs tc tys+      -- NB: Allow multiple matches because of compatible overlap++  = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos+    in Just $ coercionRedn co++  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc+  , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys+  = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos+    in Just $ coercionRedn co++  | Just builtin_fam  <- isBuiltInSynFamTyCon_maybe tc+  , Just (rewrite,ts,ty) <- tryMatchFam builtin_fam tys+  = let co = mkAxiomCo rewrite (map mkNomReflCo ts)+    in Just $ mkReduction co ty++  | otherwise+  = Nothing++-- The axiom can be oversaturated. (Closed families only.)+chooseBranch :: CoAxiom Branched -> [Type]+             -> Maybe (BranchIndex, [Type], [Coercion])  -- found match, with args+chooseBranch axiom tys+  = do { let num_pats = coAxiomNumPats axiom+             (target_tys, extra_tys) = splitAt num_pats tys+             branches = coAxiomBranches axiom+       ; (ind, inst_tys, inst_cos)+           <- findBranch (unMkBranches branches) target_tys+       ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) }++-- The axiom must *not* be oversaturated+findBranch :: Array BranchIndex CoAxBranch+           -> [Type]+           -> Maybe (BranchIndex, [Type], [Coercion])+    -- coercions relate requested types to returned axiom LHS at role N+findBranch branches target_tys+  = foldr go Nothing (assocs branches)+  where+    go :: (BranchIndex, CoAxBranch)+       -> Maybe (BranchIndex, [Type], [Coercion])+       -> Maybe (BranchIndex, [Type], [Coercion])+    go (index, branch) other+      = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs+                        , cab_lhs = tpl_lhs }) = branch+        in case tcMatchTys tpl_lhs target_tys of+        Just subst -- Matching worked. now, check for apartness.+          |  apartnessCheck target_tys branch+          -> -- Matching worked & we're apart from all incompatible branches.+             -- success+             assert (all (isJust . lookupCoVar subst) tpl_cvs) $+             Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs)++        -- Failure. keep looking+        _ -> other++-- | Do an apartness check, as described in the "Closed Type Families" paper+-- (POPL '14). This should be used when determining if an equation+-- ('CoAxBranch') of a closed type family can be used to reduce a certain target+-- type family application.+apartnessCheck :: [Type]+               -> CoAxBranch -- ^ The candidate equation we wish to use+                             -- Precondition: this matches the target+               -> Bool       -- ^ True <=> equation can fire+apartnessCheck target (CoAxBranch { cab_incomps = incomps })+  = all (isSurelyApart+         . tcUnifyTysFG alwaysBindFam alwaysBindTv target+         . coAxBranchLHS) incomps+  where+    isSurelyApart SurelyApart = True+    isSurelyApart _           = False++{-+************************************************************************+*                                                                      *+                Looking up a family instance+*                                                                      *+************************************************************************++Note [Normalising types]+~~~~~~~~~~~~~~~~~~~~~~~~+The topNormaliseType function removes all occurrences of type families+and newtypes from the top-level structure of a type. normaliseTcApp does+the type family lookup and is fairly straightforward. normaliseType is+a little more involved.++The complication comes from the fact that a type family might be used in the+kind of a variable bound in a forall. We wish to remove this type family+application, but that means coming up with a fresh variable (with the new+kind). Thus, we need a substitution to be built up as we recur through the+type. However, an ordinary TCvSubst just won't do: when we hit a type variable+whose kind has changed during normalisation, we need both the new type+variable *and* the coercion. We could conjure up a new VarEnv with just this+property, but a usable substitution environment already exists:+LiftingContexts from the liftCoSubst family of functions, defined in GHC.Core.Coercion.+A LiftingContext maps a type variable to a coercion and a coercion variable to+a pair of coercions. Let's ignore coercion variables for now. Because the+coercion a type variable maps to contains the destination type (via+coercionKind), we don't need to store that destination type separately. Thus,+a LiftingContext has what we need: a map from type variables to (Coercion,+Type) pairs.++We also benefit because we can piggyback on the liftCoSubstVarBndr function to+deal with binders. However, I had to modify that function to work with this+application. Thus, we now have liftCoSubstVarBndrUsing, which takes+a function used to process the kind of the binder. We don't wish+to lift the kind, but instead normalise it. So, we pass in a callback function+that processes the kind of the binder.++After that brilliant explanation of all this, I'm sure you've forgotten the+dangling reference to coercion variables. What do we do with those? Nothing at+all. The point of normalising types is to remove type family applications, but+there's no sense in removing these from coercions. We would just get back a+new coercion witnessing the equality between the same types as the original+coercion. Because coercions are irrelevant anyway, there is no point in doing+this. So, whenever we encounter a coercion, we just say that it won't change.+That's what the CoercionTy case is doing within normalise_type.++Note [Normalisation and type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be a bit careful about normalising in the presence of type+synonyms (#13035).  Suppose S is a type synonym, and we have+   S t1 t2+If S is family-free (on its RHS) we can just normalise t1 and t2 and+reconstruct (S t1' t2').   Expanding S could not reveal any new redexes+because type families are saturated.++But if S has a type family on its RHS we expand /before/ normalising+the args t1, t2.  If we normalise t1, t2 first, we'll re-normalise them+after expansion, and that can lead to /exponential/ behaviour; see #13035.++Notice, though, that expanding first can in principle duplicate t1,t2,+which might contain redexes. I'm sure you could conjure up an exponential+case by that route too, but it hasn't happened in practice yet!+-}++topNormaliseType :: FamInstEnvs -> Type -> Type+topNormaliseType env ty+  = case topNormaliseType_maybe env ty of+      Just redn -> reductionReducedType redn+      Nothing   -> ty++topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe Reduction++-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+-- returning an appropriate Representational coercion.  Specifically, if+--   topNormaliseType_maybe env ty = Just (co, ty')+-- then postconditions:+--   (a) co :: ty ~R ty'+--   (b) ty' is not a newtype, and is not a type-family or data-family redex+--+-- However, ty' can be something like (Maybe (F ty)), where+-- (F ty) is a redex.+--+-- Always operates homogeneously: the returned type has the same kind as the+-- original type, and the returned coercion is always homogeneous.+topNormaliseType_maybe env ty+  = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty+       ; let hredn = mkHetReduction (mkReduction co nty) mkind_co+       ; return $ homogeniseHetRedn Representational hredn }+  where+    stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper++    combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2)++    unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)+    unwrapNewTypeStepper' rec_nts tc tys+      = (, MRefl) <$> unwrapNewTypeStepper rec_nts tc tys++      -- second coercion below is the kind coercion relating the original type's kind+      -- to the normalised type's kind+    tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family+      = case topReduceTyFamApp_maybe env tc tys of+          Just (HetReduction (Reduction co rhs) res_co)+            -> NS_Step rec_nts rhs (co, res_co)+          _ -> NS_Done++---------------+-- | Try to simplify a type-family application, by *one* step+-- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co)+-- then    co     :: F tys ~R# rhs+--         res_co :: typeKind(F tys) ~ typeKind(rhs)+-- Type families and data families; always Representational role+topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]+                        -> Maybe HetReduction+topReduceTyFamApp_maybe envs fam_tc arg_tys+  | isFamilyTyCon fam_tc   -- type families and data families+  , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys+  = Just $+      mkHetReduction+        (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn)+        res_co+  | otherwise+  = Nothing+  where+    role = Representational+    ArgsReductions (Reductions args_cos ntys) res_co+      = initNormM envs role (tyCoVarsOfTypes arg_tys)+      $ normalise_tc_args fam_tc arg_tys++---------------+normaliseType :: FamInstEnvs+              -> Role  -- desired role of coercion+              -> Type -> Reduction+normaliseType env role ty+  = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty++---------------+normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction+-- See comments on normaliseType for the arguments of this function+normaliseTcApp env role tc tys+  = initNormM env role (tyCoVarsOfTypes tys) $+    normalise_tc_app tc tys++-------------------------------------------------------+--        Functions that work in the NormM monad+-------------------------------------------------------++-- See Note [Normalising types] about the LiftingContext+normalise_tc_app :: TyCon -> [Type] -> NormM Reduction+normalise_tc_app tc tys+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys+  , not (isFamFreeTyCon tc)  -- Expand and try again+  = -- A synonym with type families in the RHS+    -- Expand and try again+    -- See Note [Normalisation and type synonyms]+    normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')++  | isFamilyTyCon tc+  = -- A type-family application+    do { env <- getEnv+       ; role <- getRole+       ; ArgsReductions redns@(Reductions args_cos ntys) res_co <- normalise_tc_args tc tys+       ; case reduceTyFamApp_maybe env role tc ntys of+           Just redn1+             -> do { redn2 <- normalise_reduction redn1+                   ; let redn3 = mkTyConAppCo role tc args_cos `mkTransRedn` redn2+                   ; return $ assemble_result role redn3 res_co }+           _ -> -- No unique matching family instance exists;+                -- we do not do anything+                return $+                  assemble_result role (mkTyConAppRedn role tc redns) res_co }++  | otherwise+  = -- A synonym with no type families in the RHS; or data type etc+    -- Just normalise the arguments and rebuild+    do { ArgsReductions redns res_co <- normalise_tc_args tc tys+       ; role <- getRole+       ; return $+            assemble_result role (mkTyConAppRedn role tc redns) res_co }++  where+    assemble_result :: Role       -- r, ambient role in NormM monad+                    -> Reduction  -- orig_ty ~r nty, possibly heterogeneous (nty possibly of changed kind)+                    -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)+                    -> Reduction  -- orig_ty ~r nty_casted+                                  -- where nty_casted has same kind as orig_ty+    assemble_result r redn kind_co+      = mkCoherenceRightMRedn r redn (mkSymMCo kind_co)++normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions+normalise_tc_args tc tys+  = do { role <- getRole+       ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys }++normalise_type :: Type -> NormM Reduction+-- Normalise the input type, by eliminating *all* type-function redexes+-- but *not* newtypes (which are visible to the programmer)+-- Returns with Refl if nothing happens+-- Does nothing to newtypes+-- The returned coercion *must* be *homogeneous*+-- See Note [Normalising types]+-- Try not to disturb type synonyms if possible++normalise_type ty+  = go ty+  where+    go :: Type -> NormM Reduction+    go (TyConApp tc tys) = normalise_tc_app tc tys+    go ty@(LitTy {})+      = do { r <- getRole+           ; return $ mkReflRedn r ty }+    go (AppTy ty1 ty2) = go_app_tys ty1 [ty2]++    go (FunTy { ft_af = vis, ft_mult = w, ft_arg = ty1, ft_res = ty2 })+      = do { arg_redn <- go ty1+           ; res_redn <- go ty2+           ; w_redn <- withRole Nominal $ go w+           ; r <- getRole+           ; return $ mkFunRedn r vis w_redn arg_redn res_redn }+    go (ForAllTy (Bndr tcvar vis) ty)+      = do { (lc', tv', k_redn) <- normalise_var_bndr tcvar+           ; redn <- withLC lc' $ normalise_type ty+           ; return $ mkForAllRedn vis tv' k_redn redn }+    go (TyVarTy tv)    = normalise_tyvar tv+    go (CastTy ty co)+      = do { redn <- go ty+           ; lc <- getLC+           ; let co' = substRightCo lc co+           ; return $ mkCastRedn2 Nominal ty co redn co'+             --       ^^^^^^^^^^^ uses castCoercionKind2+           }+    go (CoercionTy co)+      = do { lc <- getLC+           ; r <- getRole+           ; let kco = liftCoSubst Nominal lc (coercionType co)+                 co' = substRightCo lc co+           ; return $ mkProofIrrelRedn r kco co co' }++    go_app_tys :: Type   -- function+               -> [Type] -- args+               -> NormM Reduction+    -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args+    go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)+    go_app_tys fun_ty arg_tys+      = do { fun_redn@(Reduction fun_co nfun) <- go fun_ty+           ; case tcSplitTyConApp_maybe nfun of+               Just (tc, xis) ->+                 do { redn <- go (mkTyConApp tc (xis ++ arg_tys))+                   -- rewrite_app_ty_args avoids redundantly processing the xis,+                   -- but that's a much more performance-sensitive function.+                   -- This type normalisation is not called in a loop.+                    ; return $+                        mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransRedn` redn }+               Nothing ->+                 do { ArgsReductions redns res_co+                        <- normalise_args (typeKind nfun)+                                          (Inf.repeat Nominal)+                                          arg_tys+                    ; role <- getRole+                    ; return $+                        mkCoherenceRightMRedn role+                          (mkAppRedns fun_redn redns)+                          (mkSymMCo res_co) } }++normalise_args :: Kind    -- of the function+               -> Infinite Role  -- roles at which to normalise args+               -> [Type]  -- args+               -> NormM ArgsReductions+-- returns ArgsReductions (Reductions cos xis) res_co,+-- where each xi is the normalised version of the corresponding type,+-- each co is orig_arg ~ xi, and res_co :: kind(f orig_args) ~ kind(f xis).+-- NB: The xis might *not* have the same kinds as the input types,+-- but the resulting application *will* be well-kinded+-- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow+normalise_args fun_ki roles args+  = do { normed_args <- zipWithM normalise1 (Inf.toList roles) args+       ; return $ simplifyArgsWorker ki_binders inner_ki fvs roles normed_args }+  where+    (ki_binders, inner_ki) = splitPiTys fun_ki+    fvs = tyCoVarsOfTypes args++    normalise1 role ty+      = withRole role $ normalise_type ty++normalise_tyvar :: TyVar -> NormM Reduction+normalise_tyvar tv+  = assert (isTyVar tv) $+    do { lc <- getLC+       ; r  <- getRole+       ; return $ case liftCoSubstTyVar lc r tv of+           Just co -> coercionRedn co+           Nothing -> mkReflRedn r (mkTyVarTy tv) }++normalise_reduction :: Reduction -> NormM Reduction+normalise_reduction (Reduction co ty)+  = do { redn' <- normalise_type ty+       ; return $ co `mkTransRedn` redn' }++normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Reduction)+normalise_var_bndr tcvar+  -- works for both tvar and covar+  = do { lc1 <- getLC+       ; env <- getEnv+       ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal+       ; return $ liftCoSubstVarBndrUsing reductionCoercion callback lc1 tcvar }++-- | a monad for the normalisation functions, reading 'FamInstEnvs',+-- a 'LiftingContext', and a 'Role'.+newtype NormM a = NormM { runNormM ::+                            FamInstEnvs -> LiftingContext -> Role -> a }+    deriving (Functor)++initNormM :: FamInstEnvs -> Role+          -> TyCoVarSet   -- the in-scope variables+          -> NormM a -> a+initNormM env role vars (NormM thing_inside)+  = thing_inside env lc role+  where+    in_scope = mkInScopeSet vars+    lc       = emptyLiftingContext in_scope++getRole :: NormM Role+getRole = NormM (\ _ _ r -> r)++getLC :: NormM LiftingContext+getLC = NormM (\ _ lc _ -> lc)++getEnv :: NormM FamInstEnvs+getEnv = NormM (\ env _ _ -> env)++withRole :: Role -> NormM a -> NormM a+withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r++withLC :: LiftingContext -> NormM a -> NormM a+withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r++instance Monad NormM where+  ma >>= fmb = NormM $ \env lc r ->+               let a = runNormM ma env lc r in+               runNormM (fmb a) env lc r++instance Applicative NormM where+  pure x = NormM $ \ _ _ _ -> x+  (<*>)  = ap
+ GHC/Core/InstEnv.hs view
@@ -0,0 +1,1711 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[InstEnv]{Utilities for typechecking instance declarations}++The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv.+-}++{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}++module GHC.Core.InstEnv (+        DFunId, InstMatch, ClsInstLookupResult,+        CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers,+        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances,+        instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,+        instanceDFunId, updateClsInstDFuns, updateClsInstDFun,+        fuzzyClsInstCmp, orphNamesOfClsInst,++        InstEnvs(..), VisibleOrphanModules, InstEnv,+        LookupInstanceErrReason (..),+        mkInstEnv, emptyInstEnv, unionInstEnv, extendInstEnv,+        filterInstEnv, deleteFromInstEnv, deleteDFunFromInstEnv,+        anyInstEnv,+        identicalClsInstHead,+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses, mapInstEnv,+        memberInstEnv,+        instIsVisible,+        classInstances, instanceBindFun,+        classNameInstances,+        instanceCantMatch, roughMatchTcs,+        isOverlappable, isOverlapping, isIncoherent+    ) where++import GHC.Prelude hiding ( head, init, last, tail )++import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker,+              -- and depends on TcType in many ways+import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )+import GHC.Core.RoughMap+import GHC.Core.Class+import GHC.Core.Unify+import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )+import GHC.Hs.Extension++import GHC.Unit.Module.Env+import GHC.Unit.Module.Warnings+import GHC.Unit.Types+import GHC.Types.Var+import GHC.Types.Unique.DSet+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Generics (Generic)+import Data.Data        ( Data )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Maybe       ( isJust )++import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Panic+import Data.Semigroup++{-+************************************************************************+*                                                                      *+           ClsInst: the data type for type-class instances+*                                                                      *+************************************************************************+-}++-- | A type-class instance. Note that there is some tricky laziness at work+-- here. See Note [ClsInst laziness and the rough-match fields] for more+-- details.+data ClsInst+  = ClsInst {   -- Used for "rough matching"; see+                -- Note [ClsInst laziness and the rough-match fields]+                -- INVARIANT: is_tcs = KnownTc is_cls_nm : roughMatchTcs is_tys+               is_cls_nm :: Name          -- ^ Class name++             , is_tcs  :: [RoughMatchTc]  -- ^ Top of type args+                          -- The class itself is always+                          -- the first element of this list++               -- | @is_dfun_name = idName . is_dfun@.+               --+               -- We use 'is_dfun_name' for the visibility check,+               -- 'instIsVisible', which needs to know the 'Module' which the+               -- dictionary is defined in. However, we cannot use the 'Module'+               -- attached to 'is_dfun' since doing so would mean we would+               -- potentially pull in an entire interface file unnecessarily.+               -- This was the cause of #12367.+             , is_dfun_name :: Name++                -- Used for "proper matching"; see Note [Proper-match fields]+             , is_tvs  :: [TyVar]       -- Fresh template tyvars for full match+                                        -- See Note [Template tyvars are fresh]+             , is_cls  :: Class         -- The real class+             , is_tys  :: [Type]        -- Full arg types (mentioning is_tvs)+                -- INVARIANT: is_dfun Id has type+                --      forall is_tvs. (...) => is_cls is_tys+                -- (modulo alpha conversion)++             , is_dfun :: DFunId -- See Note [Haddock assumptions]++             , is_flag :: OverlapFlag   -- See detailed comments with+                                        -- the decl of BasicTypes.OverlapFlag+             , is_orphan :: IsOrphan+             , is_warn :: Maybe (WarningTxt GhcRn)+                -- Warning emitted when the instance is used+                -- See Note [Implementation of deprecated instances]+                -- in GHC.Tc.Solver.Dict+    }+  deriving Data++-- | A fuzzy comparison function for class instances, intended for sorting+-- instances before displaying them to the user.+fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering+fuzzyClsInstCmp x y =+    foldMap cmp (zip (is_tcs x) (is_tcs y))+  where+    cmp (RM_WildCard,  RM_WildCard)   = EQ+    cmp (RM_WildCard,  RM_KnownTc _) = LT+    cmp (RM_KnownTc _, RM_WildCard)   = GT+    cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y++isOverlappable, isOverlapping, isIncoherent, isNonCanonical :: ClsInst -> Bool+isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))+isOverlapping  i = hasOverlappingFlag  (overlapMode (is_flag i))+isIncoherent   i = hasIncoherentFlag   (overlapMode (is_flag i))+isNonCanonical i = hasNonCanonicalFlag (overlapMode (is_flag i))++{-+Note [ClsInst laziness and the rough-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is+otherwise unused in the program. Then it's stupid to load B.hi, the data type+declaration for B.T -- and perhaps further instance declarations!++We avoid this as follows:++* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's+  content.++* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys+  contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we+  poke any of these fields we'll typecheck the DFunId declaration, and hence+  pull in interfaces that it refers to. See Note [Proper-match fields].++* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and+  is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking+  inside the DFunId. The rough-match fields allow us to say "definitely does not+  match", based only on Names.  See GHC.Core.Unify+  Note [Rough matching in class and family instances]++  This laziness is very important; see #12367. Try hard to avoid pulling on+  the structured fields unless you really need the instance.++* Another place to watch is InstEnv.instIsVisible, which needs the module to+  which the ClsInst belongs. We can get this from is_dfun_name.+-}++{-+Note [Template tyvars are fresh]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs field of a ClsInst has *completely fresh* tyvars.+That is, they are+  * distinct from any other ClsInst+  * distinct from any tyvars free in predicates that may+    be looked up in the class instance environment+Reason for freshness: we use unification when checking for overlap+etc, and that requires the tyvars to be distinct.++The invariant is checked by the ASSERT in instEnvMatchesAndUnifiers.++Note [Proper-match fields]+~~~~~~~~~~~~~~~~~~~~~~~~~+The is_tvs, is_cls, is_tys fields are simply cached values, pulled+out (lazily) from the dfun id. They are cached here simply so+that we don't need to decompose the DFunId each time we want+to match it.  The hope is that the rough-match fields mean+that we often never poke the proper-match fields.++However, note that:+ * is_tvs must be a superset of the free vars of is_tys++ * is_tvs, is_tys may be alpha-renamed compared to the ones in+   the dfun Id++Note [Haddock assumptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For normal user-written instances, Haddock relies on++ * the SrcSpan of+ * the Name of+ * the is_dfun of+ * an Instance++being equal to++  * the SrcSpan of+  * the instance head type of+  * the InstDecl used to construct the Instance.+-}++instanceDFunId :: ClsInst -> DFunId+instanceDFunId = is_dfun++updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst+updateClsInstDFun tidy_dfun ispec+  = ispec { is_dfun = tidy_dfun (is_dfun ispec) }++updateClsInstDFuns :: (DFunId -> DFunId) -> InstEnv -> InstEnv+updateClsInstDFuns tidy_dfun (InstEnv rm)+  = InstEnv $ fmap (updateClsInstDFun tidy_dfun) rm++instance NamedThing ClsInst where+   getName ispec = getName (is_dfun ispec)++instance Outputable ClsInst where+   ppr = pprInstance++pprDFunId :: DFunId -> SDoc+-- Prints the analogous information to `pprInstance`+-- but with just the DFunId+pprDFunId dfun+  = hang dfun_header+       2 (vcat [ text "--" <+> pprDefinedAt (getName dfun)+               , whenPprDebug (ppr dfun) ])+  where+    dfun_header = ppr_overlap_dfun_hdr empty dfun++pprInstance :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstance ispec+  = hang (pprInstanceHdr ispec)+       2 (vcat [ text "--" <+> pprDefinedAt (getName ispec)+               , whenPprDebug (ppr (is_dfun ispec)) ])++-- * pprInstanceHdr is used in VStudio to populate the ClassView tree+pprInstanceHdr :: ClsInst -> SDoc+-- Prints the ClsInst as an instance declaration+pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })+  = ppr_overlap_dfun_hdr (ppr flag) dfun++ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc+ppr_overlap_dfun_hdr flag_sdoc dfun+  = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun)++pprInstances :: [ClsInst] -> SDoc+pprInstances ispecs = vcat (map pprInstance ispecs)++instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)+instanceWarning = is_warn++instanceHead :: ClsInst -> ([TyVar], Class, [Type])+-- Returns the head, using the fresh tyvars from the ClsInst+instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })+   = (tvs, cls, tys)++-- | Collects the names of concrete types and type constructors that make+-- up the head of a class instance. For instance, given `class Foo a b`:+--+-- `instance Foo (Either (Maybe Int) a) Bool` would yield+--      [Either, Maybe, Int, Bool]+--+-- Used in the implementation of ":info" in GHCi.+--+-- The 'tcSplitSigmaTy' is because of+--      instance Foo a => Baz T where ...+-- The decl is an orphan if Baz and T are both not locally defined,+--      even if Foo *is* locally defined+orphNamesOfClsInst :: ClsInst -> NameSet+orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys })+  = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm++instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])+-- Decomposes the DFunId+instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))++mkLocalClsInst :: DFunId -> OverlapFlag+               -> [TyVar] -> Class -> [Type]+               -> Maybe (WarningTxt GhcRn)+               -> ClsInst+-- Used for local instances, where we can safely pull on the DFunId.+-- Consider using newClsInst instead; this will also warn if+-- the instance is an orphan.+mkLocalClsInst dfun oflag tvs cls tys warn+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs+            , is_dfun_name = dfun_name+            , is_cls = cls, is_cls_nm = cls_name+            , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys+            , is_orphan = orph, is_warn = warn+            }+  where+    cls_name = className cls+    dfun_name = idName dfun+    this_mod = assert (isExternalName dfun_name) $ nameModule dfun_name+    is_local name = nameIsLocalOrFrom this_mod name++        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv+    (cls_tvs, fds) = classTvsFds cls+    arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys]++    -- See Note [When exactly is an instance decl an orphan?]+    orph | is_local cls_name   = NotOrphan (nameOccName cls_name)+         | all notOrphan mb_ns = NE.head mb_ns+         | otherwise           = IsOrphan++    notOrphan NotOrphan{} = True+    notOrphan _ = False++    mb_ns :: NonEmpty IsOrphan+    -- One for each fundep; a locally-defined name+    -- that is not in the "determined" arguments+    mb_ns = case nonEmpty fds of+        Nothing -> NE.singleton (choose_one arg_names)+        Just fds -> fmap do_one fds+    do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names+                                            , not (tv `elem` rtvs)]++    choose_one nss = chooseOrphanAnchor (unionNameSets nss)++mkImportedClsInst :: Name                     -- ^ the name of the class+                  -> [RoughMatchTc]           -- ^ the rough match signature of the instance+                  -> Name                     -- ^ the 'Name' of the dictionary binding+                  -> DFunId                   -- ^ the 'Id' of the dictionary.+                  -> OverlapFlag              -- ^ may this instance overlap?+                  -> IsOrphan                 -- ^ is this instance an orphan?+                  -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved+                  -> ClsInst+-- Used for imported instances, where we get the rough-match stuff+-- from the interface file+-- The bound tyvars of the dfun are guaranteed fresh, because+-- the dfun has been typechecked out of the same interface file+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn+  = ClsInst { is_flag = oflag, is_dfun = dfun+            , is_tvs = tvs, is_tys = tys+            , is_dfun_name = dfun_name+            , is_cls_nm = cls_nm, is_cls = cls+            , is_tcs = RM_KnownTc cls_nm : mb_tcs+            , is_orphan = orphan+            , is_warn = warn }+  where+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)++{-+Note [When exactly is an instance decl an orphan?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(See GHC.Iface.Make.instanceToIfaceInst, which implements this.)+See Note [Orphans] in GHC.Core++Roughly speaking, an instance is an orphan if its head (after the =>)+mentions nothing defined in this module.++Functional dependencies complicate the situation though. Consider++  module M where { class C a b | a -> b }++and suppose we are compiling module X:++  module X where+        import M+        data T = ...+        instance C Int T where ...++This instance is an orphan, because when compiling a third module Y we+might get a constraint (C Int v), and we'd want to improve v to T.  So+we must make sure X's instances are loaded, even if we do not directly+use anything from X.++More precisely, an instance is an orphan iff++  If there are no fundeps, then at least of the names in+  the instance head is locally defined.++  If there are fundeps, then for every fundep, at least one of the+  names free in a *non-determined* part of the instance head is+  defined in this module.++(Note that these conditions hold trivially if the class is locally+defined.)+++************************************************************************+*                                                                      *+                InstEnv, ClsInstEnv+*                                                                      *+************************************************************************++A @ClsInstEnv@ all the instances of that class.  The @Id@ inside a+ClsInstEnv mapping is the dfun for that instance.++If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then++        forall a b, C t1 t2 t3  can be constructed by dfun++or, to put it another way, we have++        instance (...) => C t1 t2 t3,  witnessed by dfun+-}++---------------------------------------------------+{-+Note [InstEnv determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We turn InstEnvs into a list in some places that don't directly affect+the ABI. That happens when we create output for `:info`.+Unfortunately that nondeterminism is nonlocal and it's hard to tell what it+affects without following a chain of functions. It's also easy to accidentally+make that nondeterminism affect the ABI. Furthermore the envs should be+relatively small, so it should be free to use deterministic maps here.+Testing with nofib and validate detected no difference between UniqFM and+UniqDFM. See also Note [Deterministic UniqFM]+-}++-- Internally it's safe to indexable this map by+-- by @Class@, the classes @Name@, the classes @TyCon@+-- or it's @Unique@.+-- This is since:+-- getUnique cls == getUnique (className cls) == getUnique (classTyCon cls)+--+-- We still use Class as key type as it's both the common case+-- and conveys the meaning better. But the implementation of+--InstEnv is a bit more lax internally.+newtype InstEnv = InstEnv (RoughMap ClsInst)      -- Maps Class to instances for that class+  -- See Note [InstEnv determinism]++instance Outputable InstEnv where+  ppr (InstEnv rm) = pprInstances $ elemsRM rm++-- | 'InstEnvs' represents the combination of the global type class instance+-- environment, the local type class instance environment, and the set of+-- transitively reachable orphan modules (according to what modules have been+-- directly imported) used to test orphan instance visibility.+data InstEnvs = InstEnvs {+        ie_global  :: InstEnv,               -- External-package instances+        ie_local   :: InstEnv,               -- Home-package instances+        ie_visible :: VisibleOrphanModules   -- Set of all orphan modules transitively+                                             -- reachable from the module being compiled+                                             -- See Note [Instance lookup and orphan instances]+    }++-- | Set of visible orphan modules, according to what modules have been directly+-- imported.  This is based off of the dep_orphs field, which records+-- transitively reachable orphan modules (modules that define orphan instances).+type VisibleOrphanModules = ModuleSet+++-- INVARIANTS:+--  * The is_tvs are distinct in each ClsInst+--      of a ClsInstEnv (so we can safely unify them)++-- Thus, the @ClsInstEnv@ for @Eq@ might contain the following entry:+--      [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]+-- The "a" in the pattern must be one of the forall'd variables in+-- the dfun type.++emptyInstEnv :: InstEnv+emptyInstEnv = InstEnv emptyRM++mkInstEnv :: [ClsInst] -> InstEnv+mkInstEnv = extendInstEnvList emptyInstEnv++instEnvElts :: InstEnv -> [ClsInst]+instEnvElts (InstEnv rm) = elemsRM rm+  -- See Note [InstEnv determinism]++instEnvEltsForClass :: InstEnv -> Name -> [ClsInst]+instEnvEltsForClass (InstEnv rm) cls_nm = lookupRM [RML_KnownTc cls_nm] rm++-- N.B. this is not particularly efficient but used only by GHCi.+instEnvClasses :: InstEnv -> UniqDSet Class+instEnvClasses ie = mkUniqDSet $ map is_cls (instEnvElts ie)++-- | Test if an instance is visible, by checking that its origin module+-- is in 'VisibleOrphanModules'.+-- See Note [Instance lookup and orphan instances]+instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool+instIsVisible vis_mods ispec+  -- NB: Instances from the interactive package always are visible. We can't+  -- add interactive modules to the set since we keep creating new ones+  -- as a GHCi session progresses.+  = case nameModule_maybe (is_dfun_name ispec) of+      Nothing -> True+      Just mod | isInteractiveModule mod     -> True+               | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods+               | otherwise                   -> True++classInstances :: InstEnvs -> Class -> [ClsInst]+classInstances envs cls = classNameInstances envs (className cls)++classNameInstances :: InstEnvs -> Name -> [ClsInst]+classNameInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls+  = get home_ie ++ get pkg_ie+  where+    get :: InstEnv -> [ClsInst]+    get ie = filter (instIsVisible vis_mods) (instEnvEltsForClass ie cls)++-- | Checks for an exact match of ClsInst in the instance environment.+-- We use this when we do signature checking in "GHC.Tc.Module"+memberInstEnv :: InstEnv -> ClsInst -> Bool+memberInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs } ) =+    any (identicalDFunType ins_item) (fst $ lookupRM' (map roughMatchTcToLookup tcs) rm)+ where+  identicalDFunType cls1 cls2 =+    eqType (varType (is_dfun cls1)) (varType (is_dfun cls2))++-- | Makes no particular effort to detect conflicts.+unionInstEnv :: InstEnv -> InstEnv -> InstEnv+unionInstEnv (InstEnv a) (InstEnv b) = InstEnv (a `unionRM` b)++extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv+extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs++extendInstEnv :: InstEnv -> ClsInst -> InstEnv+extendInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs })+  = InstEnv $ insertRM tcs ins_item rm++filterInstEnv :: (ClsInst -> Bool) -> InstEnv -> InstEnv+filterInstEnv pred (InstEnv rm)+  = InstEnv $ filterRM pred rm++anyInstEnv :: (ClsInst -> Bool) -> InstEnv -> Bool+anyInstEnv pred (InstEnv rm)+  = foldRM (\x rest -> pred x || rest) False rm++mapInstEnv :: (ClsInst -> ClsInst) -> InstEnv -> InstEnv+mapInstEnv f (InstEnv rm) = InstEnv (f <$> rm)++deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv+deleteFromInstEnv (InstEnv rm) ins_item@(ClsInst { is_tcs = tcs })+  = InstEnv $ filterMatchingRM (not . identicalClsInstHead ins_item) tcs rm++deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv+-- Delete a specific instance fron an InstEnv+deleteDFunFromInstEnv (InstEnv rm) dfun+  = InstEnv $ filterMatchingRM (not . same_dfun) [RM_KnownTc (className cls)] rm+  where+    (_, _, cls, _) = tcSplitDFunTy (idType dfun)+    same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun'++identicalClsInstHead :: ClsInst -> ClsInst -> Bool+-- ^ True when when the instance heads are the same+-- e.g.  both are   Eq [(a,b)]+-- Used for overriding in GHCi+-- Obviously should be insensitive to alpha-renaming+identicalClsInstHead (ClsInst { is_tcs = rough1, is_tys = tys1 })+                     (ClsInst { is_tcs = rough2, is_tys = tys2 })+  =  not (instanceCantMatch rough1 rough2)  -- Fast check for no match, uses the "rough match" fields;+                                            -- also accounts for class name.+  && isJust (tcMatchTys tys1 tys2)+  && isJust (tcMatchTys tys2 tys1)++{-+************************************************************************+*                                                                      *+        Looking up an instance+*                                                                      *+************************************************************************++@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match.  Since+the env is kept ordered, the first match must be the only one.  The+thing we are looking up can have an arbitrary "flexi" part.++Note [Instance lookup and orphan instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are compiling a module M, and we have a zillion packages+loaded, and we are looking up an instance for C (T W).  If we find a+match in module 'X' from package 'p', should be "in scope"; that is,++  is p:X in the transitive closure of modules imported from M?++The difficulty is that the "zillion packages" might include ones loaded+through earlier invocations of the GHC API, or earlier module loads in GHCi.+They might not be in the dependencies of M itself; and if not, the instances+in them should not be visible.  #2182, #8427.++There are two cases:+  * If the instance is *not an orphan*, then module X defines C, T, or W.+    And in order for those types to be involved in typechecking M, it+    must be that X is in the transitive closure of M's imports.  So we+    can use the instance.++  * If the instance *is an orphan*, the above reasoning does not apply.+    So we keep track of the set of orphan modules transitively below M;+    this is the ie_visible field of InstEnvs, of type VisibleOrphanModules.++    If module p:X is in this set, then we can use the instance, otherwise+    we can't.++Note [Rules for instance lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions implement the carefully-written rules in the user+manual section on "overlapping instances". At risk of duplication,+here are the rules.  If the rules change, change this text and the+user manual simultaneously.  The link may be this:+https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/instances.html#instance-overlap++The willingness to be overlapped or incoherent is a property of the+instance declaration itself, controlled by its `OverlapMode`, as follows++ * An instance is "incoherent" (OverlapMode = `Incoherent` or `NonCanonical`)+   if it has an `INCOHERENT` pragma, or+   if it appears in a module compiled with `-XIncoherentInstances`.+   In those cases:+      -fspecialise-incoherents on  => Incoherent+      -fspecialise-incoherents off => NonCanonical+   NB: it is on by default++ * An instance is "overlappable" (OverlapMode = `Overlappable` or `Overlaps`)+   if it has an `OVERLAPPABLE` or `OVERLAPS` pragma, or+   if it appears in a module compiled with `-XOverlappingInstances`, or+   if the instance is incoherent.++ * An instance is "overlapping" (OverlapMode = `Overlapping` or `Overlaps`)+   if it has an `OVERLAPPING` or `OVERLAPS` pragma, or+   if it appears in a module compiled with `-XOverlappingInstances`, or+   if the instance is incoherent.++Now suppose that, in some client module, we are searching for an instance+of the target constraint (C ty1 .. tyn). The search works like this.++(IL0) If there are any local Givens that match (potentially unifying+      any metavariables, even untouchable ones) the target constraint,+      the search fails unless -XIncoherentInstances is enabled. See+      Note [Instance and Given overlap] in GHC.Tc.Solver.Dict.  This is+      implemented by the first guard in matchClassInst.++(IL1) Find `all_matches` and `all_unifs` in `lookupInstEnv`:+      - all_matches: all instances `I` that *match* the target constraint (that+        is, the target constraint is a substitution instance of `I`). These+        instance declarations are the /candidates/.+      - all_unifs: all non-incoherent instances that *unify with but do not match*+        the target constraint. These are not candidates, but might match later if+        the target constraint is furhter instantiated. See+        `data PotentialUnifiers` for more precise details.++(IL2) If there are no candidates, the search fails+      (lookupInstEnv returns no final_matches). The PotentialUnifiers are returned+      by lookupInstEnv for use in error message generation (mkDictErr).++(IL3) Eliminate any candidate `IX` for which there is another candidate `IY` such+      that both of the following hold:+      - `IY` is strictly more specific than `IX`. That is, `IY` is a+        substitution instance of `IX` but not vice versa.+      - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This+        "either/or" design, rather than a "both/and" design, allow a+        client to deliberately override an instance from a library,+        without requiring a change to the library.)++      In addition, provided there is at least one candidate, eliminate any other+      candidates that are *incoherent*. (In particular, if all remaining candidates+      are incoherent, all except an arbitrarily chosen one will be eliminated.)++      This is implemented by `pruneOverlappedMatches`, producing final_matches in+      lookupInstEnv.  See Note [Instance overlap and guards] and+      Note [Incoherent instances].++(IL4) If exactly one *incoherent* candidate remains, the search succeeds.+      (By the previous step, there cannot be more than one incoherent candidate+      remaining.)++      In this case, lookupInstEnv returns the successful match, and it returns+      NoUnifiers as the final_unifs, which amounts to skipping the following+      steps.++(IL5) If more than one candidate remains, the search fails. (We have already+      eliminated the incoherent candidates, and we have no way to select+      between non-incoherent candidates.)++(IL6) Otherwise there is exactly one candidate remaining. The all_unifs+      computed at step (IL1) are returned from lookupInstEnv as final_unifs.++      If there are no potential unifiers, the search succeeds (in matchInstEnv).+      If there is at least one (non-incoherent) potential unifier, matchInstEnv+      returns a NotSure result and refrains from committing to the instance.++      Incoherent instances are not returned as part of the potential unifiers. This+      affects error messages: they will not be listed as "potentially matching instances"+      in an "Overlapping instances" or "Ambiguous type variable" error.+      See also Note [Recording coherence information in `PotentialUnifiers`].+++Notice that these rules are not influenced by flag settings in the+client module, where the instances are *used*. These rules make it+possible for a library author to design a library that relies on+overlapping instances without the client having to know.++Note [Overlapping instances]   (NB: these notes are quite old)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Overlap is permitted, but only in such a way that one can make+a unique choice when looking up.  That is, overlap is only permitted if+one template matches the other, or vice versa.  So this is ok:++  [a]  [Int]++but this is not++  (Int,a)  (b,Int)++If overlap is permitted, the list is kept most specific first, so that+the first lookup is the right choice.+++For now we just use association lists.++\subsection{Avoiding a problem with overlapping}++Consider this little program:++\begin{pseudocode}+     class C a        where c :: a+     class C a => D a where d :: a++     instance C Int where c = 17+     instance D Int where d = 13++     instance C a => C [a] where c = [c]+     instance ({- C [a], -} D a) => D [a] where d = c++     instance C [Int] where c = [37]++     main = print (d :: [Int])+\end{pseudocode}++What do you think `main' prints  (assuming we have overlapping instances, and+all that turned on)?  Well, the instance for `D' at type `[a]' is defined to+be `c' at the same type, and we've got an instance of `C' at `[Int]', so the+answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because+the `C [Int]' instance is more specific).++Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong.  That+was easy ;-)  Let's just consult hugs for good measure.  Wait - if I use old+hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it+doesn't even compile!  What's going on!?++What hugs complains about is the `D [a]' instance decl.++\begin{pseudocode}+     ERROR "mj.hs" (line 10): Cannot build superclass instance+     *** Instance            : D [a]+     *** Context supplied    : D a+     *** Required superclass : C [a]+\end{pseudocode}++You might wonder what hugs is complaining about.  It's saying that you+need to add `C [a]' to the context of the `D [a]' instance (as appears+in comments).  But there's that `C [a]' instance decl one line above+that says that I can reduce the need for a `C [a]' instance to the+need for a `C a' instance, and in this case, I already have the+necessary `C a' instance (since we have `D a' explicitly in the+context, and `C' is a superclass of `D').++Unfortunately, the above reasoning indicates a premature commitment to the+generic `C [a]' instance.  I.e., it prematurely rules out the more specific+instance `C [Int]'.  This is the mistake that ghc-4.06 makes.  The fix is to+add the context that hugs suggests (uncomment the `C [a]'), effectively+deferring the decision about which instance to use.++Now, interestingly enough, 4.04 has this same bug, but it's covered up+in this case by a little known `optimization' that was disabled in+4.06.  Ghc-4.04 silently inserts any missing superclass context into+an instance declaration.  In this case, it silently inserts the `C+[a]', and everything happens to work out.++(See `GHC.Types.Id.Make.mkDictFunId' for the code in question.  Search for+`Mark Jones', although Mark claims no credit for the `optimization' in+question, and would rather it stopped being called the `Mark Jones+optimization' ;-)++So, what's the fix?  I think hugs has it right.  Here's why.  Let's try+something else out with ghc-4.04.  Let's add the following line:++    d' :: D a => [a]+    d' = c++Everyone raise their hand who thinks that `d :: [Int]' should give a+different answer from `d' :: [Int]'.  Well, in ghc-4.04, it does.  The+`optimization' only applies to instance decls, not to regular+bindings, giving inconsistent behavior.++Old hugs had this same bug.  Here's how we fixed it: like GHC, the+list of instances for a given class is ordered, so that more specific+instances come before more generic ones.  For example, the instance+list for C might contain:+    ..., C Int, ..., C a, ...+When we go to look for a `C Int' instance we'll get that one first.+But what if we go looking for a `C b' (`b' is unconstrained)?  We'll+pass the `C Int' instance, and keep going.  But if `b' is+unconstrained, then we don't know yet if the more specific instance+will eventually apply.  GHC keeps going, and matches on the generic `C+a'.  The fix is to, at each step, check to see if there's a reverse+match, and if so, abort the search.  This prevents hugs from+prematurely choosing a generic instance when a more specific one+exists.++--Jeff++BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in+this test.  Suppose the instance envt had+    ..., forall a b. C a a b, ..., forall a b c. C a b c, ...+(still most specific first)+Now suppose we are looking for (C x y Int), where x and y are unconstrained.+        C x y Int  doesn't match the template {a,b} C a a b+but neither does+        C a a b  match the template {x,y} C x y Int+But still x and y might subsequently be unified so they *do* match.++Simple story: unify, don't match.++Note [Coherence and specialisation: overview]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's specialiser relies on the Coherence Assumption: that if+      d1 :: C tys+      d2 :: C tys+then the dictionary d1 can be used in place of d2 and vice versa; it is as if+(C tys) is a singleton type.  If d1 and d2 are interchangeable, we say that+they constitute /canonical evidence/ for (C tys).  We have a special data type,+`CanonoicalEvidence`, for recording whether evidence is canonical.++Let's use this example+  class C a where { op :: a -> Int }+  instance                     C [a]         where {...}   -- (I1)+  instance {-# OVERLAPPING #-} C [Int]       where {...}   -- (I2)++  instance C a =>              C (Maybe a)   where {...}   -- (I3)+  instance {-# INCOHERENT #-}  C (Maybe Int) where {...}   -- (I4)+  instance                     C Int         where {...}   -- (I5)++* When solving (C tys) from the top-level instances, we generally insist that+  there is a unique, most-specific match.  (Incoherent instances change the+  picture a bit: see Note [Rules for instance lookup].) Example:+     [W] C [Int]    -- Pick (I2)+     [W] C [Char]   -- Pick (I1); does not match (I2)++  Caveat: if different usage sites see different instances (which the+  programmer can contrive, with some effort), all bets are off; we really+  can't make any guarantees at all.++* But what about [W] C [b]? This might arise from+     risky :: b -> Int+     risky x = op [x]+  We can't pick (I2) because `b` is not Int. But if we pick (I1), and later+  the simplifier inlines a call (risky @Int) we'll get a dictionary of type+  (C [Int]) built by (I1), which might be utterly different to the dictionary+  of type (C [Int]) built by (I2).  That breaks the Coherence Assumption.++  So GHC declines to pick either, and rejects `risky`. You have to write a+  different signature+     notRisky :: C [b] => b -> Int+     notRisky x = op [x]+  so that the dictionary is resolved at the call site.++* The INCOHERENT pragma tells GHC to choose an instance anyway: see+  Note [Rules for instance lookup] step (IL6).  Suppose we have+     veryRisky :: C b => b -> Int+     veryRisky x = op (Just x)+   So we have [W] C (Maybe b).  Because (I4) is INCOHERENT, GHC is allowed to+   pick (I3).  Of course, this risks breaking the Coherence Assumption, as+   described above.++* What about the incoherence from step (IL4)? For example+     class D a b where { opD :: a -> b -> String }+     instance {-# INCOHERENT #-} D Int b where {...}  -- (I7)+     instance {-# INCOHERENT #-} D a Int where {...}  -- (I8)++     g (x::Int) = opD x x  -- [W] D Int Int++  Here both (I7) and (I8) match, GHC picks an arbitrary one.++So INCOHERENT may break the Coherence Assumption. But sometimes that+is fine, because the programmer promises that it doesn't matter which+one is chosen.  A good example is in the `optics` library:++  data IxEq i is js where { IxEq :: IxEq i is is }++  class AppendIndices xs ys ks | xs ys -> ks where+    appendIndices :: IxEq i (Curry xs (Curry ys i)) (Curry ks i)++  instance {-# INCOHERENT #-} xs ~ zs => AppendIndices xs '[] zs where+    appendIndices = IxEq++  instance ys ~ zs => AppendIndices '[] ys zs where+    appendIndices = IxEq++Here `xs` and `ys` are type-level lists, and for type inference purposes we want to+solve the `AppendIndices` constraint when /either/ of them are the empty list. The+dictionaries are the same in both cases (indeed the dictionary type is a singleton!),+so we really don't care which is used.  See #23287 for discussion.+++In short, sometimes we want to specialise on these incoherently-selected dictionaries,+and sometimes we don't.  It would be best to have a per-instance pragma, but for now+we have a global flag:++* If an instance has an `{-# INCOHERENT #-}` pragma, we the  `OverlapFlag` of the+  `ClsInst` to label it as either+    * `Incoherent`: meaning incoherent but still specialisable, or+    * `NonCanonical`: meaning incoherent and not specialisable.+  The module-wide `-fspecialise-incoherents` flag (on by default) determines+  which choice is made.++  See GHC.Tc.Utils.Instantiate.getOverlapFlag.++The rest of this note describes what happens for `NonCanonical`+instances, i.e. with `-fno-specialise-incoherents`.++To avoid this incoherence breaking the specialiser,++* We label as "non-canonical" any dictionary constructed by a (potentially)+  incoherent use of an ClsInst.++* We do not specialise a function if there is a non-canonical+  dictionary in the /transistive dependencies/ of its dictionary+  arguments.++To see the transitive closure issue, consider+  deeplyRisky :: C b => b -> Int+  deeplyRisky x = op (Just (Just x))++From (op (Just (Just x))) we get+  [W] d1 : C (Maybe (Maybe b))+which we solve (coherently!) via (I3), giving+  [W] d2 : C (Maybe b)+Now we can only solve this incoherently. So we end up with++  deeplyRisky @b (d1 :: C b)+    = op @(Maybe (Maybe b)) d1+    where+      d1 :: C (Maybe (Maybe b)) = $dfI3 d2   -- Coherent decision+      d2 :: C (Maybe b)         = $sfI3 d1   -- Incoherent decision++So `d2` is incoherent, and hence (transitively) so is `d1`.++Here are the moving parts:++* GHC.Core.InstEnv.lookupInstEnv tells if any incoherent unifiers were discarded+  in step (IL4) or (IL6) of the instance lookup: see+  Note [Recording coherence information in `PotentialUnifiers`] and+  Note [Canonicity for incoherent matches].++* That info is recorded in the `cir_is_coherent` field of `OneInst`, and thence+  transferred to the `ep_is_coherent` field of the `EvBind` for the dictionary.++* In the desugarer we exploit this info:+  see Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr.+  See also Note [nospecId magic] in GHC.Types.Id.Make.+++Note [Canonicity for incoherent matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the selected instance is INCOHERENT at step (IL4) of+Note [Rules for instance lookup], we ignore all unifiers,+whether or not they are marked with INCOHERENT pragmas.+This is implemented by returning NoUnifiers in final_unifs.+NoUnifiers takes an argument indicating whether the match was canonical+as described in Note [Coherence and specialisation: overview] and+Note [Recording coherence information in `PotentialUnifiers`].++To determine whether an incoherent match was canonical, we look *only*+at the OverlapFlag of the instance being matched. For example:++  class C a+  instance {-# INCOHERENT #-} C a -- (1)+  instance C Int   -- (2)++  [W] C tau++Here we match instance (1) and discard instance (2). If (1) is Incoherent+(under -fspecialise-incoherents), it is important that we treat the match+as EvCanonical so that we do not block specialisation (see #25883).++What about the following situation:++  instance {-# INCOHERENT #-} C a    -- (1), in a module with -fspecialise-incoherents (Incoherent)+  instance {-# INCOHERENT #-} C Int  -- (2), in a module with -fno-specialise-incoherents (NonCanonical)++  [W] C tau++Again we match instance (1) and discard instance (2). It is not obvious+whether Incoherent or NonCanonical should "win" here, but it seems more+consistent with the previous example to look only at the flag on instance (1).++What about if the only instance that can match is marked as NonCanonical?+In this case are no unifiers at all, so all_unifs = NoUnifiers EvCanonical.+It is not obvious what -fno-specialise-incoherents should do here, but+currently it returns NoUnifiers EvCanonical.++-}++type DFunInstType = Maybe Type+        -- Just ty   => Instantiate with this type+        -- Nothing   => Instantiate with any type of this tyvar's kind+        -- See Note [DFunInstType: instantiating types]++type InstMatch = (ClsInst, [DFunInstType])++type ClsInstLookupResult+     = ( [InstMatch]     -- Successful matches+       , PotentialUnifiers  -- These don't match but do unify+       , [InstMatch] )   -- Unsafe overlapped instances under Safe Haskell+                         -- (see Note [Safe Haskell Overlapping Instances] in+                         -- GHC.Tc.Solver).++{-+Note [DFunInstType: instantiating types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A successful match is a ClsInst, together with the types at which+        the dfun_id in the ClsInst should be instantiated+The instantiating types are (Either TyVar Type)s because the dfun+might have some tyvars that *only* appear in arguments+        dfun :: forall a b. C a b, Ord b => D [a]+When we match this against D [ty], we return the instantiating types+        [Just ty, Nothing]+where the 'Nothing' indicates that 'b' can be freely instantiated.+(The caller instantiates it to a flexi type variable, which will+ presumably later become fixed via functional dependencies.)++Note [Infinitary substitution in lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  class C a b+  instance C c c+  instance C d (Maybe d)+  [W] C e (Maybe e)++You would think we could just use the second instance, because the first doesn't+unify. But that's just ever so slightly wrong. The reason we check for unifiers+along with matchers is that we don't want the possibility that a type variable+instantiation could cause an instance choice to change. Yet if we have+  type family M = Maybe M+and choose (e |-> M), then both instances match. This is absurd, but we cannot+rule it out. Yet, worrying about this case is awfully inconvenient to users,+and so we pretend the problem doesn't exist, by considering a lookup that runs into+this occurs-check issue to indicate that an instance surely does not apply (i.e.+is like the SurelyApart case). In the brief time that we didn't treat infinitary+substitutions specially, two tickets were filed: #19044 and #19052, both trying+to do Real Work.++Why don't we just exclude any instances that are MaybeApart? Because we might+have a [W] C e (F e), where F is a type family. The second instance above does+not match, but it should be included as a future possibility. Unification will+return MaybeApart MARTypeFamily in this case.++What can go wrong with this design choice? We might get incoherence -- but not+loss of type safety. In particular, if we have [W] C M M (for the M type family+above), then GHC might arbitrarily choose either instance, depending on how+M reduces (or doesn't).++For type families, we can't just ignore the problem (as we essentially do here),+because doing so would give us a hole in the type safety proof (as explored in+Section 6 of "Closed Type Families with Overlapping Equations", POPL'14). This+possibility of an infinitary substitution manifests as closed type families that+look like they should reduce, but don't. Users complain: #9082 and #17311. For+open type families, we actually can have unsoundness if we don't take infinitary+substitutions into account: #8162. But, luckily, for class instances, we just+risk coherence -- not great, but it seems better to give users what they likely+want. (Also, note that this problem existed for the entire decade of 201x without+anyone noticing, so it's manifestly not ruining anyone's day.)+-}++-- |Look up an instance in the given instance environment. The given class application must match exactly+-- one instance and the match may not contain any flexi type variables.  If the lookup is unsuccessful,+-- yield 'Left errorMessage'.+lookupUniqueInstEnv :: InstEnvs+                    -> Class -> [Type]+                    -> Either LookupInstanceErrReason (ClsInst, [Type])+lookupUniqueInstEnv instEnv cls tys+  = case lookupInstEnv False instEnv cls tys of+      ([(inst, inst_tys)], _, _)+             | noFlexiVar -> Right (inst, inst_tys')+             | otherwise  -> Left $ LookupInstErrFlexiVar+             where+               inst_tys'  = [ty | Just ty <- inst_tys]+               noFlexiVar = all isJust inst_tys+      _other -> Left $ LookupInstErrNotFound++-- | Why a particular typeclass application couldn't be looked up.+data LookupInstanceErrReason =+  -- | Tyvars aren't an exact match.+  LookupInstErrNotExact+  |+  -- | One of the tyvars is flexible.+  LookupInstErrFlexiVar+  |+  -- | No matching instance was found.+  LookupInstErrNotFound+  deriving (Generic)++-- | `CanonicalEvidence` says whether a piece of evidence has a singleton type;+-- For example, given (d1 :: C Int), will any other (d2 :: C Int) do equally well?+-- See Note [Coherence and specialisation: overview] above, and+-- Note [Desugaring non-canonical evidence] in GHC.HsToCore.Binds+data CanonicalEvidence+  = EvCanonical+  | EvNonCanonical++andCanEv :: CanonicalEvidence -> CanonicalEvidence -> CanonicalEvidence+-- Only canonical if both are+andCanEv EvCanonical EvCanonical = EvCanonical+andCanEv _           _           = EvNonCanonical++-- See Note [Recording coherence information in `PotentialUnifiers`]+data PotentialUnifiers+  = NoUnifiers CanonicalEvidence+       -- Either there were no unifiers, or all were incoherent+       --+       -- NoUnifiers EvNonCanonical:+       --    We discarded (via INCOHERENT) some instances that unify,+       --    and that are marked NonCanonical; so the matching instance+       --    should be traeated as EvNonCanonical+       -- NoUnifiers EvCanonical:+       --    We discarded no NonCanonical incoherent unifying instances,+       --    so the matching instance can be treated as EvCanonical++  | OneOrMoreUnifiers (NonEmpty ClsInst)+       -- There are some /coherent/ unifiers; here they are+       --+       -- This list is lazy as we only look at all the unifiers when+       -- printing an error message. It can be expensive to compute all+       -- the unifiers because if you are matching something like C a[sk] then+       -- all instances will unify.++{- Note [Recording coherence information in `PotentialUnifiers`]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find a matching instance, there might be other instances that+could potentially unify with the goal. For `INCOHERENT` instances, we+don't care (see step (IL6) in Note [Rules for instance lookup]).+But if we have potentially unifying coherent instance, we+report these `OneOrMoreUnifiers` so that `matchInstEnv` can go down+the `NotSure` route.++If this hurdle is passed, i.e. we have a unique solution up to+`INCOHERENT` instances, the specialiser needs to know if that unique+solution is canonical or not (see Note [Coherence and specialisation:+overview] for why we care at all). So when the set of potential+unifiers is empty, we record in `NoUnifiers` if the one solution is+`Canonical`.++For example, suppose we have:++  class C x y+  instance C a Bool                   -- (1)+  instance {-# INCOHERENT #-} C Int a -- (2)++  [W] C x Bool++Here instance (1) matches the Wanted, and since instance (2) is INCOHERENT+we want to succeed with the match rather than getting stick at step (IL6).+But if -fno-specialise-incoherents was enabled for (2), the specialiser is+not permitted to specialise this dictionary later, so lookupInstEnv reports+the PotentialUnifiers as NoUnifiers EvNonCanonical.++-}++instance Outputable CanonicalEvidence where+  ppr EvCanonical    = text "canonical"+  ppr EvNonCanonical = text "non-canonical"++instance Outputable PotentialUnifiers where+  ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c+  ppr xs = ppr (getCoherentUnifiers xs)++instance Semigroup PotentialUnifiers where+  NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2)+  NoUnifiers _ <> u = u+  OneOrMoreUnifiers (unifier :| unifiers) <> u+    = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u))++getCoherentUnifiers :: PotentialUnifiers -> [ClsInst]+getCoherentUnifiers NoUnifiers{} = []+getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls++-- | Are there no *coherent* unifiers?+nullUnifiers :: PotentialUnifiers -> Bool+nullUnifiers NoUnifiers{} = True+nullUnifiers _ = False++-- | Are there any unifiers, ignoring those marked Incoherent (but including any+-- marked NonCanonical)?+someUnifiers :: PotentialUnifiers -> Bool+someUnifiers (NoUnifiers EvCanonical) = False+someUnifiers _ = True+++instEnvMatchesAndUnifiers+  :: InstEnv          -- InstEnv to look in+  -> VisibleOrphanModules   -- But filter against this+  -> Class -> [Type]  -- What we are looking for+  -> ([InstMatch],    -- Successful matches+      PotentialUnifiers)      -- These don't match but do unify+                                   -- (no incoherent ones in here)+-- The second component of the result pair happens when we look up+--      Foo [a]+-- in an InstEnv that has entries for+--      Foo [Int]+--      Foo [b]+-- Then which we choose would depend on the way in which 'a'+-- is instantiated.  So we report that Foo [b] is a match (mapping b->a)+-- but Foo [Int] is a unifier.  This gives the caller a better chance of+-- giving a suitable error message++instEnvMatchesAndUnifiers (InstEnv rm) vis_mods cls tys+  = (foldr check_match [] rough_matches, check_unifiers rough_unifiers)+  where+    (rough_matches, rough_unifiers) = lookupRM' rough_tcs rm+    rough_tcs  = RML_KnownTc (className cls) : roughMatchTcsLookup tys++    --------------+    check_match :: ClsInst -> [InstMatch] -> [InstMatch]+    check_match item@(ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }) acc+      | not (instIsVisible vis_mods item)+      = acc  -- See Note [Instance lookup and orphan instances]++      | Just subst <- tcMatchTys tpl_tys tys+      = ((item, map (lookupTyVar subst) tpl_tvs) : acc)++      | otherwise+      = acc++    check_unifiers :: [ClsInst] -> PotentialUnifiers+    check_unifiers [] = NoUnifiers EvCanonical+    check_unifiers (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items)++      | not (instIsVisible vis_mods item)+      = check_unifiers items  -- See Note [Instance lookup and orphan instances]++      -- If it matches, check_match has gotten it, so skip over it here+      | Just {} <- tcMatchTys tpl_tys tys+      = check_unifiers items++      -- Does not match, so next check whether the things unify+      -- See Note [Overlapping instances]+      | otherwise+      = assertPpr (tys_tv_set `disjointVarSet` tpl_tv_set)+                  ((ppr cls <+> ppr tys) $$+                   (ppr tpl_tvs <+> ppr tpl_tys)) $+                -- Unification will break badly if the variables overlap+                -- They shouldn't because we allocate separate uniques for them+                -- See Note [Template tyvars are fresh]+        case tcUnifyTysFG alwaysBindFam instanceBindFun tpl_tys tys of+          -- alwaysBindFam: the family-application can't be in the instance head,+          -- but it certainly can be in the Wanted constraint we are matching!+          --+          -- We consider MaybeApart to be a case where the instance might+          -- apply in the future. This covers an instance like C Int and+          -- a target like [W] C (F a), where F is a type family.+          -- See (ATF1) in Note [Apartness and type families] in GHC.Core.Unify+            SurelyApart              -> check_unifiers items+              -- See Note [Infinitary substitution in lookup]+            MaybeApart MARInfinite _ -> check_unifiers items+            _                        -> add_unifier item (check_unifiers items)++      where+        tpl_tv_set = mkVarSet tpl_tvs+        tys_tv_set = tyCoVarsOfTypes tys++    add_unifier :: ClsInst -> PotentialUnifiers -> PotentialUnifiers+        -- Record that we encountered non-canonical instances:+        -- Note [Coherence and specialisation: overview]+    add_unifier item other_unifiers+      | not (isIncoherent item)+      = OneOrMoreUnifiers (item :| getCoherentUnifiers other_unifiers)++      -- So `item` is incoherent; see Note [Incoherent instances]+      | otherwise+      = case other_unifiers of+          OneOrMoreUnifiers{}                -> other_unifiers+          NoUnifiers{} | isNonCanonical item -> NoUnifiers EvNonCanonical+                       | otherwise           -> other_unifiers+++---------------+-- This is the common way to call this function.+lookupInstEnv :: Bool              -- Check Safe Haskell overlap restrictions+              -> InstEnvs          -- External and home package inst-env+              -> Class -> [Type]   -- What we are looking for+              -> ClsInstLookupResult+-- ^ See Note [Rules for instance lookup]+-- ^ See Note [Safe Haskell Overlapping Instances] in "GHC.Tc.Solver"+-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in "GHC.Tc.Solver"+lookupInstEnv check_overlap_safe+              (InstEnvs { ie_global = pkg_ie+                        , ie_local = home_ie+                        , ie_visible = vis_mods })+              cls+              tys+  = (final_matches, final_unifs, unsafe_overlapped)+  where+    -- (IL1): Find all instances that match the target constraint+    (home_matches, home_unifs) = instEnvMatchesAndUnifiers home_ie vis_mods cls tys+    (pkg_matches,  pkg_unifs)  = instEnvMatchesAndUnifiers pkg_ie  vis_mods cls tys+    all_matches = home_matches <> pkg_matches+    all_unifs   = home_unifs <> pkg_unifs++    -- (IL3): Eliminate candidates that are overlapped or incoherent+    final_matches = pruneOverlappedMatches all_matches+        -- Even if the unifs is non-empty (an error situation)+        -- we still prune the matches, so that the error message isn't+        -- misleading (complaining of multiple matches when some should be+        -- overlapped away)++    unsafe_overlapped+       = case final_matches of+           [match] -> check_safe match+           _       -> []++    -- If the selected match is incoherent, discard all unifiers+    -- See (IL4) of Note [Rules for instance lookup]+    final_unifs = case final_matches of+                    (m:ms) | isIncoherent (fst m)+                           -- Incoherent match, so discard all unifiers, but+                           -- keep track of dropping coherent or non-canonical ones+                           -- if the match is non-canonical.+                           -- See Note [Canonicity for incoherent matches]+                           -> assertPpr (null ms) (ppr final_matches) $+                              NoUnifiers $+                                 if isNonCanonical (fst m) && someUnifiers all_unifs+                                    then EvNonCanonical+                                    else EvCanonical+                    _      -> all_unifs++    -- Note [Safe Haskell isSafeOverlap]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- We restrict code compiled in 'Safe' mode from overriding code+    -- compiled in any other mode. The rationale is that code compiled+    -- in 'Safe' mode is code that is untrusted by the ghc user. So+    -- we shouldn't let that code change the behaviour of code the+    -- user didn't compile in 'Safe' mode since that's the code they+    -- trust. So 'Safe' instances can only overlap instances from the+    -- same module. A same instance origin policy for safe compiled+    -- instances.+    check_safe (inst,_)+        = case check_overlap_safe && unsafeTopInstance inst of+                -- make sure it only overlaps instances from the same module+                True -> go [] all_matches+                -- most specific is from a trusted location.+                False -> []+        where+            go bad [] = bad+            go bad (i@(x,_):unchecked) =+                if inSameMod x || isOverlappable x+                    then go bad unchecked+                    else go (i:bad) unchecked++            inSameMod b =+                let na = getName $ getName inst+                    la = isInternalName na+                    nb = getName $ getName b+                    lb = isInternalName nb+                in (la && lb) || (nameModule na == nameModule nb)++    -- We consider the most specific instance unsafe when it both:+    --   (1) Comes from a module compiled as `Safe`+    --   (2) Is an orphan instance, OR, an instance for a MPTC+    unsafeTopInstance inst = isSafeOverlap (is_flag inst) &&+        (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1)++---------------+++{- Note [Instance overlap and guards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The first step is to find all instances that /match/ the constraint+we are trying to solve.  Next, using pruneOverlapped Matches, we eliminate+from that list of instances any instances that are overlapped.  For example:++(A)   instance                      C [a] where ...+(B)   instance {-# OVERLAPPING #-} C [[a] where ...+(C)   instance C (Maybe a) where++Suppose we are trying to solve C [[Bool]]. The lookup will return a list [A,B]+of the first two instances, since both match.  (The Maybe instance doesn't match,+so the lookup won't return (C).)  Then pruneOverlappedMatches removes (A),+since (B) is more specific.  So we end up with just one match, (B).++However pruneOverlappedMatches is a bit more subtle than you might think (#20946).+Recall how we go about eliminating redundant instances, as described in+Note [Rules for instance lookup].++  - When instance I1 is more specific than instance I2,+  - and either I1 is overlapping or I2 is overlappable,++then we can discard I2 in favour of I1. Note however that, as part of the instance+resolution process, we don't want to immediately discard I2, as it can still be useful.+For example, suppose we are trying to solve C [[Int]], and have instances:++  I1: instance                  C [[Int]]+  I2: instance {-# OVERLAPS #-} C [[a]]++Both instances match. I2 is both overlappable and overlapping (that's what `OVERLAPS`+means). Now I1 is more specific than I2, and I2 is overlappable, so we can discard I2.+However, we should still keep I2 around when looking up instances, because it is+overlapping and `I1` isn't: this means it can be used to eliminate other instances+that I1 can't, such as:++  I3: instance C [a]++I3 is more general than both I1 and I2, but it is not overlappable, and I1+is not overlapping. This means that we must use I2 to discard I3.++To do this, in 'insert_overlapping', on top of keeping track of matching+instances, we also keep track of /guards/, which are instances like I2+which we will discard in the end (because we have a more specific match+that overrides it) but might still be useful for eliminating other instances+(like I3 in this example).+++(A) Definition of guarding instances (guards).++    To add a matching instance G as a guard, it must satisfy the following conditions:++      A1. G is overlapped by a more specific match, M,+      A2. M is not overlapping,+      A3. G is overlapping.++    This means that we eliminate G from the set of matches (it is overridden by M),+    but we keep it around until we are done with instance resolution because+    it might still be useful to eliminate other matches.++(B) Guards eliminate matches.++    There are two situations in which guards can eliminate a match:++      B1. We want to add a new instance, but it is overridden by a guard.+          We can immediately discard the instance.++          Example for B1:++            Suppose we want to solve C [[Int]], with instances:++              J1: instance                  C [[Int]]+              J2: instance {-# OVERLAPS #-} C [[a]]+              J3: instance                  C [a]++          Processing them in order: we add J1 as a match, then J2 as a guard.+          Now, when we come across J3, we can immediately discard it because+          it is overridden by the guard J2.++      B2. We have found a new guard. We must use it to discard matches+          we have already found. This is necessary because we must obtain+          the same result whether we process the instance or the guard first.++          Example for B2:++            Suppose we want to solve C [[Int]], with instances:++              K1: instance                  C [[Int]]+              K2: instance                  C [a]+              K3: instance {-# OVERLAPS #-} C [[a]]++            We start by considering K1 and K2. Neither has any overlapping flag set,+            so we end up with two matches, {K1, K2}.+            Next we look at K3: it is overridden by K1, but as K1 is not+            overlapping this means K3 should function as a guard.+            We must then ensure we eliminate K2 from the list of matches,+            as K3 guards against it.++(C) Adding guards.++    When we already have collected some guards, and have come across a new+    guard, we can simply add it to the existing list of guards.+    We don't need to keep the set of guards minimal, as they will simply+    be thrown away at the end: we are only interested in the matches.+    Not having a minimal set of guards does not harm us, but it makes+    the code simpler.+-}++-- | Collect class instance matches, including matches that we know+-- are overridden but might still be useful to override other instances+-- (which we call "guards").+--+-- See Note [Instance overlap and guards].+data InstMatches+  = InstMatches+  { -- | Minimal matches: we have knocked out all strictly more general+    -- matches that are overlapped by a match in this list.+    instMatches :: [InstMatch]++    -- | Guards: matches that we know we won't pick in the end,+    -- but might still be useful for ruling out other instances,+    -- as per #20946. See Note [Instance overlap and guards], (A).+  , instGuards  :: [ClsInst]+  }++instance Outputable InstMatches where+  ppr (InstMatches { instMatches = matches, instGuards = guards })+    = text "InstMatches" <+>+      braces (vcat [ text "instMatches:" <+> ppr matches+                   , text "instGuards:" <+> ppr guards ])++noMatches :: InstMatches+noMatches = InstMatches { instMatches = [], instGuards = [] }++pruneOverlappedMatches :: [InstMatch] -> [InstMatch]+-- ^ Remove from the argument list any InstMatches for which another+-- element of the list is more specific, and overlaps it, using the+-- rules of Note [Rules for instance lookup], esp (IL3)+--+-- Incoherent instances are discarded, unless all are incoherent,+-- in which case exactly one is kept.+pruneOverlappedMatches all_matches =+  instMatches $ foldr insert_overlapping noMatches all_matches++-- | Computes whether the first class instance overrides the second,+-- i.e. the first is more specific and can overlap the second.+--+-- More precisely, @instA `overrides` instB@ returns 'True' precisely when:+--+--   - @instA@ is more specific than @instB@,+--   - @instB@ is not more specific than @instA@,+--   - @instA@ is overlapping OR @instB@ is overlappable.+overrides :: ClsInst -> ClsInst -> Bool+new_inst `overrides` old_inst+  =  (new_inst `more_specific_than` old_inst)+  && (not $ old_inst `more_specific_than` new_inst)+  && (isOverlapping new_inst || isOverlappable old_inst)+       -- Overlap permitted if either the more specific instance+       -- is marked as overlapping, or the more general one is+       -- marked as overlappable.+       -- Latest change described in: #9242.+       -- Previous change: #3877, Dec 10.+  where+    -- `instB` can be instantiated to match `instA`+    -- or the two are equal+    instA `more_specific_than` instB+      = isJust (tcMatchTys (is_tys instB) (is_tys instA))++insert_overlapping :: InstMatch -> InstMatches -> InstMatches+-- ^ Add a new solution, knocking out strictly less specific ones+-- See Note [Rules for instance lookup] and Note [Instance overlap and guards].+--+-- /Property/: the order of insertion doesn't matter, i.e.+-- @insert_overlapping inst1 (insert_overlapping inst2 matches)@+-- gives the same result as @insert_overlapping inst2 (insert_overlapping inst1 matches)@.+insert_overlapping+  new_item@(new_inst,_)+  old@(InstMatches { instMatches = old_items, instGuards = guards })+  -- If any of the "guarding" instances override this item, discard it.+  -- See Note [Instance overlap and guards], (B1).+  | any (`overrides` new_inst) guards+  = old+  | otherwise+  = insert_overlapping_new_item old_items++  where+    insert_overlapping_new_item :: [InstMatch] -> InstMatches+    insert_overlapping_new_item []+      = InstMatches { instMatches = [new_item], instGuards = guards }+    insert_overlapping_new_item all_old_items@(old_item@(old_inst,_) : old_items)++      -- New strictly overrides old: throw out the old from the list of matches,+      -- but potentially keep it around as a guard if it can still be used+      -- to eliminate other instances.+      | new_inst `overrides` old_inst+      , InstMatches { instMatches = final_matches+                    , instGuards  = prev_guards }+                    <- insert_overlapping_new_item old_items+      = if isOverlapping new_inst || not (isOverlapping old_inst)+        -- We're adding "new_inst" as a match.+        -- If "new_inst" is not overlapping but "old_inst" is, we should+        -- keep "old_inst" around as a guard.+        -- See Note [Instance overlap and guards], (A).+        then InstMatches { instMatches = final_matches+                         , instGuards  = prev_guards }+        else InstMatches { instMatches = final_matches+                         , instGuards  = old_inst : prev_guards }+        --                               ^^^^^^^^^^^^^^^^^^^^^^+        --                    See Note [Instance overlap and guards], (C).+++      -- Old strictly overrides new: throw it out from the list of matches,+      -- but potentially keep it around as a guard if it can still be used+      -- to eliminate other instances.+      | old_inst `overrides` new_inst+      = if isOverlapping old_inst || not (isOverlapping new_inst)+        -- We're discarding "new_inst", as it is overridden by "old_inst".+        -- However, it might still be useful as a guard if "old_inst" is not overlapping+        -- but "new_inst" is.+        -- See Note [Instance overlap and guards], (A).+        then InstMatches { instMatches = all_old_items+                         , instGuards  = guards }+        else InstMatches+                  -- We're adding "new_inst" as a guard, so we must prune out+                  -- any matches it overrides.+                  -- See Note [Instance overlap and guards], (B2)+                { instMatches =+                    filter+                      (\(old_inst,_) -> not (new_inst `overrides` old_inst))+                      all_old_items++                -- See Note [Instance overlap and guards], (C)+                , instGuards = new_inst : guards }++      -- Discard incoherent instances; see Note [Incoherent instances]+      | isIncoherent old_inst -- Old is incoherent; discard it+      = insert_overlapping_new_item old_items+      | isIncoherent new_inst -- New is incoherent; discard it+      = InstMatches { instMatches = all_old_items+                    , instGuards  = guards }++      -- Equal or incomparable, and neither is incoherent; keep both+      | otherwise+      , InstMatches { instMatches = final_matches+                    , instGuards  = final_guards }+                    <- insert_overlapping_new_item old_items+      = InstMatches { instMatches = old_item : final_matches+                    , instGuards  = final_guards }++{-+Note [Incoherent instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some classes, the choice of a particular instance does not matter, any one+is good. E.g. consider++        class D a b where { opD :: a -> b -> String }+        instance D Int b where ...+        instance D a Int where ...++        g (x::Int) = opD x x  -- Wanted: D Int Int++For such classes this should work (without having to add an "instance D Int+Int", and using -XOverlappingInstances, which would then work). This is what+-XIncoherentInstances is for: Telling GHC "I don't care which instance you use;+if you can use one, use it."++Should this logic only work when *all* candidates have the incoherent flag, or+even when all but one have it? The right choice is the latter, which can be+justified by comparing the behaviour with how -XIncoherentInstances worked when+it was only about the unify-check (Note [Overlapping instances]):++Example:+        class C a b c where foo :: (a,b,c)+        instance C [a] b Int+        instance {-# INCOHERENT #-} C [Int] b c+        instance {-# INCOHERENT #-} C a Int c+Thanks to the incoherent flags,+        [Wanted]  C [a] b Int+works: Only instance one matches, the others just unify, but are marked+incoherent.++So I can write+        (foo :: ([a],b,Int)) :: ([Int], Int, Int).+but if that works then I really want to be able to write+        foo :: ([Int], Int, Int)+as well. Now all three instances from above match. None is more specific than+another, so none is ruled out by the normal overlapping rules. One of them is+not incoherent, but we still want this to compile. Hence the+"all-but-one-logic".++The implementation is in insert_overlapping, where we remove matching+incoherent instances as long as there are others.++If the choice of instance *does* matter, all bets are still not off:+users can consult the detailed specification of the instance selection+algorithm in the GHC Users' Manual. However, this means we can end up+with different instances at the same types at different parts of the+program, and this difference has to be preserved. Note [Coherence and+specialisation: overview] details how we achieve that.++************************************************************************+*                                                                      *+        Binding decisions+*                                                                      *+************************************************************************+-}++instanceBindFun :: BindTvFun+instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = DontBindMe+                           | otherwise              = BindMe+   -- Note [Super skolems: binding when looking up instances]++{-+Note [Super skolems: binding when looking up instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When looking up in the instance environment, or family-instance environment,+we are careful about multiple matches, as described above in+Note [Overlapping instances]++The target tys can contain skolem constants. For existentials and instance variables,+we can guarantee that those+are never going to be instantiated to anything, so we should not involve+them in the unification test. These are called "super skolems". Example:+        class Foo a where { op :: a -> Int }+        instance Foo a => Foo [a]       -- NB overlap+        instance Foo [Int]              -- NB overlap+        data T = forall a. Foo a => MkT a+        f :: T -> Int+        f (MkT x) = op [x,x]+The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and+so it is a "super skolem". (See the use of tcInstSuperSkolTyVarsX in+GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to+isOverlappableTyVar, and the use of DontBindMe in instanceBindFun, above, means+that these will be treated as fresh constants in the unification algorithm+during instance lookup. Without this treatment, GHC would complain, saying+that the choice of instance depended on the instantiation of 'a'; but of+course it isn't *going* to be instantiated. Note that it is necessary that+the unification algorithm returns SurelyApart for these super-skolems+for GHC to be able to commit to another instance.++We do this only for super skolems.  For example we reject+        g :: forall a => [a] -> Int+        g x = op x+on the grounds that the correct instance depends on the instantiation of 'a'+-}
+ GHC/Core/LateCC.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE RecordWildCards #-}++-- | Adds cost-centers after the core pipline has run.+module GHC.Core.LateCC+    ( -- * Inserting cost centres+      addLateCostCenters+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.LateCC.OverloadedCalls+import GHC.Core.LateCC.TopLevelBinds+import GHC.Core.LateCC.Types+import GHC.Core.LateCC.Utils+import GHC.Core.Seq+import qualified GHC.Data.Strict as Strict+import GHC.Core.Utils+import GHC.Tc.Utils.TcType+import GHC.Types.SrcLoc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Types.RepType (mightBeFunTy)++-- | Late cost center insertion logic used by the driver+addLateCostCenters ::+     Logger+  -- ^ Logger+  -> LateCCConfig+  -- ^ Late cost center configuration+  -> CoreProgram+  -- ^ The program+  -> IO (CoreProgram, LateCCState (Strict.Maybe SrcSpan))+addLateCostCenters logger LateCCConfig{..} core_binds = do++    -- If top-level late CCs are enabled via either -fprof-late or+    -- -fprof-late-overloaded, add them+    (top_level_cc_binds, top_level_late_cc_state) <-+      case lateCCConfig_whichBinds of+        LateCCNone ->+          return (core_binds, initLateCCState ())+        _ ->+          withTiming+            logger+            (text "LateTopLevelCCs" <+> brackets (ppr this_mod))+            (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ())+            $ {-# SCC lateTopLevelCCs #-} do+              pure $+                doLateCostCenters+                  lateCCConfig_env+                  (initLateCCState ())+                  (topLevelBindsCC top_level_cc_pred)+                  core_binds++    -- If overloaded call CCs are enabled via -fprof-late-overloaded-calls, add+    -- them+    (late_cc_binds, late_cc_state) <-+      if lateCCConfig_overloadedCalls then+        withTiming+            logger+            (text "LateOverloadedCallsCCs" <+> brackets (ppr this_mod))+            (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ())+            $ {-# SCC lateoverloadedCallsCCs #-} do+              pure $+                doLateCostCenters+                  lateCCConfig_env+                  (top_level_late_cc_state { lateCCState_extra = Strict.Nothing })+                  overloadedCallsCC+                  top_level_cc_binds+      else+        return+          ( top_level_cc_binds+          , top_level_late_cc_state { lateCCState_extra = Strict.Nothing }+          )++    return (late_cc_binds, late_cc_state)+  where+    top_level_cc_pred :: CoreExpr -> Bool+    top_level_cc_pred =+        case lateCCConfig_whichBinds of+          LateCCBinds -> \rhs ->+            -- Make sure we record any functions. Even if it's something like `f = g`.+            mightBeFunTy (exprType rhs) ||+            -- If the RHS is a CAF doing work also insert a CC.+            not (exprIsWorkFree rhs)+          LateCCOverloadedBinds ->+            isOverloadedTy . exprType+          LateCCNone ->+            -- This is here for completeness, we won't actually use this+            -- predicate in this case since we'll shortcut.+            const False++    this_mod = lateCCEnv_module lateCCConfig_env
+ GHC/Core/LateCC/OverloadedCalls.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-}++module GHC.Core.LateCC.OverloadedCalls+  ( overloadedCallsCC+  ) where++import GHC.Prelude++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified GHC.Data.Strict as Strict++import GHC.Data.FastString+import GHC.Core+import GHC.Core.LateCC.Utils+import GHC.Core.LateCC.Types+import GHC.Core.Make+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Utils+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Var++type OverloadedCallsCCState = Strict.Maybe SrcSpan++{- Note [Overloaded Calls and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC considers cost centres as destructive to+join contexts. Or in other words this is not considered valid:++    join f x = ...+    in+              ... -> scc<tick> jmp++This makes the functionality of `-fprof-late-overloaded-calls` not feasible+for join points in general. We used to try to work around this by putting the+ticks on the rhs of the join point rather than around the jump. However beyond+the loss of accuracy this was broken for recursive join points as we ended up+with something like:++    rec-join f x = scc<tick> ... jmp f x++Which similarly is not valid as the tick once again destroys the tail call.+One might think we could limit ourselves to non-recursive tail calls and do+something clever like:++  join f x = scc<tick> ...+  in ... jmp f x++And sometimes this works! But sometimes the full rhs would look something like:++  join g x = ....+  join f x = scc<tick> ... -> jmp g x++Which, would again no longer be valid. I believe in the long run we can make+cost centre ticks non-destructive to join points. Or we could keep track of+where we are/are not allowed to insert a cost centre. But in the short term I will+simply disable the annotation of join calls under this flag.+-}++-- | Insert cost centres on function applications with dictionary arguments. The+-- source locations attached to the cost centres is approximated based on the+-- "closest" source note encountered in the traversal.+overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+overloadedCallsCC =+    processBind+  where+    processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+    processBind core_bind =+        case core_bind of+          NonRec b e ->+            NonRec b <$> wrap_if_join b (processExpr e)+          Rec es ->+            Rec <$> mapM (\(b,e) -> (b,) <$> wrap_if_join b (processExpr e)) es+      where+        -- If an overloaded function is turned into a join point, we won't add+        -- SCCs directly to calls since it makes them non-tail calls. Instead,+        -- we look for join points here and add an SCC to their RHS if they are+        -- overloaded.+        wrap_if_join ::+             CoreBndr+          -> LateCCM OverloadedCallsCCState CoreExpr+          -> LateCCM OverloadedCallsCCState CoreExpr+        wrap_if_join _b pexpr = do+            -- See Note [Overloaded Calls and join points]+            expr <- pexpr+            return expr++    processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr+    processExpr expr =+      case expr of+        -- The case we care about: Application+        app@App{} -> do+          -- Here we have some application like `f v1 ... vN`, where v1 ... vN+          -- should be the function's type arguments followed by the value+          -- arguments. To determine if the `f` is an overloaded function, we+          -- check if any of the arguments v1 ... vN are dictionaries.+          let+            (f, xs) = collectArgs app+            resultTy = applyTypeToArgs (exprType f) xs++          -- Recursively process the arguments first for no particular reason+          args <- mapM processExpr xs+          let app' = mkCoreApps f args++          if+              -- Check if any of the arguments are dictionaries+              any isDictExpr args++              -- Avoid instrumenting dictionary functions, which may be+              -- overloaded if there are superclasses, by checking if the result+              -- type of the function is a dictionary type.+            && not (isDictTy resultTy)++              -- Avoid instrumenting constraint selectors like eq_sel+            && (typeTypeOrConstraint resultTy /= ConstraintLike)++              -- Avoid instrumenting join points.+              -- (See comment in processBind above)+              -- Also see Note [Overloaded Calls and join points]+            && not (isJoinVarExpr f)+          then do+            -- Extract a name and source location from the function being+            -- applied+            let+              cc_name :: FastString+              cc_name =+                maybe (fsLit "<no name available>") getOccFS (exprName app)++            cc_srcspan <-+              fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $+                lift $ gets lateCCState_extra++            insertCC cc_name cc_srcspan app'+          else+            return app'++        -- For recursive constructors of Expr, we traverse the nested Exprs+        Lam b e ->+          mkCoreLams [b] <$> processExpr e+        Let b e ->+          mkCoreLet <$> processBind b <*> processExpr e+        Case e b t alts ->+              Case+          <$> processExpr e+          <*> pure b+          <*> pure t+          <*> mapM processAlt alts+        Cast e co ->+          mkCast <$> processExpr e <*> pure co+        Tick t e -> do+          trackSourceNote t $+            mkTick t <$> processExpr e++        -- For non-recursive constructors of Expr, we do nothing+        x -> return x++    processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt+    processAlt (Alt c bs e) = Alt c bs <$> processExpr e++    trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a+    trackSourceNote tick act =+      case tick of+        SourceNote rss _ -> do+          -- Prefer source notes from the current file+          in_current_file <-+            maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$>+              asks lateCCEnv_file+          if not in_current_file then+            act+          else do+            loc <- lift $ gets lateCCState_extra+            lift . modify $ \s ->+              s { lateCCState_extra =+                    Strict.Just $ RealSrcSpan rss mempty+                }+            x <- act+            lift . modify $ \s ->+              s { lateCCState_extra = loc+                }+            return x+        _ ->+          act++    -- Utility functions++    -- Extract a Name from an expression. If it is an application, attempt to+    -- extract a name from the applied function. If it is a variable, return the+    -- Name of the variable. If it is a tick/cast, attempt to extract a Name+    -- from the expression held in the tick/cast. Otherwise return Nothing.+    exprName :: CoreExpr -> Maybe Name+    exprName =+        \case+          App f _ ->+            exprName f+          Var f ->+            Just (idName f)+          Tick _ e ->+            exprName e+          Cast e _ ->+            exprName e+          _ ->+            Nothing++    -- Determine whether an expression is a dictionary+    isDictExpr :: CoreExpr -> Bool+    isDictExpr =+        maybe False isDictTy . exprType'+      where+        exprType' :: CoreExpr -> Maybe Type+        exprType' = \case+            Type{} -> Nothing+            expr -> Just $ exprType expr++    -- Determine whether an expression is a join variable+    isJoinVarExpr :: CoreExpr -> Bool+    isJoinVarExpr =+        \case+          Var var -> isJoinId var+          Tick _ e -> isJoinVarExpr e+          Cast e _ -> isJoinVarExpr e+          _ -> False
+ GHC/Core/LateCC/TopLevelBinds.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE TupleSections #-}+module GHC.Core.LateCC.TopLevelBinds where++import GHC.Prelude++import GHC.Core.LateCC.Types+import GHC.Core.LateCC.Utils++import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Driver.DynFlags+import GHC.Types.Id+import GHC.Types.Name+import GHC.Unit.Module.ModGuts++import Data.Maybe++{- 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 to top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is very simple. For a 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.++To reduce overhead we ignore workfree bindings because they don't contribute+meaningfully to a performance profile. This reduces code size massively as it+allows us to allocate definitions like `val = Just 32` at compile time instead+of turning them into a CAF of the form `val = <scc val> let x = Just 32 in x` which+would be the alternative.++We make an exception for rhss with function types. This allows us to get+cost centres on eta-reduced definitions like `f = g`. By putting a tick onto+`f`s rhs we end up with++    f = \eta1 eta2 ... etan ->+        <scc f> g eta1 ... etan++Which can make it easier to understand call graphs of an application.++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.++-}++-- | Add late cost centres directly to the 'ModGuts'. This is used inside the+-- core pipeline with the -fprof-late-inline flag. It should not be used after+-- tidy, since it does not manually track inserted cost centers. See+-- Note [Collecting late cost centres].+topLevelBindsCCMG :: ModGuts -> CoreM ModGuts+topLevelBindsCCMG guts = do+    dflags <- getDynFlags+    let+      env =+        LateCCEnv+          { lateCCEnv_module = mg_module guts++            -- We don't use this for topLevelBindsCC, so Nothing is okay+          , lateCCEnv_file = Nothing++          , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags+          , lateCCEnv_collectCCs = False+          }+      guts' =+        guts+          { mg_binds =+              fst+                ( doLateCostCenters+                    env+                    (initLateCCState ())+                    (topLevelBindsCC (const True))+                    (mg_binds guts)+                )+          }+    return guts'++-- | Insert cost centres on top-level bindings in the module, depending on+-- whether or not they satisfy the given predicate.+topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind+topLevelBindsCC pred core_bind =+    case core_bind of+      NonRec b rhs ->+        NonRec b <$> doBndr b rhs+      Rec bs ->+        Rec <$> mapM doPair bs+  where+    doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr))+    doPair (b,rhs) = (b,) <$> doBndr b rhs++    doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr+    doBndr bndr rhs+      -- Not a constructor worker.+      -- 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.+      | isNothing (isDataConId_maybe bndr)+      , pred rhs+      = addCC bndr rhs+      | otherwise = pure rhs++    -- We want to put the cost centre below the lambda as we only care about+    -- executions of the RHS. Note that the lambdas might be hidden under ticks+    -- or casts. So look through these as well.+    addCC :: Id -> CoreExpr -> LateCCM s CoreExpr+    addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co+    addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs+    addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs+    addCC bndr rhs = do+      let name = idName bndr+          cc_loc = nameSrcSpan name+          cc_name = getOccFS name+      insertCC cc_name cc_loc rhs
+ GHC/Core/LateCC/Types.hs view
@@ -0,0 +1,74 @@+-- | Types related to late cost center insertion+module GHC.Core.LateCC.Types+  ( LateCCConfig(..)+  , LateCCBindSpec(..)+  , LateCCEnv(..)+  , LateCCState(..)+  , initLateCCState+  , LateCCM+  ) where++import GHC.Prelude++import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Data.Set as S++import GHC.Data.FastString+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Unit.Types++-- | Late cost center insertion configuration.+--+-- Specifies whether cost centers are added to overloaded function call sites+-- and/or top-level bindings, and which top-level bindings they are added to.+-- Also holds the cost center insertion environment.+data LateCCConfig =+      LateCCConfig+        { lateCCConfig_whichBinds :: !LateCCBindSpec+        , lateCCConfig_overloadedCalls :: !Bool+        , lateCCConfig_env :: !LateCCEnv+        }++-- | The types of top-level bindings we support adding cost centers to.+data LateCCBindSpec =+      LateCCNone+    | LateCCBinds+    | LateCCOverloadedBinds++-- | Late cost centre insertion environment+data LateCCEnv = LateCCEnv+  { lateCCEnv_module :: !Module+    -- ^ Current module+  , lateCCEnv_file :: Maybe FastString+    -- ^ Current file, if we have one+  , lateCCEnv_countEntries:: !Bool+    -- ^ Whether the inserted cost centers should count entries+  , lateCCEnv_collectCCs  :: !Bool+    -- ^ Whether to collect the cost centres we insert. See+    -- Note [Collecting late cost centres]++  }++-- | Late cost centre insertion state, indexed by some extra state type that an+-- insertion method may require.+data LateCCState s = LateCCState+    { lateCCState_ccs :: !(S.Set CostCentre)+      -- ^ Cost centres that have been inserted+    , lateCCState_ccState :: !CostCentreState+      -- ^ Per-module state tracking for cost centre indices+    , lateCCState_extra :: !s+    }++-- | The empty late cost centre insertion state+initLateCCState :: s -> LateCCState s+initLateCCState s =+    LateCCState+      { lateCCState_ccState = newCostCentreState+      , lateCCState_ccs = mempty+      , lateCCState_extra = s+      }++-- | Late cost centre insertion monad+type LateCCM s = ReaderT LateCCEnv (State (LateCCState s))
+ GHC/Core/LateCC/Utils.hs view
@@ -0,0 +1,80 @@+module GHC.Core.LateCC.Utils+  ( -- * Inserting cost centres+    doLateCostCenters -- Might be useful for API users++    -- ** Helpers for defining insertion methods+  , getCCFlavour+  , insertCC+  ) where++import GHC.Prelude++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Data.Set as S++import GHC.Core+import GHC.Core.LateCC.Types+import GHC.Core.Utils+import GHC.Data.FastString+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.SrcLoc+import GHC.Types.Tickish++-- | Insert cost centres into the 'CoreProgram' using the provided environment,+-- initial state, and insertion method.+doLateCostCenters+  :: LateCCEnv+  -- ^ Environment to run the insertion in+  -> LateCCState s+  -- ^ Initial state to run the insertion with+  -> (CoreBind -> LateCCM s CoreBind)+  -- ^ Insertion method+  -> CoreProgram+  -- ^ Bindings to consider+  -> (CoreProgram, LateCCState s)+doLateCostCenters env state method binds =+    runLateCC env state $ mapM method binds++-- | Evaluate late cost centre insertion+runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s)+runLateCC env state = (`runState` state) . (`runReaderT` env)++-- | Given the name of a cost centre, get its flavour+getCCFlavour :: FastString -> LateCCM s CCFlavour+getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name+  where+    getCCIndex' :: FastString -> LateCCM s CostCentreIndex+    getCCIndex' name = do+      cc_state <- lift $ gets lateCCState_ccState+      let (index, cc_state') = getCCIndex name cc_state+      lift . modify $ \s -> s { lateCCState_ccState = cc_state'}+      return index++-- | Insert a cost centre with the specified name and source span on the given+-- expression. The inserted cost centre will be appropriately tracked in the+-- late cost centre state.+insertCC+  :: FastString+  -- ^ Name of the cost centre to insert+  -> SrcSpan+  -- ^ Source location to associate with the cost centre+  -> CoreExpr+  -- ^ Expression to wrap in the cost centre+  -> LateCCM s CoreExpr+insertCC cc_name cc_loc expr = do+    cc_flavour <- getCCFlavour cc_name+    env <- ask+    let+      cc_mod = lateCCEnv_module env+      cc = NormalCC cc_flavour cc_name cc_mod cc_loc+      note = ProfNote cc (lateCCEnv_countEntries env) True+    when (lateCCEnv_collectCCs env) $ do+        lift . modify $ \s ->+          s { lateCCState_ccs = S.insert cc (lateCCState_ccs s)+            }+    return $ mkTick note expr+
+ GHC/Core/Lint.hs view
@@ -0,0 +1,4017 @@+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee].+-}++module GHC.Core.Lint (+    LintPassResultConfig (..),+    LintFlags (..),+    StaticPtrCheck (..),+    LintConfig (..),+    WarnsAndErrs,++    lintCoreBindings', lintUnfolding,+    lintPassResult, lintExpr,+    lintAnnots, lintAxioms,++    -- ** Debug output+    EndPassConfig (..),+    endPassIO,+    displayLintResults, dumpPassResult+ ) where++import GHC.Prelude++import GHC.Driver.DynFlags++import GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars+  , isFloatingPrimTy, isTyFamFree )+import GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..) )+import GHC.Unit.Module.ModGuts+import GHC.Platform++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Stats ( coreBindsStats )+import GHC.Core.DataCon+import GHC.Core.Ppr+import GHC.Core.Coercion+import GHC.Core.Type as Type+import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv+import GHC.Core.TyCo.Rep   -- checks validity of types/coercions+import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCon as TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.FamInstEnv( compatibleBranches )+import GHC.Core.Unify+import GHC.Core.Opt.Arity    ( typeArity, exprIsDeadEnd )++import GHC.Core.Opt.Monad++import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Unique.FM ( isNullUFM, sizeUFM )+import GHC.Types.RepType+import GHC.Types.Basic+import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim++import GHC.Data.Bag+import GHC.Data.List.SetOps++import GHC.Utils.Monad+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Error+import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger++import GHC.Data.Pair+import GHC.Base (oneShot)+import GHC.Data.Unboxed++import Control.Monad+import Data.Foldable      ( for_, toList )+import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )+import Data.Maybe+import Data.IntMap.Strict ( IntMap )+import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )++{-+Note [Core Lint guarantee]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Core Lint is the type-checker for Core. Using it, we get the following guarantee:++If all of:+1. Core Lint passes,+2. there are no unsafe coercions (i.e. unsafeEqualityProof),+3. all plugin-supplied coercions (i.e. PluginProv) are valid, and+4. all case-matches are complete+then running the compiled program will not seg-fault, assuming no bugs downstream+(e.g. in the code generator). This guarantee is quite powerful, in that it allows us+to decouple the safety of the resulting program from the type inference algorithm.++However, do note point (4) above. Core Lint does not check for incomplete case-matches;+see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,+an incomplete case-match might slip by Core Lint and cause trouble at runtime.++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)++Note [Linting function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All saturated applications of funTyCon are represented with the FunTy constructor.+See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim++ 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 Bool in+        let x::a = True in <body>+That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".+One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]+in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).++* Hence 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 -> Bool]) and apply this substitution before+  comparing types. In effect, in Lint, type equality is always+  equality-modulo-le-subst.  This is in the le_subst field of+  LintEnv.  But nota bene:++  (SI1) The le_subst substitution is applied to types and coercions only++  (SI2) The result of that substitution is used only to check for type+        equality, to check well-typed-ness, /but is then discarded/.+        The result of substitution does not outlive the CoreLint pass.++  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.++* The function+        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.++* Clearly we need to clone tyvar binders as we go.++* But take care (#17590)! We must also clone CoVar binders:+    let a = TYPE (ty |> cv)+    in \cv -> blah+  blindly substituting for `a` might capture `cv`.++* Alas, when cloning a coercion variable we might choose a unique+  that happens to clash with an inner Id, thus+      \cv_66 -> let wild_X7 = blah in blah+  We decide to clone `cv_66` because it's already in scope.  Fine,+  choose a new unique.  Aha, X7 looks good.  So we check the lambda+  body with le_subst of [cv_66 :-> cv_X7]++  This is all fine, even though we use the same unique as wild_X7.+  As (SI2) says, we do /not/ return a new lambda+     (\cv_X7 -> let wild_X7 = blah in ...)+  We simply use the le_subst substitution in types/coercions only, when+  checking for equality.++* We still need to check that Id occurrences are bound by some+  enclosing binding.  We do /not/ use the InScopeSet for the le_subst+  for this purpose -- it contains only TyCoVars.  Instead we have a separate+  le_ids for the in-scope Id binders.++Sigh.  We might want to explore getting rid of type-let!++Note [Bad unsafe coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions+Linter introduces additional rules that checks improper coercion between+different types, called bad coercions. Following coercions are forbidden:++  (a) coercions between boxed and unboxed values;+  (b) coercions between unlifted values of the different sizes, here+      active size is checked, i.e. size of the actual value but not+      the space allocated for value;+  (c) coercions between floating and integral boxed values, this check+      is not yet supported for unboxed tuples, as no semantics were+      specified for that;+  (d) coercions from / to vector type+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules+      (a-e) holds.++Note [Join points]+~~~~~~~~~~~~~~~~~~+We check the rules listed in Note [Invariants on join points] in GHC.Core. 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).++Note [Avoiding compiler perf traps when constructing error messages.]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's quite common to put error messages into a where clause when it might+be triggered by multiple branches. E.g.++  checkThing x y z =+    case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg+    where+      errMsg = text "My error involving:" $$ ppr x <+> ppr y++However ghc will compile this to:++  checkThink x y z =+    let errMsg = text "My error involving:" $$ ppr x <+> ppr y+    in case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg++Putting the allocation of errMsg into the common non-error path.+One way to work around this is to turn errMsg into a function:++  checkThink x y z =+    case x of+      X -> unless (correctX x) $ failWithL (errMsg x y)+      Y -> unless (correctY y) $ failWithL (errMsg x y)+    where+      errMsg x y = text "My error involving:" $$ ppr x <+> ppr y++This way `errMsg` is a static function and it being defined in the common+path does not result in allocation in the hot path. This can be surprisingly+impactful. Changing `lint_app` reduced allocations for one test program I was+looking at by ~4%.++Note [MCInfo for Lint]+~~~~~~~~~~~~~~~~~~~~~~+When printing a Lint message, use the MCInfo severity so that the+message is printed on stderr rather than stdout (#13342).++************************************************************************+*                                                                      *+                 Beginning and ending passes+*                                                                      *+************************************************************************+-}++-- | Configuration for boilerplate operations at the end of a+-- compilation pass producing Core.+data EndPassConfig = EndPassConfig+  { ep_dumpCoreSizes :: !Bool+  -- ^ Whether core bindings should be dumped with the size of what they+  -- are binding (i.e. the size of the RHS of the binding).++  , ep_lintPassResult :: !(Maybe LintPassResultConfig)+  -- ^ Whether we should lint the result of this pass.++  , ep_namePprCtx :: !NamePprCtx++  , ep_dumpFlag :: !(Maybe DumpFlag)++  , ep_prettyPass :: !SDoc++  , ep_passDetails :: !SDoc+  }++endPassIO :: Logger+          -> EndPassConfig+          -> CoreProgram -> [CoreRule]+          -> IO ()+-- Used by the IO-is CorePrep too+endPassIO logger cfg binds rules+  = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag+                        (renderWithContext defaultSDocContext (ep_prettyPass cfg))+                        (ep_passDetails cfg) binds rules+       ; for_ (ep_lintPassResult cfg) $ \lp_cfg ->+           lintPassResult logger lp_cfg binds+       }+  where+    mb_flag = case ep_dumpFlag cfg of+                Just flag | logHasDumpFlag logger flag                    -> Just flag+                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag+                _ -> Nothing++dumpPassResult :: Logger+               -> Bool                  -- dump core sizes?+               -> NamePprCtx+               -> Maybe DumpFlag        -- Just df => show details in a file whose+                                        --            name is specified by df+               -> String                -- Header+               -> SDoc                  -- Extra info to appear after header+               -> CoreProgram -> [CoreRule]+               -> IO ()+dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules+  = do { forM_ mb_flag $ \flag -> do+           logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore 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 logger 2 size_doc+       }++  where+    size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]++    dump_doc  = vcat [ nest 2 extra_info+                     , size_doc+                     , blankLine+                     , if dump_core_sizes+                        then pprCoreBindingsWithSize binds+                        else pprCoreBindings         binds+                     , ppUnless (null rules) pp_rules ]+    pp_rules = vcat [ blankLine+                    , text "------ Local rules for imported ids --------"+                    , pprRules rules ]++{-+************************************************************************+*                                                                      *+                 Top-level interfaces+*                                                                      *+************************************************************************+-}++data LintPassResultConfig = LintPassResultConfig+  { lpr_diagOpts         :: !DiagOpts+  , lpr_platform         :: !Platform+  , lpr_makeLintFlags    :: !LintFlags+  , lpr_showLintWarnings :: !Bool+  , lpr_passPpr          :: !SDoc+  , lpr_localsInScope    :: ![Var]+  }++lintPassResult :: Logger -> LintPassResultConfig+               -> CoreProgram -> IO ()+lintPassResult logger cfg binds+  = do { let warns_and_errs = lintCoreBindings'+               (LintConfig+                { l_diagOpts = lpr_diagOpts cfg+                , l_platform = lpr_platform cfg+                , l_flags    = lpr_makeLintFlags cfg+                , l_vars     = lpr_localsInScope cfg+                })+               binds+       ; Err.showPass logger $+           "Core Linted result of " +++           renderWithContext defaultSDocContext (lpr_passPpr cfg)+       ; displayLintResults logger+                            (lpr_showLintWarnings cfg) (lpr_passPpr cfg)+                            (pprCoreBindings binds) warns_and_errs+       }++displayLintResults :: Logger+                   -> Bool -- ^ If 'True', display linter warnings.+                           --   If 'False', ignore linter warnings.+                   -> SDoc -- ^ The source of the linted program+                   -> SDoc -- ^ The linted program, pretty-printed+                   -> WarnsAndErrs+                   -> IO ()+displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)+  | not (isEmptyBag errs)+  = do { logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+           $ withPprStyle defaultDumpStyle+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs+                 , text "*** Offending Program ***"+                 , pp_pgm+                 , text "*** End of Offense ***" ])+       ; Err.ghcExit logger 1 }++  | not (isEmptyBag warns)+  , log_enable_debug (logFlags logger)+  , display_warnings+  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+      $ withPprStyle defaultDumpStyle+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))++  | otherwise = return ()++lint_banner :: String -> SDoc -> SDoc+lint_banner string pass = text "*** Core Lint"      <+> text string+                          <+> text ": in result of" <+> pass+                          <+> text "***"++-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].+lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs+--   Returns (warnings, errors)+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreBindings' cfg binds+  = initL cfg $+    addLoc TopLevelBindings           $+    do { -- Check that all top-level binders are distinct+         -- We do not allow  [NonRec x=1, NonRec y=x, NonRec x=2]+         -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal+         checkL (null dups) (dupVars dups)++         -- Check for External top level binders with the same M.n name+       ; checkL (null ext_dups) (dupExtVars ext_dups)++         -- Typecheck the bindings+       ; lintRecBindings TopLevel all_pairs $ \_ ->+         return () }+  where+    all_pairs = flattenBinds binds+     -- Put all the top-level binders in scope at the start+     -- This is because rewrite rules can bring something+     -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"+    binders = map fst all_pairs++    (_, dups) = removeDups compare binders++    -- ext_dups checks for names with different uniques+    -- 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 $ removeDupsOn ord_ext $+               filter isExternalName $ map Var.varName binders+    ord_ext n = (nameModule n, nameOccName n)++{-+************************************************************************+*                                                                      *+\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 GHC.IfaceToCore.++-}++lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding+              -> LintConfig+              -> SrcLoc+              -> CoreExpr+              -> Maybe (Bag SDoc) -- Nothing => OK++lintUnfolding is_compulsory cfg locn expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg $+                     if is_compulsory+                       -- See Note [Checking for representation polymorphism]+                     then noFixedRuntimeRepChecks linter+                     else linter+    linter = addLoc (ImportedUnfolding locn) $+             lintCoreExpr expr++lintExpr :: LintConfig+         -> CoreExpr+         -> Maybe (Bag SDoc)  -- Nothing => OK++lintExpr cfg expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg linter+    linter = addLoc TopLevelBindings $+             lintCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection[lintCoreBinding]{lintCoreBinding}+*                                                                      *+************************************************************************++Check a core binding, returning the list of variables bound.+-}++-- Returns a UsageEnv because this function is called in lintCoreExpr for+-- Let++lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]+                -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv])+lintRecBindings top_lvl pairs thing_inside+  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->+    do { ues <- zipWithM lint_pair bndrs' rhss+       ; a <- thing_inside bndrs'+       ; return (a, ues) }+  where+    (bndrs, rhss) = unzip pairs+    lint_pair bndr' rhs+      = addLoc (RhsOf bndr') $+        do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs+           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty+           ; return ue }++lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv)+lintLetBody loc bndrs body+  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)+       ; mapM_ (lintJoinBndrType body_ty) bndrs+       ; return (body_ty, body_ue) }++lintLetBind :: TopLevelFlag -> RecFlag -> OutId+              -> CoreExpr -> OutType -> LintM ()+-- Binder's type, and the RHS, have already been linted+-- This function checks other invariants+lintLetBind top_lvl rec_flag binder rhs rhs_ty+  = do { let binder_ty = idType binder+       ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)++       -- If the binding is for a CoVar, the RHS should be (Coercion co)+       -- See Note [Core type and coercion invariant] in GHC.Core+       ; checkL (not (isCoVar binder) || isCoArg rhs)+                (mkLetErr binder rhs)++        -- Check the let-can-float invariant+        -- See Note [Core let-can-float invariant] in GHC.Core+       ; checkL ( isJoinId binder+               || mightBeLiftedType binder_ty+               || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed+               || exprIsTickedString rhs)+           (badBndrTyMsg binder (text "unlifted"))++        -- Check that if the binder is at the top level and has type Addr#,+        -- that it is a string literal.+        -- See Note [Core top-level string literals].+       ; checkL (not (isTopLevel top_lvl && 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 idJoinPointHood binder of+            NotJoinPoint    -> return ()+            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)+                                       (mkInvalidJoinPointMsg binder binder_ty)++       ; when (lf_check_inline_loop_breakers flags+               && isStableUnfolding (realIdUnfolding binder)+               && isStrongLoopBreaker (idOccInfo binder)+               && isInlinePragma (idInlinePragma binder))+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))+              -- Only non-rule loop breakers inhibit inlining++       -- We used to check that the dmdTypeDepth of a demand signature never+       -- exceeds idArity, but that is an unnecessary complication, see+       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal++       -- Check that the binder's arity is within the bounds imposed by the type+       -- and the strictness signature. See Note [Arity invariants for bindings]+       -- and Note [Trimming arity]++       ; checkL (typeArity (idType binder) >= idArity binder)+           (text "idArity" <+> ppr (idArity binder) <+>+           text "exceeds typeArity" <+>+           ppr (typeArity (idType binder)) <> colon <+>+           ppr binder)++       -- See Note [idArity varies independently of dmdTypeDepth]+       --     in GHC.Core.Opt.DmdAnal+       ; case splitDmdSig (idDmdSig binder) of+           (demands, result_info) | isDeadEndDiv result_info ->+              if (demands `lengthAtLeast` idArity binder)+              then return ()+              else pprTrace "Hack alert: lintLetBind #24623"+                       (ppr (idArity binder) $$ ppr (idDmdSig binder)) $+                   return ()+--             checkL (demands `lengthAtLeast` idArity binder)+--               (text "idArity" <+> ppr (idArity binder) <+>+--               text "exceeds arity imposed by the strictness signature" <+>+--               ppr (idDmdSig binder) <> colon <+>+--               ppr binder)++           _ -> return ()++       ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)++       ; addLoc (UnfoldingOf binder) $+         lintIdUnfolding binder binder_ty (idUnfolding binder)+       ; return () }++        -- 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, UsageEnv)+-- NB: the Id can be Linted or not -- it's only used for+--     its OccInfo and join-pointer-hood+lintRhs bndr rhs+    | JoinPoint arity <- idJoinPointHood bndr+    = lintJoinLams arity (Just bndr) rhs+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+    = lintJoinLams arity Nothing rhs++-- 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 :: StaticPtrCheck -> LintM (OutType, UsageEnv)+    go AllowAtTopLevel+      | (binders0, rhs') <- collectTyBinders rhs+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'+      = markAllJoinsBad $+        foldr+        -- imitate @lintCoreExpr (Lam ...)@+        lintLambda+        -- imitate @lintCoreExpr (App ...)@+        (do fun_ty_ue <- lintCoreExpr fun+            lintCoreArgs fun_ty_ue [Type t, info, e]+        )+        binders0+    go _ = markAllJoinsBad $ lintCoreExpr rhs++-- | Lint the RHS of a join point with expected join arity of @n@ (see Note+-- [Join points] in "GHC.Core").+lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv)+lintJoinLams join_arity enforce rhs+  = go join_arity rhs+  where+    go 0 expr            = lintCoreExpr expr+    go n (Lam var body)  = lintLambda var $ go (n-1) body+    go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas+              = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs+              | otherwise -- Future join point, not yet eta-expanded+              = markAllJoinsBad $ lintCoreExpr expr+                -- Body of lambda is not a tail position++lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()+lintIdUnfolding bndr bndr_ty uf+  | isStableUnfolding uf+  , Just rhs <- maybeUnfoldingTemplate uf+  = do { ty <- fst <$> (if isCompulsoryUnfolding uf+                        then noFixedRuntimeRepChecks $ lintRhs bndr rhs+            --               ^^^^^^^^^^^^^^^^^^^^^^^+            -- See Note [Checking for representation polymorphism]+                        else 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. GHC.Core.FVs.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.  Here is an example:+  instance Eq T where+    t1 == t2 = blah+    t1 /= t2 = not (t1 == t2)+    {-# INLINE (/=) #-}++This will generate something like+    -- From the class decl for Eq+    data Eq a = EqDict (a->a->Bool) (a->a->Bool)+    eq_sel :: Eq a -> (a->a->Bool)+    eq_sel (EqDict eq _) = eq++    -- From the instance Eq T+    $ceq :: T -> T -> Bool+    $ceq = blah++    Rec { $dfEqT :: Eq T {-# DFunId #-}+          $dfEqT = EqDict $ceq $cnoteq++          $cnoteq :: T -> T -> Bool  {-# INLINE #-}+          $cnoteq x y = not (eq_sel $dfEqT x y) }++Notice that++* `$dfEqT` and `$cnotEq` are mutually recursive.++* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and+  we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun+  selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop+  breaker.++So we make `$cnoteq` into the loop breaker. That means it can't+inline, despite the INLINE pragma. That's what gives rise to the+warning, which is perfectly appropriate for, say+   Rec { {-# INLINE f #-}  f = \x -> ...f.... }+We can't inline a recursive function -- it's a loop breaker.++But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get+  Rec {+    $dfEqT :: Eq T {-# DFunId #-}+    $dfEqT = EqDict $ceq $cnoteq++    $cnoteq :: T -> T -> Bool  {-# INLINE #-}+    $cnoteq x y = not ($ceq x y) }++and now the dependencies of the Rec have gone, and we can split it up to give+    NonRec {  $dfEqT :: Eq T {-# DFunId #-}+              $dfEqT = EqDict $ceq $cnoteq }++    NonRec {  $cnoteq :: T -> T -> Bool  {-# INLINE #-}+              $cnoteq x y = not ($ceq x y) }++Now $cnoteq is not a loop breaker any more, so the INLINE pragma can+take effect -- the warning turned out to be temporary.++To stop excessive warnings, this warning for INLINE loop breakers is+switched off when linting the result of the desugarer.  See+lf_check_inline_loop_breakers in GHC.Core.Lint.+++Note [Checking for representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We ordinarily want to check for bad representation polymorphism. See+Note [Representation polymorphism invariants] in GHC.Core. However, we do *not*+want to do this in a compulsory unfolding. Compulsory unfoldings arise+only internally, for things like newtype wrappers, dictionaries, and+(notably) unsafeCoerce#. These might legitimately be representation-polymorphic;+indeed representation-polymorphic unfoldings are a primary reason for the+very existence of compulsory unfoldings (we can't compile code for+the original, representation-polymorphic, binding).++It is vitally important that we do representation polymorphism checks *after*+performing the unfolding, but not beforehand. This is all safe because+we will check any unfolding after it has been unfolded; checking the+unfolding beforehand is merely an optimization, and one that actively+hurts us here.++Note [Linting of runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~+runRW# has some very special behavior (see Note [runRW magic] in+GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing+join points in its argument.  For example, this is fine:++    join j x = ...+    in runRW#  (\s. case v of+                       A -> j 3+                       B -> j 4)++Usually those calls to the join point 'j' would not be valid tail calls,+because they occur in a function argument.  But in the case of runRW#+they are fine, because runRW# (\s.e) behaves operationally just like e.+(runRW# is ultimately inlined in GHC.CoreToStg.Prep.)++In the case that the continuation is /not/ a lambda we simply disable this+special behaviour.  For example, this is /not/ fine:++    join j = ...+    in runRW# @r @ty (jump j)++Note [Coercions in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (Type ty) can occur only as the argument of an application,+or the RHS of a non-recursive Let.  But what about (Coercion co)?++Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose+definition is:+   coercible_sel :: Coercible a b => (a ~R# b)+   coercible_sel d = case d of+                         MkCoercibleDict (co :: a ~# b) -> Coercion co++So this function has a (Coercion co) in the alternative of a case.++Richard says (!11908): it shouldn't appear outside of arguments, but we've been+loose about this. coercible_sel is some thin ice. Really we should be unpacking+Coercible using case, not a selector. I recall looking into this a few years+back and coming to the conclusion that the fix was worse than the disease. Don't+remember the details, but could probably recover it if we want to revisit.++So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in+that: it really is a value, albeit a zero-bit value.++************************************************************************+*                                                                      *+\subsection[lintCoreExpr]{lintCoreExpr}+*                                                                      *+************************************************************************+-}++lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv)+-- 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)+  = do {  var_pair@(var_ty, _) <- lintIdOcc var 0+           -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin (Var var) [] var_ty+           --checkDataToTagPrimOpTyCon (Var var) []+       ; return var_pair }++lintCoreExpr (Lit lit)+  = return (literalType lit, zeroUE)++lintCoreExpr (Cast expr co)+  = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)+            -- markAllJoinsBad: see Note [Join points and casts]++       ; lintCoercion co+       ; lintRole co Representational (coercionRole co)+       ; Pair from_ty to_ty <- substCoKindM co+       ; checkValueType (typeKind to_ty) $+         text "target of cast" <+> quotes (ppr co)+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty)+       ; return (to_ty, ue) }++lintCoreExpr (Tick tickish expr)+  = do { case tickish of+           Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0+           _                  -> 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' <- lintTypeAndSubst ty+        ; lintTyCoBndr tv              $ \ tv' ->+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'+                -- Now extend the substitution so we+                -- take advantage of it in the body+        ; extendTvSubstL tv ty' $+          addLoc (BodyOfLet tv) $+          lintCoreExpr body } }++lintCoreExpr (Let (NonRec bndr rhs) body)+  | isId bndr+  = do { -- First Lint the RHS, before bringing the binder into scope+         (rhs_ty, let_ue) <- lintRhs bndr rhs++          -- See Note [Multiplicity of let binders] in Var+         -- Now lint the binder+       ; lintBinder LetBind bndr $ \bndr' ->+    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty+       ; addAliasUE bndr' let_ue $+         lintLetBody (BodyOfLet bndr') [bndr'] body } }++  | otherwise+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate++lintCoreExpr e@(Let (Rec pairs) body)+  = do  { -- Check that the list of pairs is non-empty+          checkL (not (null pairs)) (emptyRec e)++          -- Check that there are no duplicated binders+        ; let (_, dups) = removeDups compare bndrs+        ; 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++          -- See Note [Multiplicity of let binders] in Var+        ; ((body_type, body_ue), ues) <-+            lintRecBindings NotTopLevel pairs $ \ bndrs' ->+            lintLetBody (BodyOfLetRec bndrs') bndrs' body+        ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) }+  where+    bndrs = map fst pairs++lintCoreExpr e@(App _ _)+  | Var fun <- fun+  , fun `hasKey` runRWKey+    -- See Note [Linting of runRW#]+    -- N.B. we may have an over-saturated application of the form:+    --   runRW (\s -> \x -> ...) y+  , ty_arg1 : ty_arg2 : cont_arg : rest <- args+  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+             lint_rw_cont expr@(Lam _ _) mult fun_ue+                = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr+                     ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+                     ; return (arg_ty, app_ue) }++             lint_rw_cont expr mult ue+                = lintValArg expr mult ue+             -- TODO: Look through ticks?++       ; runrw_pr <- lintApp (text "runRW# expression")+                               lintTyArg lint_rw_cont+                               (idType fun) [ty_arg1,ty_arg2,cont_arg] zeroUE+       ; lintCoreArgs runrw_pr rest }++  | otherwise+  = do { fun_pair <- lintCoreFun fun (length args)+       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args++       -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin fun args app_ty+       ; --checkDataToTagPrimOpTyCon fun args++       ; return app_pair}+  where+    skipTick t = case collectFunSimple e of+      (Var v) -> etaExpansionTick v t+      _ -> tickishFloatable t+    (fun, args, _source_ticks) = collectArgsTicks skipTick e+      -- We must look through source ticks to avoid #21152, for example:+      --+      -- reallyUnsafePtrEquality+      --   = \ @a ->+      --       (src<loc> reallyUnsafePtrEquality#)+      --         @Lifted @a @Lifted @a+      --+      -- To do this, we use `collectArgsTicks tickishFloatable` to match+      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]+      -- in GHC.Core.Opt.Arity.+      -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.+      -- See Note [Ticks and mandatory eta expansion]++lintCoreExpr (Lam var expr)+  = markAllJoinsBad $+    lintLambda var $ lintCoreExpr expr++lintCoreExpr (Case scrut var alt_ty alts)+  = lintCaseExpr scrut var alt_ty alts++-- This case can't happen; linting types in expressions gets routed through lintTyArg+lintCoreExpr (Type ty)+  = failWithL (text "Type found as expression" <+> ppr ty)++lintCoreExpr (Coercion co)+  -- See Note [Coercions in terms]+  = do { addLoc (InCo co) $ lintCoercion co+       ; ty <- substTyM (coercionType co)+       ; return (ty, zeroUE) }++----------------------+lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed+          -> LintM (OutType, UsageEnv) -- returns type of the *variable*+lintIdOcc in_id nargs+  = addLoc (OccOf in_id) $+    do  { checkL (isNonCoVarId in_id)+                 (text "Non term variable" <+> ppr in_id)+                 -- See GHC.Core Note [Variable occurrences in Core]++        -- Check that the type of the occurrence is the same+        -- as the type of the binding site.  The inScopeIds are+        -- /un-substituted/, so this checks that the occurrence type+        -- is identical to the binder type.+        -- This makes things much easier for things like:+        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...+        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.+        -- If we compared /substituted/ types we'd risk comparing+        -- (Maybe a) from the binding site with bogus (Maybe a1) from+        -- the occurrence site.  Comparing un-substituted types finesses+        -- this altogether+        ; out_ty <- lintVarOcc in_id++          -- 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 in_id /= makeStaticName) $+              text "Found makeStatic nested in an expression"++        ; checkDeadIdOcc in_id++        ; case isDataConId_maybe in_id of+             Nothing -> return ()+             Just dc -> checkTypeDataConOcc "expression" dc++        ; checkJoinOcc in_id nargs+        ; usage <- varCallSiteUsage in_id++        ; return (out_ty, usage) }++++lintCoreFun :: CoreExpr+            -> Int                          -- Number of arguments (type or val) being passed+            -> LintM (OutType, UsageEnv) -- Returns type of the *function*+lintCoreFun (Var var) nargs+  = lintIdOcc var nargs++lintCoreFun (Lam var body) nargs+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;+  -- See Note [Beta redexes]+  | nargs /= 0+  = lintLambda var $ lintCoreFun body (nargs - 1)++lintCoreFun expr nargs+  = markAllJoinsBadIf (nargs /= 0) $+      -- See Note [Join points are less general than the paper]+    lintCoreExpr expr+------------------+lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)+lintLambda var lintBody =+    addLoc (LambdaBodyOf var) $+    lintBinder LambdaBind var $ \ var' ->+    do { (body_ty, ue) <- lintBody+       ; ue' <- checkLinearity ue var'+       ; return (mkLamType var' body_ty, ue') }+------------------+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 ()++------------------+lintJoinBndrType :: OutType -- Type of the body+                 -> OutId   -- Possibly a join Id+                -> LintM ()+-- Checks that the return type of a join Id matches the body+-- E.g. join j x = rhs in body+--      The type of 'rhs' must be the same as the type of 'body'+lintJoinBndrType body_ty bndr+  | JoinPoint arity <- idJoinPointHood bndr+  , let bndr_ty = idType bndr+  , (bndrs, res) <- splitPiTys bndr_ty+  = checkL (length bndrs >= arity+            && body_ty `eqType` mkPiTys (drop arity bndrs) res) $+    hang (text "Join point returns different type than body")+       2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)+               , text "Join arity:" <+> ppr arity+               , text "Body type:" <+> ppr body_ty ])+  | 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+  | JoinPoint join_arity_occ <- idJoinPointHood var+  = do { mb_join_arity_bndr <- lookupJoinId var+       ; case mb_join_arity_bndr of {+           NotJoinPoint -> do { join_set <- getValidJoins+                              ; addErrL (text "join set " <+> ppr join_set $$+                                invalidJoinOcc var) } ;++           JoinPoint 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 ()++checkTypeDataConOcc :: String -> DataCon -> LintM ()+-- Check that the Id is not a data constructor of a `type data` declaration+-- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module+checkTypeDataConOcc what dc+  = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $+    (text "type data constructor found in a" <+> text what <> colon <+> ppr dc)++{-+-- | Check that a use of a dataToTag# primop satisfies conditions DTT2+-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class+--+-- Ignores applications not headed by dataToTag# primops.++-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.+-- See wrinkle DTW7 in Note [DataToTag overview].+checkDataToTagPrimOpTyCon+  :: CoreExpr   -- ^ the function (head of the application) we are checking+  -> [CoreArg]  -- ^ The arguments to the application+  -> LintM ()+checkDataToTagPrimOpTyCon (Var fun_id) args+  | Just op <- isPrimOpId_maybe fun_id+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case args of+      Type _levity : Type dty : _rest+        | Just (tc, _) <- splitTyConApp_maybe dty+        , isValidDTT2TyCon tc+          -> do  platform <- getPlatform+                 let  numConstrs = tyConFamilySize tc+                      isSmallOp = op == DataToTagSmallOp+                 checkL (isSmallFamily platform numConstrs == isSmallOp) $+                   text "dataToTag# primop-size/tycon-family-size mismatch"+        | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"+                                   <+> ppr dty+      _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"+                       <+> ppr (take 2 args)++checkDataToTagPrimOpTyCon _ _ = pure ()+-}++-- | Check representation-polymorphic invariants in an application of a+-- built-in function or newtype constructor.+--+-- See Note [Linting representation-polymorphic builtins].+checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking+                    -> [CoreArg]  -- ^ the arguments to the application+                    -> OutType -- ^ the instantiated type of the overall application+                    -> LintM ()+checkRepPolyBuiltin (Var fun_id) args app_ty+  = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags+       ; when (do_rep_poly_checks && hasNoBinding fun_id) $+           if+             -- (2) representation-polymorphic unlifted newtypes+             | Just dc <- isDataConId_maybe fun_id+             , isNewDataCon dc+             -> if tcHasFixedRuntimeRep $ dataConTyCon dc+                then return ()+                else checkRepPolyNewtypeApp dc args app_ty++             -- (1) representation-polymorphic builtins+             | otherwise+             -> checkRepPolyBuiltinApp fun_id args+       }+checkRepPolyBuiltin _ _ _ = return ()++checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> OutType -> LintM ()+checkRepPolyNewtypeApp nt args app_ty+  -- If the newtype is saturated, we're OK.+  | any isValArg args+  = return ()+  -- Otherwise, check we can eta-expand.+  | otherwise+  = case getRuntimeArgTys app_ty of+      (Scaled _ first_val_arg_ty, _):_+        | not $ typeHasFixedRuntimeRep first_val_arg_ty+        -> failWithL (err_msg first_val_arg_ty)+      _ -> return ()++  where++      err_msg :: Type -> SDoc+      err_msg bad_arg_ty+        = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot+               , text "Its argument type does not have a fixed runtime representation:"+               , nest 2 $ ppr_ty_ki bad_arg_ty ]++      ppr_ty_ki :: Type -> SDoc+      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)++checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()+checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg+  where++    conc_binder_positions :: IntMap ConcreteTvOrigin+    conc_binder_positions+      = concreteTyVarPositions fun_id+      $ idDetailsConcreteTvs+      $ idDetails fun_id++    max_pos :: Int+    max_pos =+      case nonEmpty $ IntMap.keys conc_binder_positions of+        Nothing -> 0+        Just positions -> maximum positions++    not_concs :: [(SDoc, ConcreteTvOrigin)]+    not_concs =+      mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing))+        -- NB: 1-indexed++    is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)+    is_bad (pos, mb_arg)+      | Just conc_reason <- IntMap.lookup pos conc_binder_positions+      , Just bad_ty <- case mb_arg of+          Just (Type ki)+            | isConcreteType ki+            -> Nothing+            | otherwise+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has been instantiated with a type that is not concrete.+            -> Just $ quotes (ppr ki) <+> text "is not concrete."+          -- We expected a type argument in this position, and got something else: panic!+          Just arg ->+            pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $+              vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id)+                   , text "pos:" <+> ppr pos+                   , text "arg:" <+> ppr arg ]+          Nothing ->+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has not been instantiated at all.+            case conc_reason of+              ConcreteFRR frr_orig ->+                let ty = frr_type frr_orig+                in  Just $ ppr ty <+> dcolon <+> ppr (typeKind ty)+      = Just (bad_ty, conc_reason)+      | otherwise+      = Nothing++    err_msg :: SDoc+    err_msg+      = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs++    ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc+    ppr_not_conc (bad_ty, conc) =+      vcat+       [ ppr_conc_orig conc+       , nest 2 bad_ty ]++    ppr_conc_orig :: ConcreteTvOrigin -> SDoc+    ppr_conc_orig (ConcreteFRR frr_orig) =+      case frr_orig of+        FixedRuntimeRepOrigin { frr_context = ctxt } ->+          hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ]++-- | Compute the 1-indexed positions in the outer forall'd quantified type variables+-- of the type in which the concrete type variables occur.+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.+concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin+concreteTyVarPositions fun_id conc_tvs+  | isNullUFM conc_tvs+  = IntMap.empty+  | otherwise+  = case splitForAllTyCoVars (idType fun_id) of+    ([], _)  -> IntMap.empty+    (tvs, _) ->+      let positions =+            IntMap.fromList+              [ (pos, conc_orig)+              | (tv, pos) <- zip tvs [1..]+              , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv)+              ]+         -- Assert that we have as many positions as concrete type variables,+         -- i.e. we are not missing any concreteness information.+      in assertPpr (sizeUFM conc_tvs == length positions)+           (vcat [ text "concreteTyVarPositions: missing concreteness information"+                 , text "fun_id:" <+> ppr fun_id+                 , text "tvs:" <+> ppr tvs+                 , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs)+                 , text "  Actual # of concrete tvs:" <+> ppr (length positions) ])+           positions++-- Check that the usage of var is consistent with var itself, and pop the var+-- from the usage environment (this is important because of shadowing).+checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv+checkLinearity body_ue lam_var =+  case varMultMaybe lam_var of+    Just mult -> do+      let (lhs, body_ue') = popUE body_ue lam_var+          err_msg = vcat [ text "Linearity failure in lambda:" <+> ppr lam_var+                         , ppr lhs <+> text "⊈" <+> ppr mult+                         , ppr body_ue ]+      ensureSubUsage lhs mult err_msg+      return body_ue'+    Nothing    -> return body_ue -- A type variable++{- Note [Join points and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that this should be OK:+   join j x = rhs+   in (case e of+          A   -> alt1+          B x -> (jump j x) |> co)++You might think that, since the cast is ultimately erased, the jump to+`j` should still be OK as a join point.  But no!  See #21716. Suppose++  newtype Age = MkAge Int   -- axAge :: Age ~ Int+  f :: Int -> ...           -- f strict in it's first argument++and consider the expression++  f (join j :: Bool -> Age+          j x = (rhs1 :: Age)+     in case v of+         Just x  -> (j x |> axAge :: Int)+         Nothing -> rhs2)++Then, if the Simplifier pushes the strict call into the join points+and alternatives we'll get++   join j' x = f (rhs1 :: Age)+   in case v of+      Just x  -> j' x |> axAge+      Nothing -> f rhs2++Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.+No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad+in the (Cast expr co) case of lintCoreExpr.++Note [No alternatives lint check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case expressions with no alternatives are odd beasts, and it would seem+like they would worth be looking at in the linter (cf #10180). We+used to check two things:++* exprIsHNF is false: it would *seem* to be terribly wrong if+  the scrutinee was already in head normal form.++* exprIsDeadEnd is true: we should be able to see why GHC believes the+  scrutinee is diverging for sure.++It was already known that the second test was not entirely reliable.+Unfortunately (#13990), the first test turned out not to be reliable+either. Getting the checks right turns out to be somewhat complicated.++For example, suppose we have (comment 8)++  data T a where+    TInt :: T Int++  absurdTBool :: T Bool -> a+  absurdTBool v = case v of++  data Foo = Foo !(T Bool)++  absurdFoo :: Foo -> a+  absurdFoo (Foo x) = absurdTBool x++GHC initially accepts the empty case because of the GADT conditions. But then+we inline absurdTBool, getting++  absurdFoo (Foo x) = case x of++x is in normal form (because the Foo constructor is strict) but the+case is empty. To avoid this problem, GHC would have to recognize+that matching on Foo x is already absurd, which is not so easy.++More generally, we don't really know all the ways that GHC can+lose track of why an expression is bottom, so we shouldn't make too+much fuss when that happens.+++Note [Beta redexes]+~~~~~~~~~~~~~~~~~~~+Consider:++  join j @x y z = ... in+  (\@x y z -> jump j @x y z) @t e1 e2++This is clearly ill-typed, since the jump is inside both an application and a+lambda, either of which is enough to disqualify it as a tail call (see Note+[Invariants on join points] in GHC.Core). 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, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately+before Float Out.++All that said, currently GHC.Core.Subst.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.+-}++-- Takes the functions type and arguments as argument.+-- Returns the *result* of applying the function to arguments.+-- e.g. f :: Int -> Bool -> Int would return `Int` as result type.+lintCoreArgs  :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv)+lintCoreArgs (fun_ty, fun_ue) args+  = lintApp (text "expression")+              lintTyArg lintValArg fun_ty args fun_ue++lintTyArg :: InExpr -> LintM OutType++-- Type argument+lintTyArg (Type arg_ty)+  = do { checkL (not (isCoercionTy arg_ty))+                (text "Unnecessary coercion-to-type injection:"+                  <+> ppr arg_ty)+       ; lintTypeAndSubst arg_ty }+lintTyArg arg+  = failWithL (hang (text "Expected type argument but found") 2 (ppr arg))++lintValArg  :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+lintValArg arg mult fun_ue+  = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg+           -- See Note [Representation polymorphism invariants] in GHC.Core++       ; flags <- getLintFlags+       ; when (lf_check_fixed_rep flags) $+         -- Only check that 'arg_ty' has a fixed RuntimeRep+         -- if 'lf_check_fixed_rep' is on.+         do { checkL (typeHasFixedRuntimeRep arg_ty)+                     (text "Argument does not have a fixed runtime representation"+                      <+> ppr arg <+> dcolon+                      <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) }++       ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+       ; return (arg_ty, app_ue) }++-----------------+lintAltBinders :: UsageEnv+               -> Var         -- Case binder+               -> OutType     -- Scrutinee type+               -> OutType     -- Constructor type+               -> [(Mult, OutVar)]    -- Binders+               -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintAltBinders rhs_ue _case_bndr scrut_ty con_ty []+  = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)+       ; return rhs_ue }+lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)+  | isTyVar bndr+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)+       ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }+  | otherwise+  = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE+         -- We can pass zeroUE to lintValApp because we ignore its usage+         -- calculation and compute it in the call for checkCaseLinearity below.+       ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr+       ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }++-- | Implements the case rules for linearity+checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv+checkCaseLinearity ue case_bndr var_w bndr = do+  ensureSubUsage lhs rhs err_msg+  lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr)+  return $ deleteUE ue bndr+  where+    lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage)+    rhs = case_bndr_w `mkMultMul` var_w+    err_msg  = (text "Linearity failure in variable:" <+> ppr bndr+                $$ ppr lhs <+> text "⊈" <+> ppr rhs+                $$ text "Computed by:"+                <+> text "LHS:" <+> lhs_formula+                <+> text "RHS:" <+> rhs_formula)+    lhs_formula = ppr bndr_usage <+> text "+"+                                 <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w)+    rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w+    case_bndr_w = idMult case_bndr+    case_bndr_usage = lookupUE ue case_bndr+    bndr_usage = lookupUE ue bndr++++-----------------+lintTyApp :: OutType -> OutType -> LintM OutType+lintTyApp fun_ty arg_ty+  | Just (tv,body_ty) <- splitForAllTyVar_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 GHC.Core.TyCo.Subst+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }++  | otherwise+  = failWithL (mkTyAppMsg fun_ty arg_ty)++-----------------++-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@+-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the+-- application.+lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv+           -> LintM (OutType, UsageEnv)+lintValApp arg fun_ty arg_ty fun_ue arg_ue+  | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty+  = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)+       ; let app_ue =  addUE fun_ue (scaleUE w arg_ue)+       ; return (res_ty', app_ue) }+  | otherwise+  = failWithL err2+  where+    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+  = unless (arg_kind `eqType` tyvar_kind) $+    addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))+  where+    tyvar_kind = tyVarKind tyvar+    arg_kind   = typeKind arg_ty++{-+************************************************************************+*                                                                      *+\subsection[lintCoreAlts]{lintCoreAlts}+*                                                                      *+************************************************************************+-}++lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv)+lintCaseExpr scrut case_bndr alt_ty alts+  = do { let e = Case scrut case_bndr alt_ty alts   -- Just for error messages++       -- Check the scrutinee+       ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut+            -- See Note [Join points are less general than the paper]+            -- in GHC.Core++       ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty++       ; checkCaseAlts e scrut scrut_ty' alts++       -- Lint the case-binder. Must do this after linting the scrutinee+       -- because the case-binder isn't in scope in the scrutineex+       ; lintBinder CaseBind case_bndr $ \case_bndr' ->+      -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate++    do { let case_bndr_ty' = idType case_bndr'+             scrut_mult    = idMult case_bndr'++       ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty')+         -- See GHC.Core Note [Case expression invariants] item (7)++       ; -- Check the alternatives+       ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts+       ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues+       ; return (alt_ty', case_ue) } }++checkCaseAlts :: InExpr -> InExpr -> 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+-- d) Check that the scrutinee is not a floating-point type+--    if there are any literal alternatives+-- e) Check if the scrutinee type has no constructors+--+-- 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.+--+-- NB: Algebraic cases are not necessarily exhaustive, because+--     the simplifier correctly eliminates case that can't+--     possibly match.+checkCaseAlts e scrut scrut_ty alts+  = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+           -- See GHC.Core Note [Case expression invariants] item (2)++       ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)+           -- See GHC.Core Note [Case expression invariants] item (3)++            -- 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 GHC.Core) 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)++       -- Check that the scrutinee is not a floating-point type+       -- if there are any literal alternatives+       -- See GHC.Core Note [Case expression invariants] item (5)+       -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold+       ; checkL (not $ isFloatingPrimTy scrut_ty && any is_lit_alt alts)+           (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."+            $$ text "scrut" <+> ppr scrut)++       -- Check if scrutinee type has no constructors+       -- Just a trace message for now+       ; case tyConAppTyCon_maybe scrut_ty of+           Just tycon+                | debugIsOn+                , isAlgTyCon tycon+                , not (isAbstractTyCon tycon)+                , null (tyConDataCons tycon)+                , not (exprIsDeadEnd scrut)+                -> pprTrace "Lint warning: case scrutinee type has no constructors"+                        (ppr scrut_ty)+                          -- This can legitimately happen for type families+                        $ return ()+           _otherwise -> return ()+        }+  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 (Alt DEFAULT _ _) = False+    non_deflt _                 = True++    is_lit_alt (Alt (LitAlt _) _  _) = True+    is_lit_alt _                     = False++    is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of+                        Nothing    -> False+                        Just tycon -> isPrimTyCon tycon++lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv+lintAltExpr expr ann_ty+  = do { (actual_ty, ue) <- lintCoreExpr expr+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)+       ; return ue }+         -- See GHC.Core Note [Case expression invariants] item (6)++lintCoreAlt :: OutId         -- Case binder+            -> OutType       -- Type of scrutinee+            -> Mult          -- Multiplicity of scrutinee+            -> OutType       -- Type of the alternative+            -> CoreAlt+            -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) =+  do { lintL (null args) (mkDefaultArgsMsg args)+     ; rhs_ue <- lintAltExpr rhs alt_ty+     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr+           err_msg = vcat [ text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr+                          , ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult ]+     ; ensureSubUsage case_bndr_usage scrut_mult err_msg+     ; return rhs_ue' }++lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (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)+       ; rhs_ue <- lintAltExpr rhs alt_ty+       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks+       }+  where+    lit_ty = literalType lit++lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)+  | isNewTyCon (dataConTyCon con)+  = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty+  = addLoc (CaseAlt alt) $  do+    { checkTypeDataConOcc "pattern" con+    ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)++      -- Instantiate the universally quantified+      -- type variables of the data constructor+    ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys+          ; binderMult (Named _)   = ManyTy+          ; binderMult (Anon st _) = scaledMult st+          -- See Note [Validating multiplicities in a case]+          ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }++        -- And now bring the new binders into scope+    ; lintBinders CasePatBind args $ \ args' -> do+      { rhs_ue <- lintAltExpr rhs alt_ty+      ; rhs_ue' <- addLoc (CasePat alt) $+                   lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty+                                  (zipEqual multiplicities  args')+      ; return $ deleteUE rhs_ue' case_bndr+      }+   }++  | otherwise   -- Scrut-ty is wrong shape+  = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt)++{-+Note [Validating multiplicities in a case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'MkT :: a %m -> T m a'.+If we are validating 'case (x :: T Many a) of MkT y -> ...',+we have to substitute m := Many in the type of MkT - in particular,+y can be used Many times and that expression would still be linear in x.+We do this by looking at con_payload_ty, which is the type of the datacon+applied to the surrounding arguments.+Testcase: linear/should_compile/MultConstructor++Data constructors containing existential tyvars will then have+Named binders, which are always multiplicity Many.+Testcase: indexed-types/should_compile/GADT1+-}++lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()+lintLinearBinder doc actual_usage described_usage+  = ensureSubMult actual_usage described_usage err_msg+    where+      err_msg = (text "Multiplicity of variable does not agree with its context"+                $$ doc+                $$ ppr actual_usage+                $$ text "Annotation:" <+> ppr described_usage)++{-+************************************************************************+*                                                                      *+\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 :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> 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 :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a+lintBinder site var linterF+  | isTyCoVar var = lintTyCoBndr var linterF+  | otherwise     = lintIdBndr NotTopLevel site var linterF++lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a+lintTyCoBndr tcv thing_inside+  = do { tcv_type' <- lintTypeAndSubst (varType tcv)+       ; let tcv_kind' = typeKind tcv_type'++         -- See (FORALL1) and (FORALL2) in GHC.Core.Type+       ; if (isTyVar tcv)+         then -- Check that in (forall (a:ki). blah) we have ki:Type+              lintL (isLiftedTypeKind tcv_kind') $+              hang (text "TyVar whose kind does not have kind Type:")+                 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind')+         else -- Check that in (forall (cv::ty). blah),+              -- then ty looks like (t1 ~# t2)+              lintL (isCoVarType tcv_type') $+              text "CoVar with non-coercion type:" <+> pprTyVar tcv++       ; addInScopeTyCoVar tcv tcv_type' thing_inside }++lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a+lintIdBndrs top_lvl ids thing_inside+  = go ids thing_inside+  where+    go :: [Id] -> ([Id] -> LintM a) -> LintM a+    go []       thing_inside = thing_inside []+    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $ \id' ->+                               go ids                         $ \ids' ->+                               thing_inside (id' : 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 thing_inside+  = assertPpr (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)++          -- See Note [Representation polymorphism invariants] in GHC.Core+       ; lintL (isJoinId id || not (lf_check_fixed_rep flags)+                || typeHasFixedRuntimeRep id_ty) $+         text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+>+            parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))++       -- 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 id_ty))+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)++       -- Check that the lambda binder has no value or OtherCon unfolding.+       -- See #21496+       ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))+                (text "Lambda binder with value or OtherCon unfolding.")++       ; out_ty <- addLoc (IdTy id) (lintValueType id_ty)++       ; addInScopeId id out_ty thing_inside }+  where+    id_ty = idType id++    is_top_lvl = isTopLevel top_lvl+    is_let_bind = case bind_site of+                    LetBind -> True+                    _       -> False++{-+%************************************************************************+%*                                                                      *+             Types+%*                                                                      *+%************************************************************************+-}++{- Note [Linting types and coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that+   lintType     :: InType     -> LintM ()+   lintCoercion :: InCoercion -> LintM ()+Neither returns anything.++If you need the kind of the type, then do `typeKind` and then apply+the ambient substitution using `substTyM`.  Note that the substitution+empty unless there is shadowing or type-lets; and if the substitution is+empty, the `substTyM` is a no-op.++It is better to take the kind and then substitute, rather than substitute+and then take the kind, becaues the kind is usually smaller.++Note: you might wonder if we should apply the same logic to expressions.+Why do we have+  lintExpr :: InExpr -> LintM OutType+Partly inertia; but also taking the type of an expresison involve looking+down a deep chain of let's, whereas that is not true of taking the kind+of a type.  It'd be worth an experiment though.++Historical note: in the olden days we had+   lintType :: InType -> LintM OutType+but that burned a huge amount of allocation building an OutType that was+often discarded, or used only to get its kind.++I also experimented with+   lintType :: InType -> LintM OutKind+but that too was slower.  It is also much simpler to return ()!  If we+return the kind we have to duplicate the logic in `typeKind`; and it is+much worse for coercions.+-}++lintValueType :: Type -> LintM OutType+-- Types only, not kinds+-- Check the type, and apply the substitution to it+-- See Note [Linting type lets]+lintValueType ty+  = addLoc (InType ty) $+    do  { ty' <- lintTypeAndSubst ty+        ; let sk = typeKind ty'+        ; lintL (isTYPEorCONSTRAINT sk) $+          hang (text "Ill-kinded type:" <+> ppr ty)+             2 (text "has kind:" <+> ppr sk)+        ; return ty' }++checkTyCon :: TyCon -> LintM ()+checkTyCon tc+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)++-------------------+lintTypeAndSubst :: InType -> LintM OutType+lintTypeAndSubst ty = do { lintType ty; substTyM ty }+           -- In GHCi we may lint an expression with a free+           -- type variable.  Then it won't be in the+           -- substitution, but it should be in scope++lintType :: InType -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintType (TyVarTy tv)+  | not (isTyVar tv)+  = failWithL (mkBadTyVarMsg tv)++  | otherwise+  = do { _ <- lintVarOcc tv+       ; return () }++lintType ty@(AppTy t1 t2)+  | TyConApp {} <- t1+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty+  | otherwise+  = do { let (fun_ty, arg_tys) = collect t1 [t2]+       ; lintType fun_ty+       ; fun_kind <- substTyM (typeKind fun_ty)+       ; lint_ty_app ty fun_kind arg_tys }+  where+    collect (AppTy f a) as = collect f (a:as)+    collect fun         as = (fun, as)++lintType ty@(TyConApp tc tys)+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags+       ; lintTySynFamApp report_unsat ty tc tys }++  | Just {} <- tyConAppFunTy_maybe tc tys+    -- We should never see a saturated application of funTyCon; such+    -- applications should be represented with the FunTy constructor.+    -- See Note [Linting function types]+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty))++  | otherwise  -- Data types, data families, primitive types+  = do { checkTyCon tc+       ; lint_ty_app ty (tyConKind tc) tys }++-- arrows can related *unlifted* kinds, so this has to be separate from+-- a dependent forall.+lintType ty@(FunTy af tw t1 t2)+  = do { lintType t1+       ; lintType t2+       ; lintType tw+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) af t1 t2 tw }++lintType ty@(ForAllTy {})+  = go [] ty+  where+    go :: [OutTyCoVar] -> InType -> LintM ()+    -- Loop, collecting the forall-binders+    go tcvs ty@(ForAllTy (Bndr tcv _) body_ty)+      | not (isTyCoVar tcv)+      = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty)++      | otherwise+      = lintTyCoBndr tcv $ \tcv' ->+        do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]+             -- Suspicious because it works on InTyCoVar; c.f. ForAllCo+             when (isCoVar tcv) $+             lintL (anyFreeVarsOfType (== tcv) body_ty) $+             text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)++           ; go (tcv' : tcvs) body_ty }++    go tcvs body_ty+      = do { lintType body_ty+           ; lintForAllBody tcvs body_ty }++lintType (CastTy ty co)+  = do { lintType ty+       ; ty_kind <- substTyM (typeKind ty)+       ; co_lk <- lintStarCoercion co+       ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }++lintType (LitTy l)       = lintTyLit l+lintType (CoercionTy co) = lintCoercion co++-----------------+lintForAllBody :: [OutTyCoVar] -> InType -> LintM ()+-- Do the checks for the body of a forall-type+lintForAllBody tcvs body_ty+  = do { -- For type variables, check for skolem escape+         -- See Note [Phantom type variables in kinds] in GHC.Core.Type+         -- The kind of (forall cv. th) is liftedTypeKind, so no+         -- need to check for skolem-escape in the CoVar case+         body_kind <- substTyM (typeKind body_ty)+       ; case occCheckExpand tcvs body_kind of+           Just {} -> return ()+           Nothing -> failWithL $+                      hang (text "Variable escape in forall:")+                         2 (vcat [ text "tycovars (reversed):" <+> ppr tcvs+                                 , text "type:" <+> ppr body_ty+                                 , text "kind:" <+> ppr body_kind ])+       ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) }++-----------------+lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM ()+-- The TyCon is a type synonym or a type family (not a data family)+-- See Note [Linting type synonym applications]+-- c.f. GHC.Tc.Validity.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+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'+  = do { when report_unsat $ do { _ <- lintType expanded_ty+                                ; return () }++       ; -- Kind-check the argument types, but without reporting+         -- un-saturated type families/synonyms+       ; setReportUnsat False $+         lint_ty_app ty (tyConKind tc) tys }++  -- Otherwise this must be a type family+  | otherwise+  = lint_ty_app ty (tyConKind tc) tys++-----------------+-- Confirms that a kind is really TYPE r or Constraint+checkValueType :: OutKind -> SDoc -> LintM ()+checkValueType kind doc+  = lintL (isTYPEorCONSTRAINT kind)+          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$+           text "when checking" <+> doc)++-----------------+lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintArrow what af t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw+                            -- or lintArrow "coercion `blah'" k1 k2 kw+  = do { k1 <- substTyM (typeKind t1)+       ; k2 <- substTyM (typeKind t2)+       ; kw <- substTyM (typeKind tw)+       ; unless (isTYPEorCONSTRAINT k1) (report (text "argument")     t1 k1)+       ; unless (isTYPEorCONSTRAINT k2) (report (text "result")       t2 k2)+       ; unless (isMultiplicityTy kw)   (report (text "multiplicity") tw kw)++       ; let real_af = chooseFunTyFlag t1 t2+       ; unless (real_af == af) $ addErrL $+         hang (text "Bad FunTyFlag")+            2 (vcat [ text "FunTyFlag =" <+> ppr af+                    , text "Computed FunTyFlag =" <+> ppr real_af+                    , text "in" <+> what ]) }+  where+    report ar t k = addErrL (hang (text "Ill-kinded" <+> ar)+                                2 (vcat [ ppr t <+> dcolon <+> ppr k+                                        , text "in" <+> what ]))++-----------------+lintTyLit :: TyLit -> LintM ()+lintTyLit (NumTyLit n)+  | n >= 0    = return ()+  | otherwise = failWithL msg+    where msg = text "Negative type literal:" <+> integer n+lintTyLit (StrTyLit _) = return ()+lintTyLit (CharTyLit _) = return ()++-----------------+lint_ty_app :: InType -> OutKind -> [InType] -> LintM ()+lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty))++lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM ()+lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co))++lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM ()+lint_tyco_app msg fun_kind arg_tys+    -- See Note [Avoiding compiler perf traps when constructing error messages.]+  = do { _ <- lintApp msg (\ty     -> do { lintType ty; substTyM ty })+                            (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) })+                            fun_kind arg_tys ()+       ; return () }++----------------+lintApp :: forall in_a acc. Outputable in_a =>+             SDoc+          -> (in_a -> LintM OutType)                        -- Lint the thing and return its value+          -> (in_a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type+          -> OutType+          -> [in_a]                               -- The arguments, always "In" things+          -> acc                                  -- Used (only) for UsageEnv in /term/ applications+          -> LintM (OutType,acc)+-- lintApp is a performance-critical function, which deals with multiple+-- applications such as  (/\a./\b./\c. expr) @ta @tb @tc+-- When returning the type of this expression we want to avoid substituting a:=ta,+-- and /then/ substituting b:=tb, etc.  That's quadratic, and can be a huge+-- perf hole.  So we gather all the arguments [in_a], and then gather the+-- substitution incrementally in the `go` loop.+--+-- lintApp is used:+--    * for term applications (lintCoreArgs)+--    * for type applications (lint_ty_app)+--    * for coercion application (lint_co_app)+-- To deal with these cases `lintApp` has two higher order arguments;+-- but we specialise it for each call site (by inlining)+{-# INLINE lintApp #-}    -- INLINE: very few call sites;+                          -- not recursive; specialised at its call sites++lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc+    = do { !in_scope <- getInScope+         -- We need the in_scope set to satisfy the invariant in+         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst+         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.++         ; let init_subst = mkEmptySubst in_scope++               go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc)+                     -- The Subst applies (only) to the fun_ty+                     -- c.f. GHC.Core.Type.piResultTys, which has a similar loop++               go subst fun_ty acc []+                 = return (substTy subst fun_ty, acc)++               go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args)+                 = do { arg' <- lint_forall_arg arg+                      ; let tv_kind = substTy subst (varType tv)+                            karg'   = typeKind arg'+                            subst'  = extendTCvSubst subst tv arg'+                      ; ensureEqTys karg' tv_kind $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind))+                                2 (ppr arg' <+> dcolon <+> ppr karg'))+                      ; go subst' body_ty acc args }++               go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args)+                 = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc+                      ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Fun:" <+> ppr fun_ty)+                                2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty+                                        , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ]))+                      ; go subst res_ty acc' args }++               go subst fun_ty acc args+                 | Just fun_ty' <- coreView fun_ty+                 = go subst fun_ty' acc args++                 | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+                 = go init_subst (substTy subst fun_ty) acc args++                 | otherwise+                 = failWithL (lint_app_fail_msg msg orig_fun_ty all_args+                                  (text "Not a fun:" <+> (ppr fun_ty $$ ppr args)))++         ; go init_subst orig_fun_ty acc all_args }++-- This is a top level definition to ensure we pass all variables of the error message+-- explicitly and don't capture them as free variables. Otherwise this binder might+-- become a thunk that get's allocated in the hot code path.+-- See Note [Avoiding compiler perf traps when constructing error messages.]+lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc+lint_app_fail_msg msg kfn arg_tys extra+  = vcat [ hang (text "Application error in") 2 msg+         , nest 2 (text "Function type =" <+> ppr kfn)+         , nest 2 (text "Args =" <+> ppr arg_tys)+         , extra ]++{- *********************************************************************+*                                                                      *+        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, zeroUE) args+       ; (rhs_ty, _) <- case idJoinPointHood fun of+                     JoinPoint 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 GHC.Core.Rules+    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)+                    && bndr `elemVarSet` rhs_fvs+                    && isNothing (isReflCoVar_maybe bndr)+++{- Note [Linting rules]+~~~~~~~~~~~~~~~~~~~~~~~+It's very bad if simplifying a rule means that one of the template+variables (ru_bndrs) that /is/ mentioned on the RHS becomes+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,+SpecConstr stupidly constructed a rule like++  forall x,c1,c2.+     f (x |> c1 |> c2) = ....++But simplExpr collapses those coercions into one.  (Indeed in #10602,+it collapsed to the identity and was removed altogether.)++We don't have a great story for what to do here, but at least+this check will nail it.++NB (#11643): it's possible that a variable listed in the+binders becomes not-mentioned on both LHS and RHS.  Here's a silly+example:+   RULE forall x y. f (g x y) = g (x+1) (y-1)+And suppose worker/wrapper decides that 'x' is Absent.  Then+we'll end up with+   RULE forall x y. f ($gw y) = $gw (x+1)+This seems sufficiently obscure that there isn't enough payoff to+try to trim the forall'd binder list.++Note [Rules for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point cannot be partially applied. However, the left-hand side of a rule+for a join point is effectively a *pattern*, not a piece of code, so there's an+argument to be made for allowing a situation like this:++  join $sj :: Int -> Int -> String+       $sj n m = ...+       j :: forall a. Eq a => a -> a -> String+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}+       j @a $dEq x y = ...++Applying this rule can't turn a well-typed program into an ill-typed one, so+conceivably we could allow it. But we can always eta-expand such an+"undersaturated" rule (see 'GHC.Core.Opt.Arity.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 [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion.+-}++{-+************************************************************************+*                                                                      *+         Linting coercions+*                                                                      *+************************************************************************+-}++{- Note [Asymptotic efficiency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting coercions (and types actually) we return a linted+(substituted) coercion.  Then we often have to take the coercionKind of+that returned coercion. If we get long chains, that can be asymptotically+inefficient, notably in+* TransCo+* InstCo+* SelCo (cf #9233)+* LRCo++But the code is simple.  And this is only Lint.  Let's wait to see if+the bad perf bites us in practice.++A solution would be to return the kind and role of the coercion,+as well as the linted coercion.  Or perhaps even *only* the kind and role,+which is what used to happen.   But that proved tricky and error prone+(#17923), so now we return the coercion.+-}+++-- lintStarCoercion lints a coercion, confirming that its lh kind and+-- its rh kind are both *; also ensures that the role is Nominal+-- Returns the lh kind+lintStarCoercion :: InCoercion -> LintM OutType+lintStarCoercion g+  = do { lintCoercion g+       ; Pair t1 t2 <- substCoKindM g+       ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g)+       ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g)+       ; lintRole g Nominal (coercionRole g)+       ; return t1 }++substCoKindM :: InCoercion -> LintM (Pair OutType)+substCoKindM co+  = do { let !(Pair lk rk) = coercionKind co+       ; lk' <- substTyM lk+       ; rk' <- substTyM rk+       ; return (Pair lk' rk') }++lintCoercion :: HasDebugCallStack => InCoercion -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]++lintCoercion (CoVarCo cv)+  | not (isCoVar cv)+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)+                  2 (text "With offending type:" <+> ppr (varType cv)))++  | otherwise  -- C.f. lintType (TyVarTy tv), which has better docs+  = do { _ <- lintVarOcc cv; return () }++lintCoercion (Refl ty)          = lintType ty+lintCoercion (GRefl _r ty MRefl) = lintType ty++lintCoercion (GRefl _r ty (MCo co))+  = do { lintType ty+       ; lintCoercion co+       ; tk <- substTyM (typeKind ty)+       ; tl <- substTyM (coercionLKind co)+       ; ensureEqTys tk tl $+         hang (text "GRefl coercion kind mis-match:" <+> ppr co)+            2 (vcat [ppr ty, ppr tk, ppr tl])+       ; lintRole co Nominal (coercionRole co) }++lintCoercion co@(TyConAppCo r tc cos)+  | Just {} <- tyConAppFunCo_maybe r tc cos+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc))+                  2 (ppr co))+    -- All saturated TyConAppCos should be FunCos++  | Just {} <- synTyConDefn_maybe tc+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)++  | otherwise+  = do { checkTyCon tc+       ; mapM_ lintCoercion cos+       ; let tc_kind = tyConKind tc+       ; lint_co_app co tc_kind (map coercionLKind cos)+       ; lint_co_app co tc_kind (map coercionRKind cos)+       ; zipWithM_ (lintRole co) (tyConRoleListX r tc) (map coercionRole cos) }+++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 { lintCoercion co1+       ; lintCoercion co2+       ; let !(Pair lt1 rt1) = coercionKind co1+       ; lk1 <- substTyM (typeKind lt1)+       ; rk1 <- substTyM (typeKind rt1)+       ; lint_co_app co lk1 [coercionLKind co2]+       ; lint_co_app co rk1 [coercionRKind co2]++       ; let r2 = coercionRole co2+       ; if coercionRole co1 == Phantom+         then lintL (r2 == Phantom || r2 == Nominal)+                     (text "Second argument in AppCo cannot be R:" $$+                      ppr co)+         else lintRole co Nominal r2 }++----------+lintCoercion co@(ForAllCo {})+-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo+  = do { _ <- go [] co; return () }+  where+    go :: [OutTyCoVar]   -- Binders in reverse order+       -> InCoercion -> LintM Role+    go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = body_co })+      | not (isTyCoVar tcv)+      = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)++      | otherwise+      = do { lk <- lintStarCoercion kind_co+           ; lintTyCoBndr tcv $ \tcv' ->+        do { ensureEqTys (varType tcv') lk $+             text "Kind mis-match in ForallCo" <+> ppr co++           -- I'm not very sure about this part, because it traverses body_co+           -- but at least it's on a cold path (a ForallCo for a CoVar)+           -- Also it works on InTyCoVar and InCoercion, which is suspect+           ; when (isCoVar tcv) $+             do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $+                  text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co+                  -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+                ; lintL (almostDevoidCoVarOfCo tcv body_co) $+                  text "Covar can only appear in Refl and GRefl: " <+> ppr co }+                  -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep++           ; role <- go (tcv':tcvs) body_co++           ; when (role == Nominal) $+             lintL (visL `eqForAllVis` visR) $+             text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co++           ; return role } }++    go tcvs body_co+      = do { lintCoercion body_co++           -- Need to check that+           --    (forall (tcv:k1). lty) and+           --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])+           -- are both well formed, including the skolem escape check.+           -- Easiest way is to call lintForAllBody for each+           ; let Pair lty rty = coercionKind body_co+           ; lintForAllBody tcvs lty+           ; lintForAllBody tcvs rty++           ; return (coercionRole body_co) }+++lintCoercion (FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+                    , fco_mult = cow, fco_arg = co1, fco_res = co2 })+  = do { lintCoercion co1+       ; lintCoercion co2+       ; lintCoercion cow+       ; let Pair lt1 rt1 = coercionKind co1+             Pair lt2 rt2 = coercionKind co2+             Pair ltw rtw = coercionKind cow+       ; lintArrow (bad_co_msg "arrowl") afl lt1 lt2 ltw+       ; lintArrow (bad_co_msg "arrowr") afr rt1 rt2 rtw+       ; lintRole co1 r (coercionRole co1)+       ; lintRole co2 r (coercionRole co2)+       ; let expected_mult_role = case r of+                                    Phantom -> Phantom+                                    _ -> Nominal+       ; lintRole cow expected_mult_role (coercionRole cow) }+  where+    bad_co_msg s = hang (text "Bad coercion" <+> parens (text s))+                      2 (vcat [ text "afl:" <+> ppr afl+                              , text "afr:" <+> ppr afr+                              , text "arg_co:" <+> ppr co1+                              , text "res_co:" <+> ppr co2 ])++-- See Note [Bad unsafe coercion]+lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov+                        , uco_lty = ty1, uco_rty = ty2, uco_deps = deps })+  = do { -- Check the role.  PhantomProv must have Phantom role, otherwise any role is fine+         case prov of+            PhantomProv -> lintRole co Phantom r+            _           -> return ()++       -- Check the to and from types+       ; lintType ty1+       ; lintType ty2+       ; tk1 <- substTyM (typeKind ty1)+       ; tk2 <- substTyM (typeKind ty2)++       ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2)+              (checkTypes ty1 ty2)++       -- Check the coercions on which this UnivCo depends+       ; mapM_ lintCoercion deps }+   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 fixed_rep_1+                         (report "left-hand type does not have a fixed runtime representation")+            ; checkWarnL fixed_rep_2+                         (report "right-hand type does not have a fixed runtime representation")+            ; when (fixed_rep_1 && fixed_rep_2) $+              do { checkWarnL (reps1 `equalLength` reps2)+                              (report "between values with different # of reps")+                 ; zipWithM_ validateCoercion reps1 reps2 }}+       where+         fixed_rep_1 = typeHasFixedRuntimeRep t1+         fixed_rep_2 = typeHasFixedRuntimeRep 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 { platform <- getPlatform+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)+                         (report "between unboxed and boxed value")+            ; checkWarnL (TyCon.primRepSizeB platform rep1+                           == TyCon.primRepSizeB platform 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 ()+            }++lintCoercion (SymCo co) = lintCoercion co++lintCoercion co@(TransCo co1 co2)+  = do { lintCoercion co1+       ; lintCoercion co2+       ; rk1 <- substTyM (coercionRKind co1)+       ; lk2 <- substTyM (coercionLKind co2)+       ; ensureEqTys rk1 lk2+               (hang (text "Trans coercion mis-match:" <+> ppr co)+                   2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)]))+       ; lintRole co (coercionRole co1) (coercionRole co2) }++lintCoercion the_co@(SelCo cs co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co++       ; if -- forall (both TyVar and CoVar)+            | Just _ <- splitForAllTyCoVar_maybe s+            , Just _ <- splitForAllTyCoVar_maybe t+            , SelForAll <- cs+            ,   (isForAllTy_ty s && isForAllTy_ty t)+             || (isForAllTy_co s && isForAllTy_co t)+            -> return ()++            -- function+            | isFunTy s+            , isFunTy t+            , SelFun {} <- cs+            -> return ()++            -- TyCon+            | Just (tc_s, tys_s) <- splitTyConApp_maybe s+            , Just (tc_t, tys_t) <- splitTyConApp_maybe t+            , tc_s == tc_t+            , SelTyCon n r0 <- cs+            , let co_role = coercionRole co+            , isInjectiveTyCon tc_s co_role+                -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+            , tys_s `equalLength` tys_t+            , tys_s `lengthExceeds` n+            -> do { lintRole the_co (tyConRole co_role tc_s n) r0+                  ; return () }++            | otherwise+            -> failWithL (hang (text "Bad SelCo:")+                             2 (ppr the_co $$ ppr s $$ ppr t)) }++lintCoercion the_co@(LRCo _lr co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co+       ; lintRole co Nominal (coercionRole co)+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of+           (Just {}, Just {}) -> return ()+           _ -> failWithL (hang (text "Bad LRCo:")+                              2 (ppr the_co $$ ppr s $$ ppr t)) }+++lintCoercion orig_co@(InstCo co arg)+  = go co [arg]+  where+    go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) }+    go co              args = do { lintCoercion co+                                 ; let Pair lty rty = coercionKind co+                                 ; lty' <- substTyM lty+                                 ; rty' <- substTyM rty+                                 ; in_scope <- getInScope+                                 ; let subst = mkEmptySubst in_scope+                                 ; go_args (subst, lty') (subst,rty') args }++    -------------+    go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion]+           -> LintM ()+    go_args _ _ []+      = return ()+    go_args lty rty (arg:args)+      = do { (lty1, rty1)  <- go_arg lty rty arg+           ; go_args lty1 rty1 args }++    -------------+    go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion+           -> LintM ((Subst,OutType), (Subst,OutType))+    go_arg (lsubst,lty) (rsubst,rty) arg+      = do { lintRole arg Nominal (coercionRole arg)+           ; Pair arg_lty arg_rty <- substCoKindM arg++           ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of+              -- forall over tvar+                (Just (ltv,lty1), Just (rtv,rty1))+                  | typeKind arg_lty `eqType` substTy lsubst (tyVarKind ltv)+                  , typeKind arg_rty `eqType` substTy rsubst (tyVarKind rtv)+                  -> return ( (extendTCvSubst lsubst ltv arg_lty, lty1)+                            , (extendTCvSubst rsubst rtv arg_rty, rty1) )+                  | otherwise+                  -> failWithL (hang (text "Kind mis-match in inst coercion")+                                   2 (vcat [ text "arg"  <+> ppr arg+                                           , text "lty"  <+> ppr lty <+> dcolon <+> ppr (typeKind lty)+                                           , text "rty"  <+> ppr rty <+> dcolon <+> ppr (typeKind rty)+                                           , text "arg_lty" <+> ppr arg_lty <+> dcolon <+> ppr (typeKind arg_lty)+                                           , text "arg_rty" <+> ppr arg_rty <+> dcolon <+> ppr (typeKind arg_rty)+                                           , text "ltv" <+> ppr ltv <+> dcolon <+> ppr (tyVarKind ltv)+                                           , text "rtv" <+> ppr rtv <+> dcolon <+> ppr (tyVarKind rtv) ]))++                _ -> failWithL (text "Bad argument of inst" <+> ppr orig_co) }++lintCoercion this_co@(AxiomCo ax cos)+  = do { mapM_ lintCoercion cos+       ; lint_roles 0 (coAxiomRuleArgRoles ax) cos+       ; prs <- mapM substCoKindM cos+       ; lint_ax ax prs }++  where+    lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM ()+    lint_ax (BuiltInFamRew  bif) prs+      = checkL (isJust (bifrw_proves bif prs))  bad_bif+    lint_ax (BuiltInFamInj bif) prs+      = checkL (case prs of+                  [pr] -> isJust (bifinj_proves bif pr)+                  _    -> False)+               bad_bif+    lint_ax (UnbranchedAxiom ax) prs+      = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs+    lint_ax (BranchedAxiom ax ind) prs+      = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax))+                    (bad_ax this_co (text "index out of range"))+           ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs }++    bad_bif = bad_ax this_co (text "Proves returns Nothing")++    err :: forall a. String -> [SDoc] -> LintM a+    err m xs  = failWithL $+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs)++    lint_roles n (e : es) (co:cos)+      | e == coercionRole co+      = lint_roles (n+1) es cos+      | otherwise = err "Argument roles mismatch"+                        [ text "In argument:" <+> int (n+1)+                        , text "Expected:" <+> ppr e+                        , text "Found:" <+> ppr (coercionRole co) ]+    lint_roles _ [] []  = return ()+    lint_roles n [] rs  = err "Too many coercion arguments"+                            [ text "Expected:" <+> int n+                            , text "Provided:" <+> int (n + length rs) ]++    lint_roles n es []  = err "Not enough coercion arguments"+                            [ text "Expected:" <+> int (n + length es)+                            , text "Provided:" <+> int n ]++lintCoercion (KindCo co) = lintCoercion co++lintCoercion (SubCo co)+  = do { lintCoercion co+       ; lintRole co Nominal (coercionRole co) }++lintCoercion (HoleCo h)+  = failWithL (text "Unfilled coercion hole:" <+> ppr h)++{-+Note [Conflict checking for axiom applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following type family and axiom:++type family Equal (a :: k) (b :: k) :: Bool+type instance where+  Equal a a = True+  Equal a b = False+--+Equal :: forall k::*. k -> k -> Bool+axEqual :: { forall k::*. forall a::k. Equal k a a ~ True+           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }++The coercion (axEqual[1] <*> <Int> <Int) is ill-typed, and Lint should reject it.+(Recall that the index is 0-based, so this is the second branch of the axiom.)+The problem is that, on the surface, it seems that++  (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False)++and that all is OK. But, all is not OK: we want to use the first branch of the+axiom in this case, not the second. The problem is that the parameters of the+first branch can unify with the supplied coercions, thus meaning that the first+branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv".++For more details, see the section "Branched axiom conflict checking" in+docs/core-spec, which defines the corresponding no_conflict function used by the+Co_AxiomInstCo rule in the section "Coercion typing".+-}++-- | Check to make sure that an axiom application is internally consistent.+-- Returns the conflicting branch, if it exists+-- Note [Conflict checking for axiom applications]+lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM ()+-- defined here to avoid dependencies in GHC.Core.Coercion+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+lintBranch this_co fam_tc branch arg_kinds+  | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch+  = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $+                (bad_ax this_co (text "lengths"))++       ; subst <- getSubst+       ; let empty_subst = zapSubst subst+       ; _ <- foldlM check_ki (empty_subst, empty_subst)+                              (zip (ktvs ++ cvs) arg_kinds)++       ; case check_no_conflict target incomps of+            Nothing -> return ()+            Just bad_branch -> failWithL $ bad_ax this_co $+                               text "inconsistent with" <+>+                                 pprCoAxBranch fam_tc bad_branch }+  where+    check_ki (subst_l, subst_r) (ktv, Pair s' t')+      = do { let sk' = typeKind s'+                 tk' = typeKind t'+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)+           ; checkL (sk' `eqType` ktv_kind_l)+                    (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))+           ; checkL (tk' `eqType` ktv_kind_r)+                    (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))+           ; return (extendTCvSubst subst_l ktv s',+                     extendTCvSubst subst_r ktv t') }++    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    incomps      = coAxBranchIncomps branch+    (tys, cotys) = splitAtList tvs (map pFst arg_kinds)+    co_args      = map stripCoercionTy cotys+    subst        = zipTvSubst tvs tys `composeTCvSubst`+                   zipCvSubst cvs co_args+    target   = Type.substTys subst (coAxBranchLHS branch)++    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch+    check_no_conflict _    [] = Nothing+    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)+         -- See Note [Apartness] in GHC.Core.FamInstEnv+      | SurelyApart <- tcUnifyTysFG alwaysBindFam alwaysBindTv flat lhs_incomp+      = check_no_conflict flat rest+      | otherwise+      = Just b++bad_ax :: Coercion -> SDoc -> SDoc+bad_ax this_co what+    = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co)+++{-+************************************************************************+*                                                                      *+              Axioms+*                                                                      *+************************************************************************+-}++lintAxioms :: Logger+           -> LintConfig+           -> SDoc -- ^ The source of the linted axioms+           -> [CoAxiom Branched]+           -> IO ()+lintAxioms logger cfg what axioms =+  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $+  initL cfg $+  do { mapM_ lint_axiom axioms+     ; let axiom_groups = groupWith coAxiomTyCon axioms+     ; mapM_ lint_axiom_group axiom_groups }++lint_axiom :: CoAxiom Branched -> LintM ()+lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches+                       , co_ax_role = ax_role })+  = addLoc (InAxiom ax) $+    do { mapM_ (lint_branch tc) branch_list+       ; extra_checks }+  where+    branch_list = fromBranches branches++    extra_checks+      | isNewTyCon tc+      = do { CoAxBranch { cab_tvs     = ax_tvs+                        , cab_eta_tvs = eta_tvs+                        , cab_cvs     = cvs+                        , cab_roles   = roles+                        , cab_lhs     = lhs_tys }+              <- case branch_list of+               [branch] -> return branch+               _        -> failWithL (text "multi-branch axiom with newtype")++           -- The LHS of the axiom is (N lhs_tys)+           -- We expect it to be      (N ax_tvs)+           ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)+                   (text "Newtype axiom LHS does not match newtype definition")+           ; lintL (null cvs)+                   (text "Newtype axiom binds coercion variables")+           ; lintL (null eta_tvs)  -- See Note [Eta reduction for data families]+                                   -- which is not about newtype axioms+                   (text "Newtype axiom has eta-tvs")+           ; lintL (ax_role == Representational)+                   (text "Newtype axiom role not representational")+           ; lintL (roles `equalLength` ax_tvs)+                   (text "Newtype axiom roles list is the wrong length." $$+                    text "roles:" <+> sep (map ppr roles))+           ; lintL (roles == takeList roles (tyConRoles tc))+                   (vcat [ text "Newtype axiom roles do not match newtype tycon's."+                         , text "axiom roles:" <+> sep (map ppr roles)+                         , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ])+           }++      | isFamilyTyCon tc+      = do { if | isTypeFamilyTyCon tc+                  -> lintL (ax_role == Nominal)+                           (text "type family axiom is not nominal")++                | isDataFamilyTyCon tc+                  -> lintL (ax_role == Representational)+                           (text "data family axiom is not representational")++                | otherwise+                  -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc)++           ; mapM_ (lint_family_branch tc) branch_list }++      | otherwise+      = addErrL (text "Axiom tycon is neither a newtype nor a family.")++lint_branch :: TyCon -> CoAxBranch -> LintM ()+lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                              , cab_lhs = lhs_args, cab_rhs = rhs })+  = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->+    do { let lhs = mkTyConApp ax_tc lhs_args+       ; lintType lhs+       ; lintType rhs+       ; lhs_kind <- substTyM (typeKind lhs)+       ; rhs_kind <- substTyM (typeKind rhs)+       ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $+         hang (text "Inhomogeneous axiom")+            2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$+               text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }+         -- Type and Constraint are not Apart, so this test allows+         -- the newtype axiom for a single-method class.  Indeed the+         -- whole reason Type and Constraint are not Apart is to allow+         -- such axioms!++-- these checks do not apply to newtype axioms+lint_family_branch :: TyCon -> CoAxBranch -> LintM ()+lint_family_branch fam_tc br@(CoAxBranch { cab_tvs     = tvs+                                         , cab_eta_tvs = eta_tvs+                                         , cab_cvs     = cvs+                                         , cab_roles   = roles+                                         , cab_lhs     = lhs+                                         , cab_incomps = incomps })+  = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs)+               (text "Type family axiom has eta-tvs")+       ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs)+               (text "Quantified variable in family axiom unused in LHS")+       ; lintL (all isTyFamFree lhs)+               (text "Type family application on LHS of family axiom")+       ; lintL (all (== Nominal) roles)+               (text "Non-nominal role in family axiom" $$+                text "roles:" <+> sep (map ppr roles))+       ; lintL (null cvs)+               (text "Coercion variables bound in family axiom")+       ; forM_ incomps $ \ br' ->+           lintL (not (compatibleBranches br br')) $+           hang (text "Incorrect incompatible branches:")+              2 (vcat [text "Branch:"       <+> ppr br,+                       text "Bogus incomp:" <+> ppr br']) }++lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()+lint_axiom_group (_  :| []) = return ()+lint_axiom_group (ax :| axs)+  = do { lintL (isOpenFamilyTyCon tc)+               (text "Non-open-family with multiple axioms")+       ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs+                                      , ax2 <- all_axs ]+       ; mapM_ (lint_axiom_pair tc) all_pairs }+  where+    all_axs = ax : axs+    tc      = coAxiomTyCon ax++lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()+lint_axiom_pair tc (ax1, ax2)+  | Just br1@(CoAxBranch { cab_tvs = tvs1+                         , cab_lhs = lhs1+                         , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1+  , Just br2@(CoAxBranch { cab_tvs = tvs2+                         , cab_lhs = lhs2+                         , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2+  = lintL (compatibleBranches br1 br2) $+    vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2+                , text "are incompatible" ]+         , text "tvs1 =" <+> pprTyVars tvs1+         , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1)+         , text "rhs1 =" <+> ppr rhs1+         , text "tvs2 =" <+> pprTyVars tvs2+         , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2)+         , text "rhs2 =" <+> ppr rhs2 ]++  | otherwise+  = addErrL (text "Open type family axiom has more than one branch: either" <+>+             ppr ax1 <+> text "or" <+> ppr ax2)++{-+************************************************************************+*                                                                      *+\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 :: Subst+                  -- Current substitution, for TyCoVars only.+                  -- Non-CoVar Ids don't appear in here, not even in the InScopeSet+                  -- Used for (a) cloning to avoid shadowing of TyCoVars,+                  --              so that eqType works ok+                  --          (b) substituting for let-bound tyvars, when we have+                  --              (let @a = Int -> Int in ...)++       , le_in_vars :: VarEnv (InVar, OutType)+                    -- Maps an InVar (i.e. its unique) to its binding InVar+                    --    and to its OutType+                    -- /All/ in-scope variables are here (term variables,+                    --    type variables, and coercion variables)+                    -- Used at an occurrence of the InVar++       , le_joins :: IdSet     -- Join points in scope that are valid+                               -- A subset of the InScopeSet in le_subst+                               -- See Note [Join points]++       , le_ue_aliases :: NameEnv UsageEnv+             -- See Note [Linting linearity]+             -- Assigns usage environments to the alias-like binders,+             -- as found in non-recursive lets.+             -- Domain is OutIds++       , le_platform   :: Platform         -- ^ Target platform+       , le_diagOpts   :: DiagOpts         -- ^ Target platform+       }++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]+       , lf_check_linearity :: Bool -- ^ See Note [Linting linearity]+       , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]+    }++-- 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++newtype LintM a =+   LintM' { unLintM ::+            LintEnv ->+            WarnsAndErrs ->           -- Warning and error messages so far+            LResult a } -- Result and messages (if any)+++pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern LintM m <- LintM' m+  where+    LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we)+    -- LintM m = LintM' (oneShot $ oneShot m)+{-# COMPLETE LintM #-}++instance Functor (LintM) where+  fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w)++type WarnsAndErrs = (Bag SDoc, Bag SDoc)++-- Using a unboxed tuple here reduced allocations for a lint heavy+-- file by ~6%. Using MaybeUB reduced them further by another ~12%.+--+-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes+-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which+-- contains gigantic types) is very very slow indeed. Conclusion: make+-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile+-- Lint.hs with optimistation on.+type LResult a = (# MaybeUB a, WarnsAndErrs #)++pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a+pattern LResult m w = (# m, w #)+{-# COMPLETE LResult #-}++mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2+mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w++-- Just for testing.+fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a+fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs+fromBoxedLResult (Nothing,errs) = LResult NothingUB errs++{- Note [Checking for global Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before CoreTidy, all locally-bound Ids must be LocalIds, even+top-level ones. See Note [Exported LocalIds] and #9857.++Note [Checking StaticPtrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.++Every occurrence of the function 'makeStatic' should be moved to the+top level by the FloatOut pass.  It's vital that we don't have nested+'makeStatic' occurrences after CorePrep, because we populate the Static+Pointer Table from the top-level bindings. See SimplCore Note [Grand+plan for static forms].++The linter checks that no occurrence is left behind, nested within an+expression. The check is enabled only after the FloatOut, CorePrep,+and CoreTidy passes and only if the module uses the StaticPointers+language extension. Checking more often doesn't help since the condition+doesn't hold until after the first FloatOut pass.++Note [Type substitution]+~~~~~~~~~~~~~~~~~~~~~~~~+Why do we need a type substitution?  Consider+        /\(a:*). \(x:a). /\(a:*). id a x+This is ill typed, because (renaming variables) it is really+        /\(a:*). \(x:a). /\(b:*). id b x+Hence, when checking an application, we can't naively compare x's type+(at its binding site) with its expected type (at a use site).  So we+rename type binders as we go, maintaining a substitution.++The same substitution also supports let-type, current expressed as+        (/\(a:*). body) ty+Here we substitute 'ty' for 'a' in 'body', on the fly.++Note [Linting type synonym applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting a type-synonym, or type-family, application+  S ty1 .. tyn+we behave as follows (#15057, #T15664):++* If lf_report_unsat_syns = True, and S has arity < n,+  complain about an unsaturated type synonym or type family++* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.++  Reason: catch out of scope variables or other ill-kinded gubbins,+  even if S discards that argument entirely. E.g. (#15012):+     type FakeOut a = Int+     type family TF a+     type instance TF Int = FakeOut a+  Here 'a' is out of scope; but if we expand FakeOut, we conceal+  that out-of-scope error.++  Reason for switching off lf_report_unsat_syns: with+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they+  are saturated when the type is expanded. Example+     type T f = f Int+     type S a = a -> a+     type Z = T S+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.++* If lf_report_unsat_syns is on, expand the synonym application and+  lint the result.  Reason: want to check that synonyms are saturated+  when the type is expanded.++Note [Linting linearity]+~~~~~~~~~~~~~~~~~~~~~~~~+Lint ignores linearity unless `-dlinear-core-lint` is set.  For why, see below.++* When do we /check linearity/ in Lint?  That is, when is `-dlinear-core-lint`+  lint set?  Answer: we check linearity in the output of the desugarer, shortly+  after type checking.++* When so we /not/ check linearity in Lint?  On all passes after desugaring.  Why?+  Because optimisation passes are not (yet) guaranteed to maintain linearity.+  They should do so semantically (GHC is careful not to duplicate computation)+  but it is much harder to ensure that the statically-checkable constraints of+  Linear Core are maintained. See examples below.++The current Linear Core is described in the wiki at:+https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.++Concretely, "ignore linearity in Lint" specifically means two things:+* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`+* In `ensureSubMult`, do nothing++Here are some examples of how the optimiser can break linearity checking.  Other+examples are documented in the linear-type implementation wiki page+[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]++* EXAMPLE 1: the binder swap transformation+    Consider++      data T = MkT {-# UNPACK #-} !Int++    The wrapper for MkT is++      $wMkT :: Int %1 -> T+      $wMkT n = case %1 n of+        I# n' -> MkT n'++    This introduces, in particular, a `case %1` (this is not actual Haskell or+    Core syntax), where the `%1` means that the `case` expression consumes its+    scrutinee linearly.++    Now, `case %1` interacts with the binder swap optimisation in a non-trivial+    way. Take a slightly modified version of the code for $wMkT:++      case %1 x of z {+        I# n' -> (x, n')+      }++    Binder-swap changes this to++      case %1 x of z {+        I# n' -> let x = z in (x, n')+      }++    This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly+    2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees+    two uses of n' where there should be a single one.++* EXAMPLE 2: letrec+    Some optimisations can create a letrec which uses a variable+    linearly, e.g.++      letrec f True = f False+             f False = x+      in f True++    uses 'x' linearly, but this is not seen by the linter, which considers,+    conservatively, that a letrec always has multiplicity Many (in particular+    that every captured free variable must have multiplicity Many). This issue+    is discussed in ticket #18694.++* EXAMPLE 3: rewrite rules+    Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be+    treated the same by rewrite rules (see also Note [Rewrite rules ignore+    multiplicities in FunTy] in GHC.Core.Unify). Consider++      m :: Bool -> A+      m' :: (Bool -> Bool) -> A+      {- RULES "ex" forall f. m (f True) = m' f -}++      f :: Bool %1 -> A+      x = m (f True)++    The rule "ex" must match . So the linter must accept `m' f`.++* EXAMPLE 4: eta-reduction+   Eta-expansion can change linear functions into unrestricted functions++     f :: A %1 -> B++     g :: A %Many -> B+     g = \x -> f x++   Eta-reduction undoes this and produces:++     g :: A %Many -> B+     g = f++Historical note: In the original linear-types implementation, we had tried to+make every optimisation pass produce code that passes `-dlinear-core-lint`. It+had proved very difficult. We kept finding corner case after corner+case. Furthermore, to attempt to achieve that goal we ended up restricting+transformations when `-dlinear-core-lint` couldn't typecheck the result.++In the future, we may be able to lint the linearity of the output of+Core-to-Core passes (#19165). But this shouldn't be done at the expense of+producing efficient code. Therefore we lay the following principle.++PRINCIPLE: The type system bends to the optimisation, not the other way around.++There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123++Note [Linting representation-polymorphic builtins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Representation-polymorphism checking built-ins], on+top of the two main representation-polymorphism invariants described in the+Note [Representation polymorphism invariants], we must perform additional+representation-polymorphism checks on builtin functions which don't have a+binding, for example to ensure that we don't run afoul of the+representation-polymorphism invariants when eta-expanding.++There are two situations:++  1. Builtins which have skolem type variables which must be instantiated to+     concrete types, such as the RuntimeRep type argument r to the catch# primop.++  2. Representation-polymorphic unlifted newtypes, which must always be instantiated+     at a fixed runtime representation.++For 1, consider for example 'coerce':++  coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b++We store in the IdDetails of the coerce Id that the first binder, r, must always+be instantiated to a concrete type. We thus check this in Core Lint: whenever we+see an application of the form++  coerce @{rep1} ...++we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".+Moreover, not instantiating these type variables at all is also an error, as+we would again not be able to perform eta-expansion. (This is a bit more theoretical,+as in user programs the typechecker will insert these type applications when+instantiating, but it can still arise when constructing Core expressions).++For 2, whenever we have an unlifted newtype such as++  type RR :: Type -> RuntimeRep+  type family RR a++  type F :: forall (a :: Type) -> TYPE (RR a)+  type family F a++  type N :: forall (a :: Type) -> TYPE (RR a)+  newtype N a = MkN (F a)++and an unsaturated occurrence++  MkN @ty -- NB: no value argument!++we check that the (instantiated) argument type has a fixed runtime representation.+This is done in the function "checkRepPolyNewtypeApp".+-}++instance Applicative LintM where+      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs+                                   --(Just x, errs)+      (<*>) = ap++instance Monad LintM where+  m >>= k  = LintM (\ env errs ->+                       let res = unLintM m env errs in+                         case res of+                           LResult (JustUB r) errs' -> unLintM (k r) env errs'+                           LResult NothingUB errs' -> LResult NothingUB errs'+                    )+                          --  LError errs'-> LError errs')+                      --  let (res, errs') = unLintM m env errs in+                          --  Just r -> unLintM (k r) env errs'+                          --  Nothing -> (Nothing, errs'))++instance MonadFail LintM where+    fail err = failWithL (text err)++getPlatform :: LintM Platform+getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs))++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | OccOf Id            -- Occurrence of id+  | LambdaBodyOf Id     -- The lambda-binder+  | RuleOf Id           -- Rules attached to a binder+  | UnfoldingOf Id      -- Unfolding of a binder+  | BodyOfLet Id        -- The let-bound variable+  | BodyOfLetRec [Id]   -- The binders of the let+  | CaseAlt CoreAlt     -- Case alternative+  | CasePat CoreAlt     -- The *pattern* of the case alternative+  | CaseTy CoreExpr     -- The type field of a case expression+                        -- with this scrutinee+  | IdTy Id             -- The type field of an Id binder+  | AnExpr CoreExpr     -- Some expression+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)+  | TopLevelBindings+  | InType Type         -- Inside a type+  | InCo   Coercion     -- Inside a coercion+  | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom++data LintConfig = LintConfig+  { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts+  , l_platform   :: !Platform         -- ^ Target platform+  , l_flags      :: !LintFlags        -- ^ Linting the result of this pass+  , l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope+  }++initL :: LintConfig+      -> LintM a            -- ^ Action to run+      -> WarnsAndErrs+initL cfg m+  = case unLintM m env (emptyBag, emptyBag) of+      LResult (JustUB _) errs -> errs+      LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs+                                    | otherwise -> pprPanic ("Bug in Lint: a failure occurred " +++                                                      "without reporting an error message") empty+  where+    vars = l_vars cfg+    env = LE { le_flags   = l_flags cfg+             , le_subst   = mkEmptySubst (mkInScopeSetList vars)+             , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]+             , le_joins   = emptyVarSet+             , le_loc     = []+             , le_ue_aliases = emptyNameEnv+             , le_platform = l_platform cfg+             , le_diagOpts = l_diagOpts cfg+             }++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++-- See Note [Checking for representation polymorphism]+noFixedRuntimeRepChecks :: LintM a -> LintM a+noFixedRuntimeRepChecks thing_inside+  = LintM $ \env errs ->+    let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }+    in unLintM thing_inside env' errs++getLintFlags :: LintM LintFlags+getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)++checkL :: Bool -> SDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = failWithL msg++-- like checkL, but relevant to type checking+lintL :: Bool -> SDoc -> LintM ()+lintL = checkL++checkWarnL :: Bool -> SDoc -> LintM ()+checkWarnL True   _  = return ()+checkWarnL False msg = addWarnL msg++failWithL :: SDoc -> LintM a+failWithL msg = LintM $ \ env (warns,errs) ->+                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))++addErrL :: SDoc -> LintM ()+addErrL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))++addWarnL :: SDoc -> LintM ()+addWarnL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (addMsg True env warns msg, errs))++addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc+addMsg show_context env msgs msg+  = assertPpr (notNull loc_msgs) msg $+    msgs `snocBag` mk_msg msg+  where+   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first+   loc_msgs = map dumpLoc (le_loc env)++   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs+                  , text "Substitution:" <+> ppr (le_subst env) ]++   context | show_context  = cxt_doc+           | otherwise     = whenPprDebug cxt_doc+     -- Print voluminous info for Lint errors+     -- but not for warnings++   msg_span = case [ span | (loc,_) <- loc_msgs+                          , let span = srcLocSpan loc+                          , isGoodSrcSpan span ] of+               []    -> noSrcSpan+               (s:_) -> s+   !diag_opts = le_diagOpts env+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span+                             (msg $$ context)++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 -> fromBoxedLResult (Just (is_case_pat env), errs)+  where+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True+    is_case_pat _other                           = False++addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a+-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned+addInScopeId in_id out_ty thing_inside+  = LintM $ \ env errs ->+    let !(out_id, env') = add env+    in unLintM (thing_inside out_id) env' errs++  where+    add env@(LE { le_in_vars = id_vars, le_joins = join_set+                , le_ue_aliases = aliases, le_subst = subst })+      = (out_id, env1)+      where+        env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }++        in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)+        aliases' = delFromNameEnv aliases (idName in_id)+           -- aliases': when shadowing an alias, we need to make sure the+           -- Id is no longer classified as such. E.g.+           --   let x = <e1> in case x of x { _DEFAULT -> <e2> }+           -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.++        -- A very tiny optimisation, not sure if it's really worth it+        -- Short-cut when the substitution is a no-op+        out_id | isEmptyTCvSubst subst = in_id+               | otherwise             = setIdType in_id out_ty++        join_set'+          | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity+          | otherwise       = delVarSet    join_set in_id -- Remove any existing binding++addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a+-- This function clones to avoid shadowing of TyCoVars+addInScopeTyCoVar tcv tcv_type thing_inside+  = LintM $ \ env@(LE { le_in_vars = in_vars, le_subst = subst }) errs ->+    let (tcv', subst') = subst_bndr subst+        env' = env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type)+                   , le_subst = subst' }+    in unLintM (thing_inside tcv') env' errs+  where+    subst_bndr subst+      | isEmptyTCvSubst subst                -- No change in kind+      , not (tcv `elemInScopeSet` in_scope)  -- Not already in scope+      = -- Do not extend the substitution, just the in-scope set+        (if (varType tcv `eqType` tcv_type) then (\x->x) else+          pprTrace "addInScopeTyCoVar" (+            vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv)+                 , text "tcv_type" <+> ppr tcv_type ])) $+        (tcv, subst `extendSubstInScope` tcv)++      -- Clone, and extend the substitution+      | let tcv' = uniqAway in_scope (setVarType tcv tcv_type)+      = (tcv', extendTCvSubstWithClone subst tcv tcv')+      where+        in_scope = substInScopeSet subst++getInVarEnv :: LintM (VarEnv (InId, OutType))+getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs))++extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a+extendTvSubstL tv ty m+  = LintM $ \ env errs ->+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) 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++getValidJoins :: LintM IdSet+getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))++getSubst :: LintM Subst+getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))++substTyM :: InType -> LintM OutType+-- Apply the substitution to the type+-- The substitution is often empty, in which case it is a no-op+substTyM ty+  = do { subst <- getSubst+       ; return (substTy subst ty) }++getUEAliases :: LintM (NameEnv UsageEnv)+getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))++getInScope :: LintM InScopeSet+getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs))++lintVarOcc :: InVar -> LintM OutType+-- Used at an occurrence of a variable: term variables, type variables, and coercion variables+-- Checks two things:+-- a) that it is in scope+-- b) that the InType at the ocurrences matches the InType at the binding site+lintVarOcc v_occ+  = do { in_var_env <- getInVarEnv+       ; case lookupVarEnv in_var_env v_occ of+           Nothing | isGlobalId v_occ -> return (idType v_occ)+                   | otherwise        -> failWithL (text pp_what <+> quotes (ppr v_occ)+                                                    <+> text "is out of scope")+           Just (v_bndr, out_ty) -> do { check_bad_global v_bndr+                                       ; ensureEqTys occ_ty bndr_ty $  -- Compares InTypes+                                         mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty+                                       ; return out_ty }+             where+               occ_ty  = varType v_occ+               bndr_ty = varType v_bndr }+  where+    pp_what | isTyVar v_occ = "The type variable"+            | isCoVar v_occ = "The coercion variable"+            | otherwise     = "The value variable"++       -- 'check_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+    check_bad_global v_bndr+      | isGlobalId v_occ+      , isLocalId v_bndr+      , not (isWiredIn v_occ)+      = failWithL $ hang (text "Occurrence is GlobalId, but binding is LocalId")+                       2 (vcat [ hang (text "occurrence:") 2 $ pprBndr LetBind v_occ+                               , hang (text "binder    :") 2 $ pprBndr LetBind v_bndr ])+      | otherwise+      = return ()++lookupJoinId :: Id -> LintM JoinPointHood+-- 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 (idJoinPointHood id')+            Nothing  -> return NotJoinPoint }++addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a+addAliasUE id ue thing_inside = LintM $ \ env errs ->+  let new_ue_aliases =+        extendNameEnv (le_ue_aliases env) (getName id) ue+  in+    unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs++varCallSiteUsage :: OutId -> LintM UsageEnv+varCallSiteUsage id =+  do m <- getUEAliases+     return $ case lookupNameEnv m (getName id) of+         Nothing    -> singleUsageUE id+         Just id_ue -> id_ue++ensureEqTys :: OutType -> OutType -> SDoc -> 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+{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]+ensureEqTys ty1 ty2 msg+  = do { flags <- getLintFlags+       ; lintL (eq_type flags ty1 ty2) msg }++eq_type :: LintFlags -> Type -> Type -> Bool+-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to+-- be equal. See Note [Linting linearity].+eq_type flags ty1 ty2 | lf_check_linearity flags = eqType                     ty1 ty2+                      | otherwise                = eqTypeIgnoringMultiplicity ty1 ty2++{- Note [INLINE ensureEqTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To make Lint fast, we want to avoid allocating a thunk for <msg> in+      ensureEqTypes ty1 ty2 <msg>+because the test almost always succeeds, and <msg> isn't needed.+So we INLINE `ensureEqTys`.  This actually make a difference of+1-2% when compiling programs with -dcore-lint.+-}++ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()+ensureSubUsage Bottom     _              _ = return ()+ensureSubUsage Zero       described_mult err_msg = ensureSubMult ManyTy described_mult err_msg+ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg++ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()+ensureSubMult actual_mult described_mult err_msg = do+    flags <- getLintFlags+    when (lf_check_linearity flags) $+      unless (deepSubMult actual_mult described_mult) $+        addErrL err_msg+  where+    -- Check for submultiplicity using the following rules:+    -- 1. x*y <= z when x <= z and y <= z.+    --    This rule follows from the fact that x*y = sup{x,y} for any+    --    multiplicities x,y.+    -- 2. x <= y*z when x <= y or x <= z.+    --    This rule is not complete: when x = y*z, we cannot+    --    change y*z <= y*z to y*z <= y or y*z <= z.+    --    However, we eliminate products on the LHS in step 1.+    -- 3. One <= x and x <= Many for any x, as checked by 'submult'.+    -- 4. x <= x.+    -- Otherwise, we fail.+    deepSubMult :: Mult -> Mult -> Bool+    deepSubMult m n+      | Just (m1, m2) <- isMultMul m = deepSubMult m1 n  && deepSubMult m2 n+      | Just (n1, n2) <- isMultMul n = deepSubMult m  n1 || deepSubMult m  n2+      | Submult <- m `submult` n = True+      | otherwise = m `eqType` n++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, text "In the RHS of" <+> pp_binders [v])++dumpLoc (OccOf v)+  = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v)++dumpLoc (LambdaBodyOf b)+  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)++dumpLoc (RuleOf b)+  = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)++dumpLoc (UnfoldingOf b)+  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)++dumpLoc (BodyOfLet b)+  = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b)++dumpLoc (BodyOfLetRec [])+  = (noSrcLoc, text "In body of a letrec with no binders")++dumpLoc (BodyOfLetRec bs@(b:_))+  = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs)++dumpLoc (AnExpr e)+  = (noSrcLoc, text "In the expression:" <+> ppr e)++dumpLoc (CaseAlt (Alt con args _))+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CasePat (Alt con args _))+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CaseTy scrut)+  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")+                  2 (ppr scrut))++dumpLoc (IdTy b)+  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)++dumpLoc (ImportedUnfolding locn)+  = (locn, 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))+dumpLoc (InAxiom ax)+  = (getSrcLoc ax, hang (text "In the coercion axiom")+                      2 (pprCoAxiom ax))++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] -> SDoc+mkDefaultArgsMsg args+  = hang (text "DEFAULT case with binders")+         4 (ppr args)++mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc+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 -> SDoc+mkScrutMsg var var_ty scrut_ty+  = 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]++mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc+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 -> SDoc+nonExhaustiveAltsMsg e+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)++mkBadConMsg :: TyCon -> DataCon -> SDoc+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 -> SDoc+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 :: SDoc+integerScrutinisedMsg+  = text "In a LitAlt, the literal is lifted (probably Integer)"++mkBadAltMsg :: Type -> CoreAlt -> SDoc+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 -> SDoc+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 -> SDoc+mkAppMsg expected_arg_ty actual_arg_ty arg+  = vcat [text "Argument value doesn't match argument type:",+              hang (text "Expected arg type:") 4 (ppr expected_arg_ty),+              hang (text "Actual arg type:") 4 (ppr actual_arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc+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 -> SDoc+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 :: OutType -> Type -> SDoc+mkTyAppMsg ty arg_ty+  = vcat [text "Illegal type application:",+              hang (text "Function type:")+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),+              hang (text "Type argument:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++emptyRec :: CoreExpr -> SDoc+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)++mkRhsMsg :: Id -> SDoc -> Type -> SDoc+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]]++badBndrTyMsg :: Id -> SDoc -> SDoc+badBndrTyMsg binder what+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder+         , text "Binder's type:" <+> ppr (idType binder) ]++mkNonTopExportedMsg :: Id -> SDoc+mkNonTopExportedMsg binder+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]++mkNonTopExternalNameMsg :: Id -> SDoc+mkNonTopExternalNameMsg binder+  = hsep [text "Non-top-level binder has an external name:", ppr binder]++mkTopNonLitStrMsg :: Id -> SDoc+mkTopNonLitStrMsg binder+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]++mkKindErrMsg :: TyVar -> Type -> SDoc+mkKindErrMsg tyvar arg_ty+  = vcat [text "Kinds don't match in type application:",+          hang (text "Type variable:")+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),+          hang (text "Arg type:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)++mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc+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 -> SDoc+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++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 n rhs+  = vcat [ text "Join point has too few lambdas",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of lambdas:" <+> ppr (ar - n),+           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 :: InVar -> InType -> InType -> SDoc+mkBndrOccTypeMismatchMsg var bndr_ty occ_ty+  = vcat [ text "Mismatch in type between binder and occurrence"+         , text "Binder:    " <+> ppr var <+> dcolon <+> ppr bndr_ty+         , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ]++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 ]++dupVars :: [NonEmpty Var] -> SDoc+dupVars vars+  = hang (text "Duplicate variables brought into scope")+       2 (ppr (map toList vars))++dupExtVars :: [NonEmpty Name] -> SDoc+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 = {-# SCC "lintAnnots" #-} do+  -- Run the pass as we normally would+  dflags <- getDynFlags+  logger <- getLogger+  when (gopt Opt_DoAnnotationLinting dflags) $+    liftIO $ Err.showPass logger "Annotation linting - first run"+  -- If appropriate re-run it without debug annotations to make sure+  -- that they made no difference.+  if gopt Opt_DoAnnotationLinting dflags+    then do+      nguts <- pass guts+      liftIO $ Err.showPass logger "Annotation linting - second run"+      nguts' <- withoutAnnots pass guts+      -- Finally compare the resulting bindings+      liftIO $ Err.showPass logger "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)) $ GHC.Core.Opt.Monad.putMsg $ vcat+        [ lint_banner "warning" pname+        , text "Core changes with annotations:"+        , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs+        ]+      return nguts+    else+      pass guts++-- | 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.+  -- TODO: supply tag here as well ?+  let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 }+  -- 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. Drop the simple count so it doesn't+  -- effect the total also+  dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts)
+ GHC/Core/Lint/Interactive.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee].+-}++module GHC.Core.Lint.Interactive (+    interactiveInScope,+ ) where++import GHC.Prelude++import GHC.Runtime.Context++import GHC.Core.Coercion+import GHC.Core.TyCo.FVs+import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )++import GHC.Types.Id+import GHC.Types.TypeEnv+++interactiveInScope :: InteractiveContext -> [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 GHC.Runtime.Context).+-- So we have to tell Lint about them, lest it reports them as out of scope.+--+-- We do this by find local-named things that may appear free in interactive+-- context.  This function is pretty revolting and quite possibly not quite right.+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty+-- so this is a (cheap) no-op.+--+-- See #8215 for an example+interactiveInScope ictxt+  = tyvars ++ ids+  where+    -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr+    (cls_insts, _fam_insts) = ic_instances ictxt+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)+    te     = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts 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)
+ GHC/Core/Make.hs view
@@ -0,0 +1,1305 @@+-- | Handy functions for creating much Core syntax+module GHC.Core.Make (+        -- * Constructing normal syntax+        mkCoreLet, mkCoreLets,+        mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps,+        mkCoreLams, mkCoreTyLams,+        mkWildCase, mkIfThenElse,+        mkWildValBinder,+        mkSingleAltCase,+        sortQuantVars, castBottomExpr,++        -- * Constructing boxed literals+        mkLitRubbish,+        mkWordExpr,+        mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,+        mkIntegerExpr, mkNaturalExpr,+        mkFloatExpr, mkDoubleExpr,+        mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith,+        MkStringIds (..), getMkStringIds,++        -- * Floats+        FloatBind(..), wrapFloat, wrapFloats, floatBindings,++        -- * Constructing small tuples+        mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum,+        mkCoreTupBoxity, unitExpr,++        -- * Constructing big tuples+        mkChunkified, chunkify,+        mkBigCoreVarTup, mkBigCoreVarTupSolo,+        mkBigCoreVarTupTy, mkBigCoreTupTy,+        mkBigCoreTup,++          -- * Deconstructing big tuples+        mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase,++        -- * Constructing list expressions+        mkNilExpr, mkConsExpr, mkListExpr,+        mkFoldrExpr, mkBuildExpr,++        -- * Constructing Maybe expressions+        mkNothingExpr, mkJustExpr,++        -- * Error Ids+        mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,+        rEC_CON_ERROR_ID,+        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,+        pAT_ERROR_ID, rEC_SEL_ERROR_ID,+        tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID+    ) where++import GHC.Prelude+import GHC.Platform++import GHC.Types.Id+import GHC.Types.Var  ( setTyVarUnique, visArgConstraintLike )+import GHC.Types.TyThing+import GHC.Types.Id.Info+import GHC.Types.Cpr+import GHC.Types.Basic( TypeOrConstraint(..) )+import GHC.Types.Demand+import GHC.Types.Name      hiding ( varName )+import GHC.Types.Literal+import GHC.Types.Unique.Supply++import GHC.Core+import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast )+import GHC.Core.Type+import GHC.Core.Predicate    ( scopedSort, isEqPred )+import GHC.Core.TyCo.Compare ( eqType )+import GHC.Core.Coercion     ( isCoVar, mkRepReflCo, mkForAllVisCos )+import GHC.Core.DataCon      ( DataCon, dataConWorkId, dataConWrapId )+import GHC.Core.Multiplicity++import GHC.Builtin.Types+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Settings.Constants( mAX_TUPLE_SIZE )+import GHC.Data.FastString+import GHC.Data.Maybe ( expectJust )++import Data.List        ( partition )+import Data.List.NonEmpty ( NonEmpty (..) )+import Data.Char        ( ord )++infixl 4 `mkCoreApp`, `mkCoreApps`++{-+************************************************************************+*                                                                      *+\subsection{Basic GHC.Core construction}+*                                                                      *+************************************************************************+-}+-- | Sort the variables, putting type and covars first, in scoped order,+-- and then other Ids+--+-- It is a deterministic sort, meaning it doesn't look at the values of+-- Uniques. For explanation why it's important See Note [Unique Determinism]+-- in GHC.Types.Unique.+sortQuantVars :: [Var] -> [Var]+sortQuantVars vs = sorted_tcvs ++ ids+  where+    (tcvs, ids) = partition (isTyVar <||> isCoVar) vs+    sorted_tcvs = scopedSort tcvs++-- | Bind a binding group over an expression, using a @let@ or @case@ as+-- appropriate (see "GHC.Core#let_can_float_invariant")+mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr+mkCoreLet (NonRec bndr rhs) body        -- See Note [Core let-can-float invariant]+  = bindNonRec bndr rhs body+mkCoreLet bind body+  = Let bind body++-- | Create a lambda where the given expression has a number of variables+-- bound over it. The leftmost binder is that bound by the outermost+-- lambda in the result+mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr+mkCoreLams = mkLams++-- | Create a type lambda (/\a b c. e) and apply a cast to fix up visibilities+-- if needed. See Note [Required foralls in Core]+mkCoreTyLams :: [TyVarBinder] -> CoreExpr -> CoreExpr+mkCoreTyLams binders body = mkCast lam co+  where+    lam = mkCoreLams (binderVars binders) body+    co  = mkForAllVisCos binders (mkRepReflCo (exprType body))++-- | Bind a list of binding groups over an expression. The leftmost binding+-- group becomes the outermost group in the resulting expression+mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr+mkCoreLets binds body = foldr mkCoreLet body binds++-- | Construct an expression which represents the application of a number of+-- expressions to that of a data constructor expression. The leftmost expression+-- in the list is applied first+mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr+mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args++-- | A variant of 'mkCoreConApps' constructs an expression which represents the+-- application of a number of expressions to that of a data constructor+-- expression using the wrapper, not the worker, of the data constructor. The+-- leftmost expression in the list is applied first+mkCoreConWrapApps :: DataCon -> [CoreExpr] -> CoreExpr+mkCoreConWrapApps con args = mkCoreApps (Var (dataConWrapId con)) args++-- | Construct an expression which represents the application of a number of+-- expressions to another. The leftmost expression in the list is applied first+mkCoreApps :: CoreExpr -- ^ function+           -> [CoreExpr] -- ^ arguments+           -> CoreExpr+mkCoreApps fun args+  = fst $+    foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args+  where+    doc_string = ppr fun_ty $$ ppr fun $$ ppr args+    fun_ty = exprType fun++-- | Construct an expression which represents the application of one expression+-- to the other+mkCoreApp :: SDoc+          -> CoreExpr -- ^ function+          -> CoreExpr -- ^ argument+          -> CoreExpr+mkCoreApp s fun arg+  = fst $ mkCoreAppTyped s (fun, exprType fun) arg++-- | Construct an expression which represents the application of one expression+-- paired with its type to an argument. The result is paired with its type. This+-- function is not exported and used in the definition of 'mkCoreApp' and+-- 'mkCoreApps'.+mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type)+mkCoreAppTyped _ (fun, fun_ty) (Type ty)+  = (App fun (Type ty), piResultTy fun_ty ty)+mkCoreAppTyped _ (fun, fun_ty) (Coercion co)+  = (App fun (Coercion co), funResultTy fun_ty)+mkCoreAppTyped d (fun, fun_ty) arg+  = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d)+    (App fun arg, funResultTy fun_ty)++{- *********************************************************************+*                                                                      *+              Building case expressions+*                                                                      *+********************************************************************* -}++-- | Make a /wildcard binder/. This is typically used when you need a binder+-- that you expect to use only at a *binding* site.  Do not use it at+-- occurrence sites because it has a single, fixed unique, and it's very+-- easy to get into difficulties with shadowing.  That's why it is used so little.+--+-- See Note [WildCard binders] in "GHC.Core.Opt.Simplify.Env"+mkWildValBinder :: Mult -> Type -> Id+mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName w ty+  -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors+  -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.++-- | Make a case expression whose case binder is unused+-- The alts and res_ty should not have any occurrences of WildId+mkWildCase :: CoreExpr -- ^ scrutinee+           -> Scaled Type+           -> Type -- ^ res_ty+           -> [CoreAlt] -- ^ alts+           -> CoreExpr+mkWildCase scrut (Scaled w scrut_ty) res_ty alts+  = Case scrut (mkWildValBinder w scrut_ty) res_ty alts++mkIfThenElse :: CoreExpr -- ^ guard+             -> CoreExpr -- ^ then+             -> CoreExpr -- ^ else+             -> CoreExpr+mkIfThenElse guard then_expr else_expr+-- Not going to be refining, so okay to take the type of the "then" clause+  = mkWildCase guard (linear boolTy) (exprType then_expr)+         [ Alt (DataAlt falseDataCon) [] else_expr,       -- Increasing order of tag!+           Alt (DataAlt trueDataCon)  [] then_expr ]++castBottomExpr :: CoreExpr -> Type -> CoreExpr+-- (castBottomExpr e ty), assuming that 'e' diverges,+-- return an expression of type 'ty'+-- See Note [Empty case alternatives] in GHC.Core+castBottomExpr e res_ty+  | e_ty `eqType` res_ty = e+  | otherwise            = Case e (mkWildValBinder OneTy e_ty) res_ty []+  where+    e_ty = exprType e++mkLitRubbish :: Type -> Maybe CoreExpr+-- Make a rubbish-literal CoreExpr of the given type.+-- Fail (returning Nothing) if+--    * the RuntimeRep of the Type is not monomorphic;+--    * the type is (a ~# b), the type of coercion+-- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals]+-- in GHC.Types.Literal+mkLitRubbish ty+  | not (noFreeVarsOfType rep)+  = Nothing   -- Satisfy INVARIANT 1+  | isEqPred ty+  = Nothing   -- Satisfy INVARIANT 2+  | otherwise+  = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])+  where+    (torc, rep) = expectJust $ sORTKind_maybe (typeKind ty)++{-+************************************************************************+*                                                                      *+\subsection{Making literals}+*                                                                      *+************************************************************************+-}++-- | Create a 'CoreExpr' which will evaluate to the given @Int@+mkIntExpr :: Platform -> Integer -> CoreExpr        -- Result = I# i :: Int+mkIntExpr platform i = mkCoreConApps intDataCon  [mkIntLit platform i]++-- | Create a 'CoreExpr' which will evaluate to the given @Int@. Don't check+-- that the number is in the range of the target platform @Int@+mkUncheckedIntExpr :: Integer -> CoreExpr        -- Result = I# i :: Int+mkUncheckedIntExpr i = mkCoreConApps intDataCon  [Lit (mkLitIntUnchecked i)]++-- | Create a 'CoreExpr' which will evaluate to the given @Int@+mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int+mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLit platform (fromIntegral i)]++-- | Create a 'CoreExpr' which will evaluate to a @Word@ with the given value+mkWordExpr :: Platform -> Integer -> CoreExpr+mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]++-- | Create a 'CoreExpr' which will evaluate to the given @Integer@+mkIntegerExpr  :: Platform -> Integer -> CoreExpr  -- Result :: Integer+mkIntegerExpr platform i+  | platformInIntRange platform i = mkCoreConApps integerISDataCon [mkIntLit platform i]+  | i < 0                         = mkCoreConApps integerINDataCon [Lit (mkLitBigNat (negate i))]+  | otherwise                     = mkCoreConApps integerIPDataCon [Lit (mkLitBigNat i)]++-- | Create a 'CoreExpr' which will evaluate to the given @Natural@+mkNaturalExpr  :: Platform -> Integer -> CoreExpr+mkNaturalExpr platform w+  | platformInWordRange platform w = mkCoreConApps naturalNSDataCon [mkWordLit platform w]+  | otherwise                      = mkCoreConApps naturalNBDataCon [Lit (mkLitBigNat w)]++-- | Create a 'CoreExpr' which will evaluate to the given @Float@+mkFloatExpr :: Float -> CoreExpr+mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f]++-- | Create a 'CoreExpr' which will evaluate to the given @Double@+mkDoubleExpr :: Double -> CoreExpr+mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d]+++-- | Create a 'CoreExpr' which will evaluate to the given @Char@+mkCharExpr     :: Char             -> CoreExpr      -- Result = C# c :: Int+mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c]++-- | Create a 'CoreExpr' which will evaluate to the given @String@+mkStringExpr   :: MonadThings m => String     -> m CoreExpr  -- Result :: String+mkStringExpr str = mkStringExprFS (mkFastString str)++-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@+mkStringExprFS :: MonadThings m => FastString -> m CoreExpr  -- Result :: String+mkStringExprFS = mkStringExprFSLookup lookupId++mkStringExprFSLookup :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr+mkStringExprFSLookup lookupM str = do+  mk <- getMkStringIds lookupM+  pure (mkStringExprFSWith mk str)++getMkStringIds :: Applicative m => (Name -> m Id) -> m MkStringIds+getMkStringIds lookupM = MkStringIds <$> lookupM unpackCStringName <*> lookupM unpackCStringUtf8Name++data MkStringIds = MkStringIds+  { unpackCStringId     :: !Id+  , unpackCStringUtf8Id :: !Id+  }++mkStringExprFSWith :: MkStringIds -> FastString -> CoreExpr+mkStringExprFSWith ids str+  | nullFS str+  = mkNilExpr charTy++  | all safeChar chars+  = let !unpack_id = unpackCStringId ids+    in App (Var unpack_id) lit++  | otherwise+  = let !unpack_utf8_id = unpackCStringUtf8Id ids+    in App (Var unpack_utf8_id) lit++  where+    chars = unpackFS str+    safeChar c = ord c >= 1 && ord c <= 0x7F+    lit = Lit (LitString (bytesFS str))++{-+************************************************************************+*                                                                      *+     Creating tuples and their types for Core expressions+*                                                                      *+************************************************************************+-}++{- Note [Flattening one-tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This family of functions creates a tuple of variables/expressions/types.+  mkCoreTup [e1,e2,e3] = (e1,e2,e3)+What if there is just one variable/expression/type in the argument?+We could do one of two things:++* Flatten it out, so that+    mkCoreTup [e1] = e1++* Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types)+    mkCoreTupSolo [e1] = Solo e1+  We use a suffix "Solo" to indicate this.++Usually we want the former, but occasionally the latter.++NB: The logic in tupleDataCon knows about () and Solo and (,), etc.++Note [Don't flatten tuples from HsSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we get an explicit 1-tuple from HsSyn somehow (likely: Template Haskell),+we should treat it really as a 1-tuple, without flattening. Note that a+1-tuple and a flattened value have different performance and laziness+characteristics, so should just do what we're asked.++This arose from discussions in #16881.++One-tuples that arise internally depend on the circumstance; often flattening+is a good idea. Decisions are made on a case-by-case basis.++'mkCoreBoxedTuple` and `mkBigCoreVarTupSolo` build tuples without flattening.+-}++-- | Build a small tuple holding the specified expressions+-- One-tuples are *not* flattened; see Note [Flattening one-tuples]+-- See also Note [Don't flatten tuples from HsSyn]+-- Arguments must have kind Type+mkCoreBoxedTuple :: HasDebugCallStack => [CoreExpr] -> CoreExpr+mkCoreBoxedTuple cs+  = assertPpr (all (tcIsLiftedTypeKind . typeKind . exprType) cs) (ppr cs)+    mkCoreConApps (tupleDataCon Boxed (length cs))+                  (map (Type . exprType) cs ++ cs)+++-- | Build a small unboxed tuple holding the specified expressions.+-- Do not include the RuntimeRep specifiers; this function calculates them+-- for you.+-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]+mkCoreUnboxedTuple :: [CoreExpr] -> CoreExpr+mkCoreUnboxedTuple exps+  = mkCoreConApps (tupleDataCon Unboxed (length tys))+                  (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)+  where+    tys = map exprType exps++-- | Make a core tuple of the given boxity; don't flatten 1-tuples+mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr+mkCoreTupBoxity Boxed   exps = mkCoreBoxedTuple   exps+mkCoreTupBoxity Unboxed exps = mkCoreUnboxedTuple exps++-- | Build the type of a small tuple that holds the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkCoreVarTupTy :: [Id] -> Type+mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)++-- | Build a small tuple holding the specified expressions+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkCoreTup :: [CoreExpr] -> CoreExpr+mkCoreTup [c] = c+mkCoreTup cs  = mkCoreBoxedTuple cs   -- non-1-tuples are uniform++-- | Build an unboxed sum.+--+-- Alternative number ("alt") starts from 1.+mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr+mkCoreUnboxedSum arity alt tys exp+  = assert (length tys == arity) $+    assert (alt <= arity) $+    mkCoreConApps (sumDataCon alt arity)+                  (map (Type . getRuntimeRep) tys+                   ++ map Type tys+                   ++ [exp])++{- Note [Big tuples]+~~~~~~~~~~~~~~~~~~~~+"Big" tuples (`mkBigCoreTup` and friends) are more general than "small"+ones (`mkCoreTup` and friends) in two ways.++1. GHCs built-in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but+   we might conceivably want to build such a massive tuple as part of the+   output of a desugaring stage (notably that for list comprehensions).++   `mkBigCoreTup` encodes such big tuples by creating and pattern+   matching on /nested/ small tuples that are directly expressible by+   GHC.++   Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)+   than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any+   construction to be big.++2. When desugaring arrows we gather up a tuple of free variables, which+   may include dictionaries (of kind Constraint) and unboxed values.++   These can't live in a tuple. `mkBigCoreTup` encodes such tuples by+   boxing up the offending arguments: see Note [Boxing constructors]+   in GHC.Builtin.Types.++If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkBigTupleSelector'+and 'mkBigTupleCase' functions to do all your work with tuples you should be+fine, and not have to worry about the arity limitation, or kind limitation at+all.++The "big" tuple operations flatten 1-tuples just like "small" tuples.+But see Note [Don't flatten tuples from HsSyn]+-}++mkBigCoreVarTupSolo :: [Id] -> CoreExpr+-- Same as mkBigCoreVarTup, but:+--   - one-tuples are not flattened+--     see Note [Flattening one-tuples]+--   - arguments should have kind Type+mkBigCoreVarTupSolo [id] = mkCoreBoxedTuple [Var id]+mkBigCoreVarTupSolo ids  = mkChunkified mkCoreTup (map Var ids)++-- | Build a big tuple holding the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+-- Arguments don't have to have kind Type+mkBigCoreVarTup :: [Id] -> CoreExpr+mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)++-- | Build a "big" tuple holding the specified expressions+-- One-tuples are flattened; see Note [Flattening one-tuples]+-- Arguments don't have to have kind Type; ones that do not are boxed+-- This function crashes (in wrapBox) if given a non-Type+-- argument that it doesn't know how to box.+mkBigCoreTup :: [CoreExpr] -> CoreExpr+mkBigCoreTup exprs = mkChunkified mkCoreTup (map wrapBox exprs)++-- | Build the type of a big tuple that holds the specified variables+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type+mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)++-- | Build the type of a big tuple that holds the specified type of thing+-- One-tuples are flattened; see Note [Flattening one-tuples]+mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type+mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $+                     map boxTy tys++-- | The unit expression+unitExpr :: CoreExpr+unitExpr = Var unitDataConId++--------------------------------------------------------------+wrapBox :: CoreExpr -> CoreExpr+-- ^ If (e :: ty) and (ty :: Type), wrapBox is a no-op+-- But if (ty :: ki), and ki is not Type, wrapBox returns (K @ty e)+--     which has kind Type+-- where K is the boxing data constructor for ki+-- See Note [Boxing constructors] in GHC.Builtin.Types+-- Panics if there /is/ no boxing data con+wrapBox e+  = case boxingDataCon e_ty of+      BI_NoBoxNeeded                       -> e+      BI_Box { bi_inst_con = boxing_expr } -> App boxing_expr e+      BI_NoBoxAvailable -> pprPanic "wrapBox" (ppr e $$ ppr (exprType e))+                           -- We should do better than panicing: #22336+  where+    e_ty = exprType e++boxTy :: HasDebugCallStack => Type -> Type+-- ^ `boxTy ty` is the boxed version of `ty`. That is,+-- if `e :: ty`, then `wrapBox e :: boxTy ty`.+-- Note that if `ty :: Type`, `boxTy ty` just returns `ty`.+-- Panics if it is not possible to box `ty`, like `wrapBox` (#22336)+-- See Note [Boxing constructors] in GHC.Builtin.Types+boxTy ty+  = case boxingDataCon ty of+      BI_NoBoxNeeded -> ty+      BI_Box { bi_boxed_type = box_ty } -> box_ty+      BI_NoBoxAvailable -> pprPanic "boxTy" (ppr ty)+                           -- We should do better than panicing: #22336++unwrapBox :: UniqSupply -> Id -> CoreExpr+                 -> (UniqSupply, Id, CoreExpr)+-- If v's type required boxing (i.e it is unlifted or a constraint)+-- then (unwrapBox us v body) returns+--          (case box_v of MkDict v -> body)+--          together with box_v+--      where box_v is a fresh variable+-- Otherwise unwrapBox is a no-op+-- Panics if no box is available (#22336)+unwrapBox us var body+  = case boxingDataCon var_ty of+      BI_NoBoxNeeded    -> (us, var, body)+      BI_NoBoxAvailable -> pprPanic "unwrapBox" (ppr var $$ ppr var_ty)+                           -- We should do better than panicing: #22336+      BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty }+         -> (us', var', body')+         where+           var'  = mkSysLocal (fsLit "uc") uniq ManyTy box_ty+           body' = Case (Var var') var' (exprType body)+                        [Alt (DataAlt box_con) [var] body]+  where+    var_ty      = idType var+    (uniq, us') = takeUniqFromSupply us++-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decomposition+mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'+             -> [a]             -- ^ Possible \"big\" list of things to construct from+             -> a               -- ^ Constructed thing made possible by recursive decomposition+mkChunkified small_tuple as = mk_big_tuple (chunkify as)+  where+        -- Each sub-list is short enough to fit in a tuple+    mk_big_tuple [as] = small_tuple as+    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))++chunkify :: [a] -> [[a]]+-- ^ Split a list into lists that are small enough to have a corresponding+-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'+-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists+chunkify xs+  | n_xs <= mAX_TUPLE_SIZE = [xs]+  | otherwise              = split xs+  where+    n_xs     = length xs+    split [] = []+    split xs = let (as, bs) = splitAt mAX_TUPLE_SIZE xs+               in as : split bs+++{-+************************************************************************+*                                                                      *+\subsection{Tuple destructors}+*                                                                      *+************************************************************************+-}++-- | Builds a selector which scrutinises the given+-- expression and extracts the one name from the list given.+-- If you want the no-shadowing rule to apply, the caller+-- is responsible for making sure that none of these names+-- are in scope.+--+-- If there is just one 'Id' in the tuple, then the selector is+-- just the identity.+--+-- If necessary, we pattern match on a \"big\" tuple.+--+-- A tuple selector is not linear in its argument. Consequently, the case+-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many'+-- times. And all the argument variables must have multiplicity 'Many'.+mkBigTupleSelector, mkBigTupleSelectorSolo+    :: [Id]         -- ^ The 'Id's to pattern match the tuple against+    -> Id           -- ^ The 'Id' to select+    -> Id           -- ^ A variable of the same type as the scrutinee+    -> CoreExpr     -- ^ Scrutinee+    -> CoreExpr     -- ^ Selector expression++-- mkBigTupleSelector [a,b,c,d] b v e+--          = case e of v {+--                (p,q) -> case p of p {+--                           (a,b) -> b }}+-- We use 'tpl' vars for the p,q, since shadowing does not matter.+--+-- In fact, it's more convenient to generate it innermost first, getting+--+--        case (case e of v+--                (p,q) -> p) of p+--          (a,b) -> b+mkBigTupleSelector vars the_var scrut_var scrut+  = mk_tup_sel (chunkify vars) the_var+  where+    mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut+    mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $+                                mk_tup_sel (chunkify tpl_vs) tpl_v+        where+          tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s]+          tpl_vs  = mkTemplateLocals tpl_tys+          (tpl_v, group) = case+            [ (tpl,gp)+            | (tpl,gp) <- zipEqual tpl_vs vars_s+            , the_var `elem` gp+            ] of+              [x] -> x+              _ -> panic "mkBigTupleSelector"+-- ^ 'mkBigTupleSelectorSolo' is like 'mkBigTupleSelector'+-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])+mkBigTupleSelectorSolo vars the_var scrut_var scrut+  | [_] <- vars+  = mkSmallTupleSelector1 vars the_var scrut_var scrut+  | otherwise+  = mkBigTupleSelector vars the_var scrut_var scrut++-- | `mkSmallTupleSelector` is like 'mkBigTupleSelector', but for tuples that+-- are guaranteed never to be "big".  Also does not unwrap boxed types.+--+-- > mkSmallTupleSelector [x] x v e = [| e |]+-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]+mkSmallTupleSelector, mkSmallTupleSelector1+          :: [Id]        -- The tuple args+          -> Id          -- The selected one+          -> Id          -- A variable of the same type as the scrutinee+          -> CoreExpr    -- Scrutinee+          -> CoreExpr+mkSmallTupleSelector [var] should_be_the_same_var _ scrut+  = assert (var == should_be_the_same_var) $+    scrut  -- Special case for 1-tuples+mkSmallTupleSelector vars the_var scrut_var scrut+  = mkSmallTupleSelector1 vars the_var scrut_var scrut++-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'+-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])+mkSmallTupleSelector1 vars the_var scrut_var scrut+  = assert (notNull vars) $+    Case scrut scrut_var (idType the_var)+         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]++-- | A generalization of 'mkBigTupleSelector', allowing the body+-- of the case to be an arbitrary expression.+--+-- To avoid shadowing, we use uniques to invent new variables.+--+-- If necessary we pattern match on a "big" tuple.+mkBigTupleCase :: MonadUnique m    --   For inventing names of intermediate variables+               => [Id]             -- ^ The tuple identifiers to pattern match on;+                                   --   Bring these into scope in the body+               -> CoreExpr         -- ^ Body of the case+               -> CoreExpr         -- ^ Scrutinee+               -> m CoreExpr+-- ToDo: eliminate cases where none of the variables are needed.+--+--         mkBigTupleCase uniqs [a,b,c,d] body v e+--           = case e of v { (p,q) ->+--             case p of p { (a,b) ->+--             case q of q { (c,d) ->+--             body }}}+mkBigTupleCase vars body scrut+  = do us <- getUniqueSupplyM+       let (wrapped_us, wrapped_vars, wrapped_body) = foldr unwrap (us,[],body) vars+       return $ mk_tuple_case wrapped_us (chunkify wrapped_vars) wrapped_body+  where+    scrut_ty = exprType scrut++    unwrap var (us,vars,body)+      = (us', var':vars, body')+      where+        (us', var', body') = unwrapBox us var body++    mk_tuple_case :: UniqSupply -> [[Id]] -> CoreExpr -> CoreExpr+    -- mk_tuple_case [[a1..an], [b1..bm], ...] body+    --    case scrut of (p,q, ...) ->+    --    case p of (a1,..an) ->+    --    case q of (b1,..bm) ->+    --    ... -> body+    -- This is the case where don't need any nesting+    mk_tuple_case us [vars] body+      = mkSmallTupleCase vars body scrut_var scrut+      where+        scrut_var = case scrut of+                       Var v -> v+                       _ -> snd (new_var us scrut_ty)++    -- This is the case where we must nest tuples at least once+    mk_tuple_case us vars_s body+      = mk_tuple_case us' (chunkify vars') body'+      where+        (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s++    one_tuple_case chunk_vars (us, vs, body)+      = (us', scrut_var:vs, body')+      where+        tup_ty           = mkBoxedTupleTy (map idType chunk_vars)+        (us', scrut_var) = new_var us tup_ty+        body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)++    new_var :: UniqSupply -> Type -> (UniqSupply, Id)+    new_var us ty = (us', id)+       where+         (uniq, us') = takeUniqFromSupply us+         id = mkSysLocal (fsLit "ds") uniq ManyTy ty++-- | As 'mkBigTupleCase', but for a tuple that is small enough to be guaranteed+-- not to need nesting.+mkSmallTupleCase+        :: [Id]         -- ^ The tuple args+        -> CoreExpr     -- ^ Body of the case+        -> Id           -- ^ A variable of the same type as the scrutinee+        -> CoreExpr     -- ^ Scrutinee+        -> CoreExpr++mkSmallTupleCase [var] body _scrut_var scrut+  = bindNonRec var scrut body+mkSmallTupleCase vars body scrut_var scrut+  = Case scrut scrut_var (exprType body)+         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body]++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************+-}++data FloatBind+  = FloatLet  CoreBind+  | FloatCase CoreExpr Id AltCon [Var]+      -- case e of y { C ys -> ... }+      -- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels++instance Outputable FloatBind where+  ppr (FloatLet b) = text "LET" <+> ppr b+  ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b)+                                2 (ppr c <+> ppr bs)++wrapFloat :: FloatBind -> CoreExpr -> CoreExpr+wrapFloat (FloatLet defns)       body = Let defns body+wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body++-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn]+-- u = let b1 in let b2 in … in let bn in u@+wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr+wrapFloats floats expr = foldr wrapFloat expr floats++bindBindings :: CoreBind -> [Var]+bindBindings (NonRec b _) = [b]+bindBindings (Rec bnds) = map fst bnds++floatBindings :: FloatBind -> [Var]+floatBindings (FloatLet bnd) = bindBindings bnd+floatBindings (FloatCase _ b _ bs) = b:bs++{-+************************************************************************+*                                                                      *+\subsection{Common list manipulation expressions}+*                                                                      *+************************************************************************++Call the constructor Ids when building explicit lists, so that they+interact well with rules.+-}++-- | Makes a list @[]@ for lists of the specified type+mkNilExpr :: Type -> CoreExpr+mkNilExpr ty = mkCoreConApps nilDataCon [Type ty]++-- | Makes a list @(:)@ for lists of the specified type+mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr+mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl]++-- | Make a list containing the given expressions, where the list has the given type+mkListExpr :: Type -> [CoreExpr] -> CoreExpr+mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs++-- | Make a fully applied 'foldr' expression+mkFoldrExpr :: MonadThings m+            => Type             -- ^ Element type of the list+            -> Type             -- ^ Fold result type+            -> CoreExpr         -- ^ "Cons" function expression for the fold+            -> CoreExpr         -- ^ "Nil" expression for the fold+            -> CoreExpr         -- ^ List expression being folded acress+            -> m CoreExpr+mkFoldrExpr elt_ty result_ty c n list = do+    foldr_id <- lookupId foldrName+    return (Var foldr_id `App` Type elt_ty+           `App` Type result_ty+           `App` c+           `App` n+           `App` list)++-- | Make a 'build' expression applied to a locally-bound worker function+mkBuildExpr :: (MonadFail m, MonadThings m, MonadUnique m)+            => Type                                     -- ^ Type of list elements to be built+            -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's+                                                        -- of the binders for the build worker function, returns+                                                        -- the body of that worker+            -> m CoreExpr+mkBuildExpr elt_ty mk_build_inside = do+    n_tyvar <- newTyVar alphaTyVar+    let n_ty = mkTyVarTy n_tyvar+        c_ty = mkVisFunTysMany [elt_ty, n_ty] n_ty+    [c, n] <- sequence [mkSysLocalM (fsLit "c") ManyTy c_ty, mkSysLocalM (fsLit "n") ManyTy n_ty]++    build_inside <- mk_build_inside (c, c_ty) (n, n_ty)++    build_id <- lookupId buildName+    return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside+  where+    newTyVar tyvar_tmpl = do+      uniq <- getUniqueM+      return (setTyVarUnique tyvar_tmpl uniq)++{-+************************************************************************+*                                                                      *+             Manipulating Maybe data type+*                                                                      *+************************************************************************+-}+++-- | Makes a Nothing for the specified type+mkNothingExpr :: Type -> CoreExpr+mkNothingExpr ty = mkConApp nothingDataCon [Type ty]++-- | Makes a Just from a value of the specified type+mkJustExpr :: Type -> CoreExpr -> CoreExpr+mkJustExpr ty val = mkConApp justDataCon [Type ty, val]+++{-+************************************************************************+*                                                                      *+                      Error expressions+*                                                                      *+************************************************************************+-}++mkRuntimeErrorApp+        :: Id           -- Should be of type+                        --   forall (r::RuntimeRep) (a::TYPE r). Addr# -> a+                        --      or (a :: CONSTRAINT r)+                        --      where Addr# points to a UTF8 encoded string+        -> Type         -- The type to instantiate 'a'+        -> String       -- The string to print+        -> CoreExpr++mkRuntimeErrorApp err_id res_ty err_msg+  = mkApps (Var err_id) [ Type (getRuntimeRep res_ty)+                        , Type res_ty, err_string ]+  where+    err_string = Lit (mkLitString err_msg)++{-+************************************************************************+*                                                                      *+                     Error Ids+*                                                                      *+************************************************************************++GHC randomly injects these into the code.++@patError@ is just a version of @error@ for pattern-matching+failures.  It knows various ``codes'' which expand to longer+strings---this saves space!++@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly+well shouldn't be yanked on, but if one is, then you will get a+friendly message from @absentErr@ (rather than a totally random+crash).+-}++errorIds :: [Id]+errorIds+  = [ nON_EXHAUSTIVE_GUARDS_ERROR_ID,+      nO_METHOD_BINDING_ERROR_ID,+      pAT_ERROR_ID,+      rEC_CON_ERROR_ID,+      rEC_SEL_ERROR_ID,+      iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID,+      aBSENT_ERROR_ID,  aBSENT_CONSTRAINT_ERROR_ID,+      aBSENT_SUM_FIELD_ERROR_ID,+      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284+      ]++recSelErrorName, recConErrorName, patErrorName :: Name+nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name+typeErrorName :: Name+absentSumFieldErrorName :: Name++recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID+recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID+patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID+typeErrorName       = err_nm "typeError"       typeErrorIdKey       tYPE_ERROR_ID++noMethodBindingErrorName     = err_nm "noMethodBindingError"+                                  noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID+nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError"+                                  nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID++err_nm :: String -> Unique -> Id -> Name+err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id++rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id+pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id+tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id+rEC_SEL_ERROR_ID                = mkRuntimeErrorId TypeLike recSelErrorName+rEC_CON_ERROR_ID                = mkRuntimeErrorId TypeLike recConErrorName+pAT_ERROR_ID                    = mkRuntimeErrorId TypeLike patErrorName+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId TypeLike noMethodBindingErrorName+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId TypeLike nonExhaustiveGuardsErrorName+tYPE_ERROR_ID                   = mkRuntimeErrorId TypeLike typeErrorName++-- Note [aBSENT_SUM_FIELD_ERROR_ID]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Unboxed sums are transformed into unboxed tuples in GHC.Stg.Unarise.mkUbxSum+-- and fields that can't be reached are filled with rubbish values.+-- For instance, consider the case of the program:+--+--     f :: (# Int | Float# #) -> Int+--     f = ...+--+--     x = f (# | 2.0## #)+--+-- Unarise will represent f's unboxed sum argument as a tuple (# Int#, Int,+-- Float# #), where Int# is a tag. Consequently, `x` will be rewritten to:+--+--     x = f (# 2#, ???, 2.0## #)+--+-- We must come up with some rubbish literal to use in place of `???`. In the+-- case of unboxed integer types this is easy: we can simply use 0 for+-- Int#/Word# and 0.0 Float#/Double#.+--+-- However, coming up with a rubbish pointer value is more delicate as the+-- value must satisfy the following requirements:+--+--    1. it needs to be a valid closure pointer for the GC (not a NULL pointer)+--+--    2. it can't take arguments because it's used in unarise and applying an+--       argument would require allocating a thunk, which is both difficult to+--       do and costly.+--+--    3. it shouldn't be CAFfy since this would make otherwise non-CAFfy+--       bindings CAFfy, incurring a cost in GC performance. Given that unboxed+--       sums are intended to be used in performance-critical code, this is to+--       We work-around this by declaring the absentSumFieldError as non-CAFfy,+--       as described in Note [Wired-in exceptions are not CAFfy].+--+--       Getting this wrong causes hard-to-debug runtime issues, see #15038.+--+--    4. it can't be defined in `base` package.  Afterall, not all code which+--       uses unboxed sums uses depends upon `base`.  Specifically, this became+--       an issue when we wanted to use unboxed sums in boot libraries used by+--       `base`, see #17791.+--+-- To fill this role we define `ghc-prim:GHC.Prim.Panic.absentSumFieldError`+-- with the type:+--+--    absentSumFieldError :: forall a. a+--+-- Note that this type is something of a lie since Unarise may use it at an+-- unlifted type. However, this lie is benign as absent sum fields are examined+-- only by the GC, which does not care about levity..+--+-- When entered, this closure calls `stg_panic#`, which immediately halts+-- execution and cannot be caught. This is in contrast to most other runtime+-- errors, which are thrown as proper Haskell exceptions. This design is+-- intentional since entering an absent sum field is an indication that+-- something has gone horribly wrong, very likely due to a compiler bug.+--++-- Note [Wired-in exceptions are not CAFfy]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC has logic wiring-in a small number of exceptions, which may be thrown in+-- generated code. Specifically, these are implemented via closures (defined+-- in `GHC.Prim.Exception` in `ghc-prim`) which, when entered, raise the desired+-- exception. For instance, in the case of OverflowError we have+--+--     raiseOverflow :: forall a. a+--     raiseOverflow = runRW# (\s ->+--         case raiseOverflow# s of+--           (# _, _ #) -> let x = x in x)+--+-- where `raiseOverflow#` is defined in the rts/Exception.cmm.+--+-- Note that `raiseOverflow` and friends, being top-level thunks, are CAFs.+-- Normally, this would be reflected in their IdInfo; however, as these+-- functions are widely used and CAFfyness is transitive, we very much want to+-- avoid declaring them as CAFfy. This is especially true in especially in+-- performance-critical code like that using unboxed sums and+-- absentSumFieldError.+--+-- Consequently, `mkExceptionId` instead declares the exceptions to be+-- non-CAFfy and rather ensure in the RTS (in `initBuiltinGcRoots` in+-- rts/RtsStartup.c) that these closures remain reachable by creating a+-- StablePtr to each. Note that we are using the StablePtr mechanism not+-- because we need a StablePtr# object, but rather because the stable pointer+-- table is a source of GC roots.+--+-- At some point we could consider removing this optimisation as it is quite+-- fragile, but we do want to be careful to avoid adding undue cost. Unboxed+-- sums in particular are intended to be used in performance-critical contexts.+--+-- See #15038, #21141.++absentSumFieldErrorName+   = mkWiredInIdName+      gHC_PRIM_PANIC+      (fsLit "absentSumFieldError")+      absentSumFieldErrorIdKey+      aBSENT_SUM_FIELD_ERROR_ID++aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName++-- | Exception with type \"forall a. a\"+--+-- Any exceptions added via this function needs to be added to+-- the RTS's initBuiltinGcRoots() function.+mkExceptionId :: Name -> Id+mkExceptionId name+  = mkVanillaGlobalWithInfo name+      (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a+      (divergingIdInfo [] `setCafInfo` NoCafRefs)+         -- See Note [Wired-in exceptions are not CAFfy]++-- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID', that+-- throws an (imprecise) exception after being supplied one value arg for every+-- argument 'Demand' in the list. The demands end up in the demand signature.+--+-- 1. Sets the demand signature to unleash the given arg dmds 'botDiv'+-- 2. Sets the arity info so that it matches the length of arg demands+-- 3. Sets a bottoming CPR sig with the correct arity+--+-- It's important that all 3 agree on the arity, which is what this defn ensures.+divergingIdInfo :: [Demand] -> IdInfo+divergingIdInfo arg_dmds+  = vanillaIdInfo `setArityInfo` arity+                  `setDmdSigInfo` mkClosedDmdSig arg_dmds botDiv+                  `setCprSigInfo` mkCprSig arity botCpr+  where+    arity = length arg_dmds++{- Note [Error and friends have an "open-tyvar" forall]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'error' and 'undefined' have types+        error     :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a+        undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a+Notice the runtime-representation polymorphism. This ensures that+"error" can be instantiated at unboxed as well as boxed types.+This is OK because it never returns, so the return type is irrelevant.+++************************************************************************+*                                                                      *+                     iMPOSSIBLE_ERROR_ID+*                                                                      *+************************************************************************+-}++iMPOSSIBLE_ERROR_ID, iMPOSSIBLE_CONSTRAINT_ERROR_ID :: Id+iMPOSSIBLE_ERROR_ID            = mkRuntimeErrorId TypeLike       impossibleErrorName+iMPOSSIBLE_CONSTRAINT_ERROR_ID = mkRuntimeErrorId ConstraintLike impossibleConstraintErrorName++impossibleErrorName, impossibleConstraintErrorName :: Name+impossibleErrorName           = err_nm "impossibleError"+                                impossibleErrorIdKey iMPOSSIBLE_ERROR_ID+impossibleConstraintErrorName = err_nm "impossibleConstraintError"+                                impossibleConstraintErrorIdKey iMPOSSIBLE_CONSTRAINT_ERROR_ID++mkImpossibleExpr :: Type -> String -> CoreExpr+mkImpossibleExpr res_ty str+  = mkRuntimeErrorApp err_id res_ty str+  where    -- See Note [Type vs Constraint for error ids]+    err_id = case typeTypeOrConstraint res_ty of+               TypeLike       -> iMPOSSIBLE_ERROR_ID+               ConstraintLike -> iMPOSSIBLE_CONSTRAINT_ERROR_ID++{- Note [Type vs Constraint for error ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need both+  iMPOSSIBLE_ERROR_ID            :: forall (r::RuntimeRep) (a::TYPE r).       Addr# -> a+  iMPOSSIBLE_CONSTRAINT_ERROR_ID :: forall (r::RuntimeRep) (a::CONSTRAINT r). Addr# -> a++because we don't have polymorphism over TYPE vs CONSTRAINT.  You+might wonder if iMPOSSIBLE_CONSTRAINT_ERROR_ID is ever needed in+practice, but it is: see #22634.  So:++* In Control.Exception.Base we have+      impossibleError           :: forall (a::Type). Addr# -> a+      impossibleConstraintError :: forall (a::Type). Addr# -> a+  This generates the code for `impossibleError`, but because they are wired in+  the interface file definitions are never looked at (indeed, they don't+  even get serialised).++* In this module GHC.Core.Make we define /wired-in/ Ids for+      iMPOSSIBLE_ERROR_ID+      iMPOSSIBLE_CONSTRAINT_ERROR_ID+   with the desired above types (i.e. runtime-rep polymorphic, and returning a+   constraint for the latter.++Much the same plan works for aBSENT_ERROR_ID and aBSENT_CONSTRAINT_ERROR_ID+++************************************************************************+*                                                                      *+                     aBSENT_ERROR_ID+*                                                                      *+************************************************************************++Note [aBSENT_ERROR_ID]+~~~~~~~~~~~~~~~~~~~~~~+We use aBSENT_ERROR_ID to build absent fillers for lifted types in workers. E.g.++   f x = (case x of (a,b) -> b) + 1::Int++The demand analyser figures out that only the second component of x is+used, and does a w/w split thus++   f x = case x of (a,b) -> $wf b++   $wf b = let a = absentError "blah"+               x = (a,b)+           in <the original RHS of f>++After some simplification, the (absentError "blah") thunk normally goes away.+See also Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils.++Historical Note+---------------+We used to have exprIsHNF respond True to absentError and *not* mark it as diverging.+Here's the reason for the former. It doesn't apply anymore because we no longer say+that `a` is absent (A). Instead it gets (head strict) demand 1A and we won't+emit the absent error:++#14285 had, roughly++   data T a = MkT a !a+   {-# INLINABLE f #-}+   f x = case x of MkT a b -> g (MkT b a)++It turned out that g didn't use the second component, and hence f doesn't use+the first.  But the stable-unfolding for f looks like+   \x. case x of MkT a b -> g ($WMkT b a)+where $WMkT is the wrapper for MkT that evaluates its arguments.  We+apply the same w/w split to this unfolding (see Note [Worker/wrapper+for INLINABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like+   \b. let a = absentError "blah"+           x = MkT a b+        in case x of MkT a b -> g ($WMkT b a)++After doing case-of-known-constructor, and expanding $WMkT we get+   \b -> g (case absentError "blah" of a -> MkT b a)++Yikes!  That bogusly appears to evaluate the absentError!++This is extremely tiresome.  Another way to think of this is that, in+Core, it is an invariant that a strict data constructor, like MkT, must+be applied only to an argument in HNF. So (absentError "blah") had+better be non-bottom.++So the "solution" is to add a special case for absentError to exprIsHNFlike.+This allows Simplify.rebuildCase, in the Note [Case to let transformation]+branch, to convert the case on absentError into a let. We also make+absentError *not* be diverging, unlike the other error-ids, so that we+can be sure not to remove the case branches before converting the case to+a let.++If, by some bug or bizarre happenstance, we ever call absentError, we should+throw an exception.  This should never happen, of course, but we definitely+can't return anything.  e.g. if somehow we had+    case absentError "foo" of+       Nothing -> ...+       Just x  -> ...+then if we return, the case expression will select a field and continue.+Seg fault city. Better to throw an exception. (Even though we've said+it is in HNF :-)++It might seem a bit surprising that seq on absentError is simply erased++    absentError "foo" `seq` x ==> x++but that should be okay; since there's no pattern match we can't really+be relying on anything from it.+-}++-- We need two absentError Ids:+--   absentError           :: forall (a :: Type).       Addr# -> a+--   absentConstraintError :: forall (a :: Constraint). Addr# -> a+-- We don't have polymorphism over TypeOrConstraint!+-- mkAbsentErrorApp chooses which one to use, based on the kind+-- See Note [Type vs Constraint for error ids]++mkAbsentErrorApp :: Type         -- The type to instantiate 'a'+                 -> String       -- The string to print+                 -> CoreExpr++mkAbsentErrorApp res_ty err_msg+  = mkApps (Var err_id) [ Type res_ty, err_string ]+  where+    err_id = case typeTypeOrConstraint res_ty of+               TypeLike       -> aBSENT_ERROR_ID+               ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID+    err_string = Lit (mkLitString err_msg)++absentErrorName, absentConstraintErrorName :: Name+absentErrorName+   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")+      absentErrorIdKey aBSENT_ERROR_ID++absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]+   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")+      absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID++aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id++aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]+ = mk_runtime_error_id absentErrorName absent_ty+ where+   -- absentError :: forall (a :: Type). Addr# -> a+   absent_ty = mkSpecForAllTys [alphaTyVar] $+               mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)+   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for+   -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils++aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]+ = mk_runtime_error_id absentConstraintErrorName absent_ty+   -- See Note [Type vs Constraint for error ids]+ where+   -- absentConstraintError :: forall (a :: Constraint). Addr# -> a+   absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $+               mkFunTy visArgConstraintLike ManyTy+                       addrPrimTy (mkTyVarTy alphaConstraintTyVar)+++{-+************************************************************************+*                                                                      *+                     mkRuntimeErrorId+*                                                                      *+************************************************************************+-}++mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id+-- Error function+--   with type:  forall (r::RuntimeRep) (a::TYPE r). Addr# -> a+--   with arity: 1+-- which diverges after being given one argument+-- The Addr# is expected to be the address of+--   a UTF8-encoded error string+mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)+++mk_runtime_error_id :: Name -> Type -> Id+mk_runtime_error_id name ty+ = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])+     -- Do *not* mark them as NoCafRefs, because they can indeed have+     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,+     -- which has some CAFs+     -- In due course we may arrange that these error-y things are+     -- regarded by the GC as permanently live, in which case we+     -- can give them NoCaf info.  As it is, any function that calls+     -- any pc_bottoming_Id will itself have CafRefs, which bloats+     -- SRTs.++mkRuntimeErrorTy :: TypeOrConstraint -> Type+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a+--   See Note [Error and friends have an "open-tyvar" forall]+mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $+                        mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)+  where+    tyvar:|_ = expectNonEmpty $ mkTemplateTyVars [kind]+    kind = case torc of+              TypeLike       -> mkTYPEapp       runtimeRep1Ty+              ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty+
+ GHC/Core/Map/Expr.hs view
@@ -0,0 +1,470 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# OPTIONS_GHC -Wno-orphans #-}+ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)++module GHC.Core.Map.Expr (+   -- * Maps over Core expressions+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,+   -- * Alpha equality+   eqDeBruijnExpr, eqCoreExpr,+   -- * 'TrieMap' class reexports+   TrieMap(..), insertTM, deleteTM,+   lkDFreeVar, xtDFreeVar,+   lkDNamed, xtDNamed,+   (>.>), (|>), (|>>),+ ) where++import GHC.Prelude++import GHC.Data.TrieMap+import GHC.Core.Map.Type+import GHC.Core+import GHC.Core.Type+import GHC.Types.Tickish+import GHC.Types.Var++import GHC.Utils.Misc+import GHC.Utils.Outputable++import qualified Data.Map    as Map+import GHC.Types.Name.Env+import Control.Monad( (>=>) )+import GHC.Types.Literal (Literal)++{-+This module implements TrieMaps over Core related data structures+like CoreExpr or Type. It is built on the Tries from the TrieMap+module.++The code is very regular and boilerplate-like, but there is+some neat handling of *binders*.  In effect they are deBruijn+numbered on the fly.+++-}++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not+-- known when defining GenMap so we can only specialize them here.++{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}+++{-+************************************************************************+*                                                                      *+                   CoreMap+*                                                                      *+************************************************************************+-}++{-+Note [Binders]+~~~~~~~~~~~~~~+ * In general we check binders as late as possible because types are+   less likely to differ than expression structure.  That's why+      cm_lam :: CoreMapG (TypeMapG a)+   rather than+      cm_lam :: TypeMapG (CoreMapG a)++ * We don't need to look at the type of some binders, notably+     - the case binder in (Case _ b _ _)+     - the binders in an alternative+   because they are totally fixed by the context++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* For a key (Case e b ty (alt:alts))  we don't need to look the return type+  'ty', because every alternative has that type.++* For a key (Case e b ty []) we MUST look at the return type 'ty', because+  otherwise (Case (error () "urk") _ Int  []) would compare equal to+            (Case (error () "urk") _ Bool [])+  which is utterly wrong (#6097)++We could compare the return type regardless, but the wildly common case+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)+for the two possibilities.  Only cm_ecase looks at the type.++See also Note [Empty case alternatives] in GHC.Core.+-}++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this+-- is the type you want.+newtype CoreMap a = CoreMap (CoreMapG a)++-- TODO(22292): derive+instance Functor CoreMap where+    fmap f = \ (CoreMap m) -> CoreMap (fmap f m)+    {-# INLINE fmap #-}++instance TrieMap CoreMap where+    type Key CoreMap = CoreExpr+    emptyTM = CoreMap emptyTM+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)+    foldTM k (CoreMap m) = foldTM k m+    filterTM f (CoreMap m) = CoreMap (filterTM f m)+    mapMaybeTM f (CoreMap m) = CoreMap (mapMaybeTM f m)++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'CoreMap'+-- inside another 'TrieMap', this is the type you want.+type CoreMapG = GenMap CoreMapX++type LiteralMap  a = Map.Map Literal a++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without+-- the 'GenMap' optimization.+data CoreMapX a+  = CM { cm_var   :: VarMap a+       , cm_lit   :: LiteralMap a+       , cm_co    :: CoercionMapG a+       , cm_type  :: TypeMapG a+       , cm_cast  :: CoreMapG (CoercionMapG a)+       , cm_tick  :: CoreMapG (TickishMap a)+       , cm_app   :: CoreMapG (CoreMapG a)+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))+       , cm_case  :: CoreMapG (ListMap AltMap a)+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]+     }++instance Eq (DeBruijn CoreExpr) where+    (==) = eqDeBruijnExpr++eqDeBruijnExpr :: DeBruijn CoreExpr -> DeBruijn CoreExpr -> Bool+eqDeBruijnExpr (D env1 e1) (D env2 e2) = go e1 e2 where+    go (Var v1) (Var v2)             = eqDeBruijnVar (D env1 v1) (D env2 v2)+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2+    go (Type t1)    (Type t2)        = eqDeBruijnType (D env1 t1) (D env2 t2)+    -- See Note [Alpha-equality for Coercion arguments]+    go (Coercion {}) (Coercion {}) = True+    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2+    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2+    go (Tick n1 e1) (Tick n2 e2)+      =  eqDeBruijnTickish (D env1 n1) (D env2 n2)+      && go e1 e2++    go (Lam b1 e1)  (Lam b2 e2)+      =  eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))+      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)+      && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2)++    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go r1 r2 -- See Note [Alpha-equality for let-bindings]+      && eqDeBruijnExpr (D (extendCME env1 v1) e1) (D (extendCME env2 v2) e2)++    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = equalLength ps1 ps2+      -- See Note [Alpha-equality for let-bindings]+      && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1))+                                        (D env2 (varType b2)))+              bs1 bs2+      && D env1' rs1 == D env2' rs2+      && eqDeBruijnExpr (D env1' e1) (D env2' e2)+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env1' = extendCMEs env1 bs1+        env2' = extendCMEs env2 bs2++    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives]+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2+      | otherwise+      = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2++    go _ _ = False++eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool+eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where+    go (Breakpoint lext lid lids) (Breakpoint rext rid rids)+        =  lid == rid+        && D env1 lids == D env2 rids+        && lext == rext+    go l r = l == r++-- Compares for equality, modulo alpha+eqCoreExpr :: CoreExpr -> CoreExpr -> Bool+eqCoreExpr e1 e2 = eqDeBruijnExpr (deBruijnize e1) (deBruijnize e2)++{- Note [Alpha-equality for Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'Coercion' constructor only appears in argument positions, and so, if the+functions are equal, then the arguments must have equal types. Because the+comparison for coercions (correctly) checks only their types, checking for+alpha-equality of the coercions is redundant.+-}++{- Note [Alpha-equality for let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For /recursive/ let-bindings we need to check that the types of the binders+are alpha-equivalent. Otherwise++  letrec (x : Bool) = x in x++and++  letrec (y : Char) = y in y++would be considered alpha-equivalent, which they are obviously not.++For /non-recursive/ let-bindings, we do not have to check that the types of+the binders are alpha-equivalent. When the RHSs (the expressions) of the+non-recursive let-binders are well-formed and well-typed (which we assume they+are at this point in the compiler), and the RHSs are alpha-equivalent, then the+bindings must have the same type.++In addition, it is also worth pointing out that++  letrec { x = e1; y = e2 } in b++is NOT considered equal to++  letrec { y = e2; x = e1 } in b+-}++emptyE :: CoreMapX a+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM+            , cm_co = emptyTM, cm_type = emptyTM+            , cm_cast = emptyTM, cm_app = emptyTM+            , cm_lam = emptyTM, cm_letn = emptyTM+            , cm_letr = emptyTM, cm_case = emptyTM+            , cm_ecase = emptyTM, cm_tick = emptyTM }++-- TODO(22292): derive+instance Functor CoreMapX where+    fmap f CM+      { cm_var = cvar, cm_lit = clit, cm_co = cco, cm_type = ctype, cm_cast = ccast+      , cm_app = capp, cm_lam = clam, cm_letn = cletn, cm_letr = cletr, cm_case = ccase+      , cm_ecase = cecase, cm_tick = ctick } = CM+      { cm_var = fmap f cvar, cm_lit = fmap f clit, cm_co = fmap f cco, cm_type = fmap f ctype+      , cm_cast = fmap (fmap f) ccast, cm_app = fmap (fmap f) capp, cm_lam = fmap (fmap f) clam+      , cm_letn = fmap (fmap (fmap f)) cletn, cm_letr = fmap (fmap (fmap f)) cletr+      , cm_case = fmap (fmap f) ccase, cm_ecase = fmap (fmap f) cecase+      , cm_tick = fmap (fmap f) ctick }++instance TrieMap CoreMapX where+   type Key CoreMapX = DeBruijn CoreExpr+   emptyTM  = emptyE+   lookupTM = lkE+   alterTM  = xtE+   foldTM   = fdE+   filterTM = ftE+   mapMaybeTM = mpE++--------------------------+ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a+ftE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit+       , cm_co = filterTM f cco, cm_type = filterTM f ctype+       , cm_cast = fmap (filterTM f) ccast, cm_app = fmap (filterTM f) capp+       , cm_lam = fmap (filterTM f) clam, cm_letn = fmap (fmap (filterTM f)) cletn+       , cm_letr = fmap (fmap (filterTM f)) cletr, cm_case = fmap (filterTM f) ccase+       , cm_ecase = fmap (filterTM f) cecase, cm_tick = fmap (filterTM f) ctick }++mpE :: (a -> Maybe b) -> CoreMapX a -> CoreMapX b+mpE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapMaybeTM f cvar, cm_lit = mapMaybeTM f clit+       , cm_co = mapMaybeTM f cco, cm_type = mapMaybeTM f ctype+       , cm_cast = fmap (mapMaybeTM f) ccast, cm_app = fmap (mapMaybeTM f) capp+       , cm_lam = fmap (mapMaybeTM f) clam, cm_letn = fmap (fmap (mapMaybeTM f)) cletn+       , cm_letr = fmap (fmap (mapMaybeTM f)) cletr, cm_case = fmap (mapMaybeTM f) ccase+       , cm_ecase = fmap (mapMaybeTM f) cecase, cm_tick = fmap (mapMaybeTM f) ctick }++--------------------------+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a+lookupCoreMap cm e = lookupTM e cm++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a+extendCoreMap m e v = alterTM e (\_ -> Just v) m++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b+foldCoreMap k z m = foldTM k m z++emptyCoreMap :: CoreMap a+emptyCoreMap = emptyTM++instance Outputable a => Outputable (CoreMap a) where+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])++-------------------------+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b+fdE k m+  = foldTM k (cm_var m)+  . foldTM k (cm_lit m)+  . foldTM k (cm_co m)+  . foldTM k (cm_type m)+  . foldTM (foldTM k) (cm_cast m)+  . foldTM (foldTM k) (cm_tick m)+  . foldTM (foldTM k) (cm_app m)+  . foldTM (foldTM k) (cm_lam m)+  . foldTM (foldTM (foldTM k)) (cm_letn m)+  . foldTM (foldTM (foldTM k)) (cm_letr m)+  . foldTM (foldTM k) (cm_case m)+  . foldTM (foldTM k) (cm_ecase m)++-- lkE: lookup in trie for expressions+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a+lkE (D env expr) cm = go expr cm+  where+    go (Var v)              = cm_var  >.> lkVar env v+    go (Lit l)              = cm_lit  >.> lookupTM l+    go (Type t)             = cm_type >.> lkG (D env t)+    go (Coercion c)         = cm_co   >.> lkG (D env c)+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)+                              >=> lkBndr env v+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs+                                  env1 = extendCMEs env bndrs+                              in cm_letr+                                 >.> lkList (lkG . D env1) rhss+                                 >=> lkG (D env1 e)+                                 >=> lkList (lkBndr env1) bndrs+    go (Case e b ty as)     -- See Note [Empty case alternatives]+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)+               | otherwise  = cm_case >.> lkG (D env e)+                              >=> lkList (lkA (extendCME env b)) as++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a+xtE (D env (Var v))              f m = m { cm_var  = cm_var m+                                                 |> xtVar env v f }+xtE (D env (Type t))             f m = m { cm_type = cm_type m+                                                 |> xtG (D env t) f }+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m+                                                 |> xtG (D env c) f }+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)+                                                 |>> xtG (D env c) f }+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)+                                                 |>> xtTickish t f }+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)+                                                 |>> xtG (D env e1) f }+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m+                                                 |> xtG (D (extendCME env v) e)+                                                 |>> xtBndr env v f }+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m+                                                 |> xtG (D (extendCME env b) e)+                                                 |>> xtG (D env r)+                                                 |>> xtBndr env b f }+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =+                                              let (bndrs,rhss) = unzip prs+                                                  env1 = extendCMEs env bndrs+                                              in cm_letr m+                                                 |>  xtList (xtG . D env1) rhss+                                                 |>> xtG (D env1 e)+                                                 |>> xtList (xtBndr env1)+                                                            bndrs f }+xtE (D env (Case e b ty as))     f m+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)+                                                 |>> xtG (D env ty) f }+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)+                                                 |>> let env1 = extendCME env b+                                                     in xtList (xtA env1) as f }++-- TODO: this seems a bit dodgy, see 'eqTickish'+type TickishMap a = Map.Map CoreTickish a+lkTickish :: CoreTickish -> TickishMap a -> Maybe a+lkTickish = lookupTM++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a+xtTickish = alterTM++------------------------+data AltMap a   -- A single alternative+  = AM { am_deflt :: CoreMapG a+       , am_data  :: DNameEnv (CoreMapG a)+       , am_lit   :: LiteralMap (CoreMapG a) }++-- TODO(22292): derive+instance Functor AltMap where+    fmap f AM { am_deflt = adeflt, am_data = adata, am_lit = alit } = AM+      { am_deflt = fmap f adeflt, am_data = fmap (fmap f) adata, am_lit = fmap (fmap f) alit }++instance TrieMap AltMap where+   type Key AltMap = CoreAlt+   emptyTM  = AM { am_deflt = emptyTM+                 , am_data = emptyDNameEnv+                 , am_lit  = emptyTM }+   lookupTM = lkA emptyCME+   alterTM  = xtA emptyCME+   foldTM   = fdA+   filterTM = ftA+   mapMaybeTM = mpA++instance Eq (DeBruijn CoreAlt) where+  D env1 a1 == D env2 a2 = go a1 a2 where+    go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2)+        = D env1 rhs1 == D env2 rhs2+    go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2)+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2+    go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2)+        = dc1 == dc2 &&+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2+    go _ _ = False++ftA :: (a->Bool) -> AltMap a -> AltMap a+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = filterTM f adeflt+       , am_data = fmap (filterTM f) adata+       , am_lit = fmap (filterTM f) alit }++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a+lkA env (Alt DEFAULT      _  rhs) = am_deflt >.> lkG (D env rhs)+lkA env (Alt (LitAlt lit) _  rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)+lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc+                                        >=> lkG (D (extendCMEs env bs) rhs)++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a+xtA env (Alt DEFAULT _ rhs)      f m =+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }+xtA env (Alt (LitAlt l) _ rhs)   f m =+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }+xtA env (Alt (DataAlt d) bs rhs) f m =+    m { am_data  = am_data m  |> xtDNamed d+                             |>> xtG (D (extendCMEs env bs) rhs) f }++fdA :: (a -> b -> b) -> AltMap a -> b -> b+fdA k m = foldTM k (am_deflt m)+        . foldTM (foldTM k) (am_data m)+        . foldTM (foldTM k) (am_lit m)++mpA :: (a -> Maybe b) -> AltMap a -> AltMap b+mpA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapMaybeTM f adeflt+       , am_data = fmap (mapMaybeTM f) adata+       , am_lit = fmap (mapMaybeTM f) alit }
+ GHC/Core/Map/Type.hs view
@@ -0,0 +1,656 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Core.Map.Type (+     -- * Re-export generic interface+   TrieMap(..), XT,++     -- * Maps over 'Type's+   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,+   LooseTypeMap,+   -- ** With explicit scoping+   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,+   mkDeBruijnContext, extendCME, extendCMEs, emptyCME,++   -- * Utilities for use by friends only+   TypeMapG, CoercionMapG,++   DeBruijn(..), deBruijnize, eqDeBruijnType, eqDeBruijnVar,++   BndrMap, xtBndr, lkBndr,+   VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar,++   xtDNamed, lkDNamed++   ) where++-- This module is separate from GHC.Core.Map.Expr to avoid a module loop+-- between GHC.Core.Unify (which depends on this module) and GHC.Core++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Rep+import GHC.Core.TyCon( isForgetfulSynTyCon )+import GHC.Core.TyCo.Compare( eqForAllVis )+import GHC.Data.TrieMap++import GHC.Data.FastString+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import GHC.Utils.Outputable++import GHC.Utils.Panic++import qualified Data.Map    as Map+import qualified Data.IntMap as IntMap++import Control.Monad ( (>=>) )++-- NB: Be careful about RULES and type families (#5821).  So we should make sure+-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)++{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}+{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}++{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}+{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}++{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}++{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}++{-+************************************************************************+*                                                                      *+                   Coercions+*                                                                      *+************************************************************************+-}++-- We should really never care about the contents of a coercion. Instead,+-- just look up the coercion's type.+newtype CoercionMap a = CoercionMap (CoercionMapG a)++-- TODO(22292): derive+instance Functor CoercionMap where+    fmap f = \ (CoercionMap m) -> CoercionMap (fmap f m)+    {-# INLINE fmap #-}++instance TrieMap CoercionMap where+   type Key CoercionMap = Coercion+   emptyTM                     = CoercionMap emptyTM+   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m+   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)+   foldTM k    (CoercionMap m) = foldTM k m+   filterTM f  (CoercionMap m) = CoercionMap (filterTM f m)+   mapMaybeTM f (CoercionMap m) = CoercionMap (mapMaybeTM f m)++type CoercionMapG = GenMap CoercionMapX+newtype CoercionMapX a = CoercionMapX (TypeMapX a)++-- TODO(22292): derive+instance Functor CoercionMapX where+    fmap f = \ (CoercionMapX core_tm) -> CoercionMapX (fmap f core_tm)+    {-# INLINE fmap #-}++instance TrieMap CoercionMapX where+  type Key CoercionMapX = DeBruijn Coercion+  emptyTM = CoercionMapX emptyTM+  lookupTM = lkC+  alterTM  = xtC+  foldTM f (CoercionMapX core_tm) = foldTM f core_tm+  filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)+  mapMaybeTM f (CoercionMapX core_tm) = CoercionMapX (mapMaybeTM f core_tm)++instance Eq (DeBruijn Coercion) where+  D env1 co1 == D env2 co2+    = D env1 (coercionType co1) ==+      D env2 (coercionType co2)++lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a+lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)+                                        core_tm++xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a+xtC (D env co) f (CoercionMapX m)+  = CoercionMapX (xtT (D env $ coercionType co) f m)++{-+************************************************************************+*                                                                      *+                   Types+*                                                                      *+************************************************************************+-}++-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'TypeMap'+-- inside another 'TrieMap', this is the type you want. Note that this+-- lookup does not do a kind-check. Thus, all keys in this map must have+-- the same kind. Also note that this map respects the distinction between+-- @Type@ and @Constraint@, despite the fact that they are equivalent type+-- synonyms in Core.+type TypeMapG = GenMap TypeMapX++-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the+-- 'GenMap' optimization. See Note [Computing equality on types] in GHC.Core.Type.+data TypeMapX a+  = TM { tm_var    :: VarMap a+       , tm_app    :: TypeMapG (TypeMapG a)  -- Note [Equality on AppTys] in GHC.Core.Type+       , tm_tycon  :: DNameEnv a+       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr+       , tm_tylit  :: TyLitMap a+       , tm_coerce :: Maybe a+       }+    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type++-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the+-- last one? See Note [Equality on AppTys] in GHC.Core.Type+--+-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a).+trieMapView :: Type -> Maybe Type+trieMapView ty+  -- First check for TyConApps that need to be expanded to+  -- AppTy chains.  This includes eliminating FunTy entirely.+  | Just (tc, tys@(_:_)) <- splitTyConApp_maybe ty+  = Just $ foldl' AppTy (mkTyConTy tc) tys++  -- Then resolve any remaining nullary synonyms.+  | Just ty' <- coreView ty+  = Just ty'++trieMapView _ = Nothing++-- TODO(22292): derive+instance Functor TypeMapX where+    fmap f TM+      { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon, tm_forall = tforall+      , tm_tylit = tlit, tm_coerce = tcoerce } = TM+      { tm_var = fmap f tvar, tm_app = fmap (fmap f) tapp, tm_tycon = fmap f ttycon+      , tm_forall = fmap (fmap f) tforall+      , tm_tylit  = fmap f tlit, tm_coerce = fmap f tcoerce }++instance TrieMap TypeMapX where+   type Key TypeMapX = DeBruijn Type+   emptyTM  = emptyT+   lookupTM = lkT+   alterTM  = xtT+   foldTM   = fdT+   filterTM = filterT+   mapMaybeTM = mpT++instance Eq (DeBruijn Type) where+  (==) = eqDeBruijnType++-- | An equality relation between two 'Type's (known below as @t1 :: k2@+-- and @t2 :: k2@)+data TypeEquality = TNEQ -- ^ @t1 /= t2@+                  | TEQ  -- ^ @t1 ~ t2@ and there are not casts in either,+                         -- therefore we can conclude @k1 ~ k2@+                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so+                         -- they may differ in kind++eqDeBruijnType :: DeBruijn Type -> DeBruijn Type -> Bool+eqDeBruijnType env_t1@(D env1 t1) env_t2@(D env2 t2) =+    -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+    -- See Note [Computing equality on types]+    case go env_t1 env_t2 of+      TEQX  -> toBool (go (D env1 k1) (D env2 k2))+      ty_eq -> toBool ty_eq+  where+    k1 = typeKind t1+    k2 = typeKind t2++    toBool :: TypeEquality -> Bool+    toBool TNEQ = False+    toBool _    = True++    liftEquality :: Bool -> TypeEquality+    liftEquality False = TNEQ+    liftEquality _     = TEQ++    hasCast :: TypeEquality -> TypeEquality+    hasCast TEQ = TEQX+    hasCast eq  = eq++    andEq :: TypeEquality -> TypeEquality -> TypeEquality+    andEq TNEQ _ = TNEQ+    andEq TEQX e = hasCast e+    andEq TEQ  e = e++    -- See Note [Comparing type synonyms] in GHC.Core.TyCo.Compare+    go (D env1 (TyConApp tc1 tys1)) (D env2 (TyConApp tc2 tys2))+      | tc1 == tc2, not (isForgetfulSynTyCon tc1)+      = gos env1 env2 tys1 tys2++    go env_t@(D env t) env_t'@(D env' t')+      | Just new_t  <- coreView t  = go (D env new_t) env_t'+      | Just new_t' <- coreView t' = go env_t (D env' new_t')+      | otherwise+      = case (t, t') of+          -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+          (CastTy t1 _, _)  -> hasCast (go (D env t1) (D env t'))+          (_, CastTy t1' _) -> hasCast (go (D env t) (D env t1'))++          (TyVarTy v, TyVarTy v')+              -> liftEquality $ eqDeBruijnVar (D env v) (D env' v')+          -- See Note [Equality on AppTys] in GHC.Core.Type+          (AppTy t1 t2, s) | Just (t1', t2') <- splitAppTyNoView_maybe s+              -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2')+          (s, AppTy t1' t2') | Just (t1, t2) <- splitAppTyNoView_maybe s+              -> go (D env t1) (D env' t1') `andEq` go (D env t2) (D env' t2')+          (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2')++              -> liftEquality (v1 == v1') `andEq`+                 -- NB: eqDeBruijnType does the kind check requested by+                 -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep+                 liftEquality (eqDeBruijnType (D env t1) (D env' t1')) `andEq`+                 liftEquality (eqDeBruijnType (D env t2) (D env' t2')) `andEq`+                 -- Comparing multiplicities last because the test is usually true+                 go (D env w1) (D env w1')+          (TyConApp tc tys, TyConApp tc' tys')+              -> liftEquality (tc == tc') `andEq` gos env env' tys tys'+          (LitTy l, LitTy l')+              -> liftEquality (l == l')+          (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty')+              -> -- See Note [ForAllTy and type equality] in+                 -- GHC.Core.TyCo.Compare for why we use `eqForAllVis` here+                 liftEquality (vis `eqForAllVis` vis') `andEq`+                 go (D env (varType tv)) (D env' (varType tv')) `andEq`+                 go (D (extendCME env tv) ty) (D (extendCME env' tv') ty')+          (CoercionTy {}, CoercionTy {})+              -> TEQ+          _ -> TNEQ++    -- These bangs make 'gos' strict in the CMEnv, which in turn+    -- keeps the CMEnv unboxed across the go/gos mutual recursion+    -- (If you want a test case, T9872c really exercises this code.)+    gos !_  !_  []         []       = TEQ+    gos e1 e2 (ty1:tys1) (ty2:tys2) = go (D e1 ty1) (D e2 ty2) `andEq`+                                      gos e1 e2 tys1 tys2+    gos _  _  _          _          = TNEQ++instance Eq (DeBruijn Var) where+  (==) = eqDeBruijnVar++eqDeBruijnVar :: DeBruijn Var -> DeBruijn Var -> Bool+eqDeBruijnVar (D env1 v1) (D env2 v2) =+    case (lookupCME env1 v1, lookupCME env2 v2) of+        (Just b1, Just b2) -> b1 == b2+        (Nothing, Nothing) -> v1 == v2+        _ -> False++instance {-# OVERLAPPING #-}+         Outputable a => Outputable (TypeMapG a) where+  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])++emptyT :: TypeMapX a+emptyT = TM { tm_var  = emptyTM+            , tm_app  = emptyTM+            , tm_tycon  = emptyDNameEnv+            , tm_forall = emptyTM+            , tm_tylit  = emptyTyLitMap+            , tm_coerce = Nothing }++-----------------+lkT :: DeBruijn Type -> TypeMapX a -> Maybe a+lkT (D env ty) m = go ty m+  where+    go ty | Just ty' <- trieMapView ty = go ty'+    go (TyVarTy v)                 = tm_var    >.> lkVar env v+    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)+                                               >=> lkG (D env t2)+    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc+    go (LitTy l)                   = tm_tylit  >.> lkTyLit l+    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)+                                               >=> lkBndr env tv+    go (CastTy t _)                = go t+    go (CoercionTy {})             = tm_coerce++    -- trieMapView has eliminated non-nullary TyConApp+    -- and FunTy into an AppTy chain+    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)+    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)++-----------------+xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a+xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m++xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }+xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)+                                                            |>> xtG (D env t2) f }+xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }+xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }+xtT (D env (CastTy t _))      f m = xtT (D env t) f m+xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }+xtT (D env (ForAllTy (Bndr tv _) ty))  f m+  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)+                                |>> xtBndr env tv f }++-- trieMapView has eliminated non-nullary TyConApp+-- and FunTy into an AppTy chain+xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)+xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)++fdT :: (a -> b -> b) -> TypeMapX a -> b -> b+fdT k m = foldTM k (tm_var m)+        . foldTM (foldTM k) (tm_app m)+        . foldTM k (tm_tycon m)+        . foldTM (foldTM k) (tm_forall m)+        . foldTyLit k (tm_tylit m)+        . foldMaybe k (tm_coerce m)++filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a+filterT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+              , tm_forall = tforall, tm_tylit = tlit+              , tm_coerce = tcoerce })+  = TM { tm_var    = filterTM f tvar+       , tm_app    = fmap (filterTM f) tapp+       , tm_tycon  = filterTM f ttycon+       , tm_forall = fmap (filterTM f) tforall+       , tm_tylit  = filterTM f tlit+       , tm_coerce = filterMaybe f tcoerce }++------------------------+data TyLitMap a = TLM { tlm_number :: Map.Map Integer a+                      , tlm_string :: UniqFM  FastString a+                      , tlm_char   :: Map.Map Char a+                      }++-- TODO(22292): derive+instance Functor TyLitMap where+    fmap f TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc } = TLM+      { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }++instance TrieMap TyLitMap where+   type Key TyLitMap = TyLit+   emptyTM  = emptyTyLitMap+   lookupTM = lkTyLit+   alterTM  = xtTyLit+   foldTM   = foldTyLit+   filterTM = filterTyLit+   mapMaybeTM = mpTyLit++emptyTyLitMap :: TyLitMap a+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }++lkTyLit :: TyLit -> TyLitMap a -> Maybe a+lkTyLit l =+  case l of+    NumTyLit n -> tlm_number >.> Map.lookup n+    StrTyLit n -> tlm_string >.> (`lookupUFM` n)+    CharTyLit n -> tlm_char >.> Map.lookup n++xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a+xtTyLit l f m =+  case l of+    NumTyLit n ->  m { tlm_number = Map.alter f n (tlm_number m) }+    StrTyLit n ->  m { tlm_string = alterUFM  f (tlm_string m) n }+    CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }++foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b+foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m)+              . flip (Map.foldr l) (tlm_number m)+              . flip (Map.foldr l) (tlm_char m)++filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }++mpTyLit :: (a -> Maybe b) -> TyLitMap a -> TyLitMap b+mpTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.mapMaybe f tn, tlm_string = mapMaybeUFM f ts, tlm_char = Map.mapMaybe f tc }++-------------------------------------------------+-- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this+-- is the type you want. The keys in this map may have different kinds.+newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))++-- TODO(22292): derive+instance Functor TypeMap where+    fmap f = \ (TypeMap m) -> TypeMap (fmap (fmap f) m)+    {-# INLINE fmap #-}++lkTT :: DeBruijn Type -> TypeMap a -> Maybe a+lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m+                          >>= lkG (D env ty)++xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a+xtTT (D env ty) f (TypeMap m)+  = TypeMap (m |> xtG (D env $ typeKind ty)+               |>> xtG (D env ty) f)++-- Below are some client-oriented functions which operate on 'TypeMap'.++instance TrieMap TypeMap where+    type Key TypeMap = Type+    emptyTM = TypeMap emptyTM+    lookupTM k m = lkTT (deBruijnize k) m+    alterTM k f m = xtTT (deBruijnize k) f m+    foldTM k (TypeMap m) = foldTM (foldTM k) m+    filterTM f (TypeMap m) = TypeMap (fmap (filterTM f) m)+    mapMaybeTM f (TypeMap m) = TypeMap (fmap (mapMaybeTM f) m)++foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b+foldTypeMap k z m = foldTM k m z++emptyTypeMap :: TypeMap a+emptyTypeMap = emptyTM++lookupTypeMap :: TypeMap a -> Type -> Maybe a+lookupTypeMap cm t = lookupTM t cm++extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a+extendTypeMap m t v = alterTM t (const (Just v)) m++lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a+lookupTypeMapWithScope m cm t = lkTT (D cm t) m++-- | Extend a 'TypeMap' with a type in the given context.+-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to+-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over+-- multiple insertions.+extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a+extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m++-- | Construct a deBruijn environment with the given variables in scope.+-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@+mkDeBruijnContext :: [Var] -> CmEnv+mkDeBruijnContext = extendCMEs emptyCME++-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),+-- you'll find entries inserted under (t), even if (g) is non-reflexive.+newtype LooseTypeMap a = LooseTypeMap (TypeMapG a)++-- TODO(22292): derive+instance Functor LooseTypeMap where+    fmap f = \ (LooseTypeMap m) -> LooseTypeMap (fmap f m)+    {-# INLINE fmap #-}++instance TrieMap LooseTypeMap where+  type Key LooseTypeMap = Type+  emptyTM = LooseTypeMap emptyTM+  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m+  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)+  foldTM f (LooseTypeMap m) = foldTM f m+  filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)+  mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m)++{-+************************************************************************+*                                                                      *+                   Variables+*                                                                      *+************************************************************************+-}++type BoundVar = Int  -- Bound variables are deBruijn numbered+type BoundVarMap a = IntMap.IntMap a++data CmEnv = CME { cme_next :: !BoundVar+                 , cme_env  :: VarEnv BoundVar }++emptyCME :: CmEnv+emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }++extendCME :: CmEnv -> Var -> CmEnv+extendCME (CME { cme_next = bv, cme_env = env }) v+  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }++extendCMEs :: CmEnv -> [Var] -> CmEnv+extendCMEs env vs = foldl' extendCME env vs++lookupCME :: CmEnv -> Var -> Maybe BoundVar+lookupCME (CME { cme_env = env }) v = lookupVarEnv env v++-- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved+-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn+-- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even+-- if this was not (easily) possible for @a@.  Note: we purposely don't+-- export the constructor.  Make a helper function if you find yourself+-- needing it.+data DeBruijn a = D CmEnv a++-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no+-- bound binders (an empty 'CmEnv').  This is usually what you want if there+-- isn't already a 'CmEnv' in scope.+deBruijnize :: a -> DeBruijn a+deBruijnize = D emptyCME++instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where+    D _   []     == D _    []       = True+    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&+                                      D env xs == D env' xs'+    _            == _               = False++instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where+    D _   Nothing  == D _    Nothing   = True+    D env (Just x) == D env' (Just x') = D env x  == D env' x'+    _              == _                = False++--------- Variable binders -------------++-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between+-- binding forms whose binders have different types.  For example,+-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should+-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:+-- we can disambiguate this by matching on the type (or kind, if this+-- a binder in a type) of the binder.+--+-- We also need to do the same for multiplicity! Which, since multiplicities are+-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries+-- of pairs are composition.+data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))++-- TODO(22292): derive+instance Functor BndrMap where+    fmap f = \ (BndrMap tm) -> BndrMap (fmap (fmap f) tm)+    {-# INLINE fmap #-}++instance TrieMap BndrMap where+   type Key BndrMap = Var+   emptyTM  = BndrMap emptyTM+   lookupTM = lkBndr emptyCME+   alterTM  = xtBndr emptyCME+   foldTM   = fdBndrMap+   filterTM = ftBndrMap+   mapMaybeTM = mpBndrMap++fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b+fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm++mpBndrMap :: (a -> Maybe b) -> BndrMap a -> BndrMap b+mpBndrMap f (BndrMap tm) = BndrMap (fmap (mapMaybeTM f) tm)++-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all+-- of these data types have binding forms.++lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a+lkBndr env v (BndrMap tymap) = do+  multmap <- lkG (D env (varType v)) tymap+  lookupTM (D env <$> varMultMaybe v) multmap+++xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a+xtBndr env v xt (BndrMap tymap)  =+  BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))++ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a+ftBndrMap f (BndrMap tm) = BndrMap (fmap (filterTM f) tm)++--------- Variable occurrence -------------+data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable+                   , vm_fvar   :: DVarEnv a }      -- Free variable++-- TODO(22292): derive+instance Functor VarMap where+    fmap f VM { vm_bvar = bv, vm_fvar = fv } = VM { vm_bvar = fmap f bv, vm_fvar = fmap f fv }++instance TrieMap VarMap where+   type Key VarMap = Var+   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }+   lookupTM = lkVar emptyCME+   alterTM  = xtVar emptyCME+   foldTM   = fdVar+   filterTM = ftVar+   mapMaybeTM = mpVar++lkVar :: CmEnv -> Var -> VarMap a -> Maybe a+lkVar env v+  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv+  | otherwise                  = vm_fvar >.> lkDFreeVar v++xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a+xtVar env v f m+  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }+  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }++fdVar :: (a -> b -> b) -> VarMap a -> b -> b+fdVar k m = foldTM k (vm_bvar m)+          . foldTM k (vm_fvar m)++lkDFreeVar :: Var -> DVarEnv a -> Maybe a+lkDFreeVar var env = lookupDVarEnv env var++xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a+xtDFreeVar v f m = alterDVarEnv f m v++ftVar :: (a -> Bool) -> VarMap a -> VarMap a+ftVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv }++mpVar :: (a -> Maybe b) -> VarMap a -> VarMap b+mpVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapMaybeTM f bv, vm_fvar = mapMaybeTM f fv }++-------------------------------------------------+lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a+lkDNamed n env = lookupDNameEnv env (getName n)++xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a+xtDNamed tc f m = alterDNameEnv f m (getName tc)++mpT :: (a -> Maybe b) -> TypeMapX a -> TypeMapX b+mpT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+          , tm_forall = tforall, tm_tylit = tlit+          , tm_coerce = tcoerce })+  = TM { tm_var    = mapMaybeTM f tvar+       , tm_app    = fmap (mapMaybeTM f) tapp+       , tm_tycon  = mapMaybeTM f ttycon+       , tm_forall = fmap (mapMaybeTM f) tforall+       , tm_tylit  = mapMaybeTM f tlit+       , tm_coerce = tcoerce >>= f }
+ GHC/Core/Multiplicity.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE PatternSynonyms    #-}++{-|+This module defines the semi-ring of multiplicities, and associated functions.+Multiplicities annotate arrow types to indicate the linearity of the+arrow (in the sense of linear types).++Mult is a type synonym for Type, used only when its kind is Multiplicity.+To simplify dealing with multiplicities, functions such as+mkMultMul perform simplifications such as Many * x = Many on the fly.+-}+module GHC.Core.Multiplicity+  ( Mult+  , pattern OneTy+  , pattern ManyTy+  , isMultMul+  , mkMultAdd+  , mkMultMul+  , mkMultSup+  , Scaled(..)+  , scaledMult+  , scaledThing+  , unrestricted+  , linear+  , tymult+  , irrelevantMult+  , mkScaled+  , scaledSet+  , scaleScaled+  , IsSubmult(..)+  , submult+  , mapScaledType+  , pprArrowWithMultiplicity+  , MultiplicityFlag(..)+  ) where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Core.Type+import GHC.Core.TyCo.Rep+import GHC.Types.Var( isFUNArg )+import {-# SOURCE #-} GHC.Builtin.Types ( multMulTyCon )+import GHC.Builtin.Names (multMulTyConKey)+import GHC.Types.Unique (hasKey)++{-+Note [Linear types]+~~~~~~~~~~~~~~~~~~~+This module is the entry point for linear types.++The detailed design is in the _Linear Haskell_ article+[https://arxiv.org/abs/1710.09756]. Other important resources in the linear+types implementation wiki page+[https://gitlab.haskell.org/ghc/ghc/wikis/linear-types/implementation], and the+proposal [https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0111-linear-types.rst] which+describes the concrete design at length.++For the busy developer, though, here is a high-level view of linear types is the following:++- Function arrows are annotated with a multiplicity (as defined by type `Mult`+  and its smart constructors in this module)+    - Multiplicities, in Haskell, are types of kind `GHC.Types.Multiplicity`.+      as in++        map :: forall (p :: Multiplicity). (a %p -> b) -> [a] %p -> [b]++    - The type constructor for function types (FUN) has type++        FUN :: forall (m :: Multiplicity) -> forall {r1) {r2}. TYPE r1 -> TYPE r2 -> Type++      The argument order is explained in https://gitlab.haskell.org/ghc/ghc/-/issues/20164+    - (->) retains its backward compatible meaning:++        (->) a b = a -> b = a %'Many -> b++      To achieve this, `(->)` is defined as a type synonym to `FUN Many` (see+      below).+- A ground multiplicity (that is, without a variable) can be `One` or `Many`+  (`Many` is generally rendered as ω in the scientific literature).+  Functions whose type is annotated with `One` are linear functions, functions whose+  type is annotated with `Many` are regular functions, often called “unrestricted”+  to contrast them with linear functions.+- A linear function is defined as a function such that *if* its result is+  consumed exactly once, *then* its argument is consumed exactly once. You can+  think of “consuming exactly once” as evaluating a value in normal form exactly+  once (though not necessarily in one go). The _Linear Haskell_ article (see+  supra) has a more precise definition of “consuming exactly once”.+- Data constructors are linear by default.+  See Note [Data constructors are linear by default].+- Multiplicities form a semiring.+- Multiplicities can also be variables and we can universally quantify over+  these variables. This is referred to as “multiplicity+  polymorphism”. Furthermore, multiplicity can be formal semiring expressions+  combining variables.+- Contrary to the paper, the sum of two multiplicities is always `Many`. This+  will have to change, however, if we want to add a multiplicity for 0. Whether+  we want to is still debated.+- Case expressions have a multiplicity annotation too. A case expression with+  multiplicity `One`, consumes its scrutinee exactly once (provided the entire+  case expression is consumed exactly once); whereas a case expression with+  multiplicity `Many` can consume its scrutinee as many time as it wishes (no+  matter how much the case expression is consumed).++For linear types in the linter see Note [Linting linearity] in GHC.Core.Lint.++Note [Usages]+~~~~~~~~~~~~~+In the _Linear Haskell_ paper, you'll find typing rules such as these:++    Γ ⊢ f : A #π-> B  Δ ⊢ u : A+    ---------------------------+        Γ + kΔ ⊢ f u : B++If you read this as a type-checking algorithm going from the bottom up, this+reads as: the algorithm has to find a split of some input context Ξ into an+appropriate Γ and a Δ such as Ξ = Γ + kΔ, *and the multiplicities are chosen to+make f and u typecheck*.++This could be achieved by letting the typechecking of `f` use exactly the+variable it needs, then passing the remainder, as `Delta` to the typechecking of+u. But what does that mean if `x` is bound with multiplicity `p` (a variable)+and `f` consumes `x` once? `Delta` would have to contain `x` with multiplicity+`p-1`. It's not really clear how to make that works. In summary: bottom-up+multiplicity checking forgoes addition and multiplication in favour of+subtraction and division. And variables make the latter hard.++The alternative is to read multiplicities from the top down: as an *output* from+the typechecking algorithm, rather than an input. We call these output+multiplicities Usages, to distinguish them from the multiplicities which come,+as input, from the types of functions. Usages are checked for compatibility with+multiplicity annotations using an ordering relation. In other words, the usage+of x in the expression u is the smallest multiplicity which can be ascribed to x+for u to typecheck.++Usages are usually group in a UsageEnv, as defined in the UsageEnv module.++So, in our function application example, the typechecking algorithm would+receive usage environments f_ue from the typechecking of f, and u_ue from the+typechecking of u. Then the output would be f_ue + (k * u_ue). Addition and+scaling of usage environment is the pointwise extension of the semiring+operations on multiplicities.++Note [Zero as a usage]+~~~~~~~~~~~~~~~~~~~~~~+In the current presentation usages are not exactly multiplicities, because they+can contain 0, and multiplicities can't.++Why do we need a 0 usage? A function which doesn't use its argument will be+required to annotate it with `Many`:++    \(x % Many) -> 0++However, we cannot replace absence with Many when computing usages+compositionally: in++    (x, True)++We expect x to have usage 1. But when computing the usage of x in True we would+find that x is absent, hence has multiplicity Many. The final multiplicity would+be One+Many = Many. Oops!++Hence there is a usage Zero for absent variables. Zero is characterised by being+the neutral element to usage addition.++We may decide to add Zero as a multiplicity in the future. In which case, this+distinction will go away.++Note [Joining usages]+~~~~~~~~~~~~~~~~~~~~~+The usage of a variable is defined, in Note [Usages], as the minimum usage which+can be ascribed to a variable.++So what is the usage of x in++    case … of+      { p1 -> u   -- usage env: u_ue+      ; p2 -> v } -- usage env: v_ue++It must be the least upper bound, or _join_, of u_ue(x) and v_ue(x).++So, contrary to a declarative presentation where the correct usage of x can be+conjured out of thin air, we need to be able to compute the join of two+multiplicities. Join is extended pointwise on usage environments.++Note [Bottom as a usage]+~~~~~~~~~~~~~~~~~~~~~~+What is the usage of x in++   case … of {}++Per usual linear logic, as well as the _Linear Haskell_ article, x can have+every multiplicity.++So we need a minimum usage _bottom_, which is also the neutral element for join.++In fact, this is not such as nice solution, because it is not clear how to+define sum and multiplication with bottom. We give reasonable definitions, but+they are not complete (they don't respect the semiring laws, and it's possible+to come up with examples of Core transformation which are not well-typed)++A better solution would probably be to annotate case expressions with a usage+environment, just like they are annotated with a type. Which, probably not+coincidentally, is also primarily for empty cases.++A side benefit of this approach is that the linter would not need to join+multiplicities, anymore; hence would be closer to the presentation in the+article. That's because it could use the annotation as the multiplicity for each+branch.++Note [Data constructors are linear by default]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All data constructors defined without -XLinearTypes, as well as data constructors+defined with the Haskell 98 in all circumstances, have all their fields linear.++That is, in++    data Maybe a = Nothing | Just a++We have++    Just :: a %1 -> Just a++Irrespective of whether -XLinearTypes is turned on or not. Furthermore, when+-XLinearTypes is turned off, the declaration++    data Endo a where { MkIntEndo :: (Int -> Int) -> T Int }++gives++    MkIntEndo :: (Int -> Int) %1 -> T Int++With -XLinearTypes turned on, instead, this would give++    data EndoU a where { MkIntEndoU :: (Int -> Int) -> T Int }+    MkIntEndoU :: (Int -> Int) -> T Int++With -XLinearTypes turned on, to get a linear field with GADT syntax we+would need to write++    data EndoL a where { MkIntEndoL :: (Int -> Int) %1 -> T Int }++The goal is to maximise reuse of types between linear code and traditional+code. This is argued at length in the proposal and the article (links in Note+[Linear types]).++Unrestricted field don't need to be consumed for a value to be consumed exactly+once. So consuming a value of type `IntEndoU a` exactly once means forcing it at+least once.++Why “at least once”? Because if `case u of { MkIntEndoL x -> f (MkIntEndoL x) }`+is linear (provided `f` is a linear function). But we might as well have done+`case u of { !z -> f z }`. So, we can observe constructors as many times as we+want, and we are actually allowed to force the same thing several times because+laziness means that we are really forcing the value once, and observing its+constructor several times. The type checker and the linter recognise some (but+not all) of these multiple forces as indeed linear. Mostly just enough to+support variable patterns.++In summary:++- Fields of data constructors defined with Haskell 98 syntax are always linear+  (even if `-XLinearTypes` is off). This choice has been made to favour sharing+  types between linearly typed Haskell and traditional Haskell. To avoid an+  ecosystem split.+- When `-XLinearTypes` is off, GADT-syntax declaration can only use the regular+  arrow `(->)`. However all the fields are linear.+++Note [Polymorphisation of linear fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The choice in Note [Data constructors are linear by default] has an impact on+backwards compatibility. Consider++    map Just++We have++    map :: (a -> b) -> f a -> f b+    Just :: a %1 -> Just a++Types don't match, we should get a type error. But this is legal Haskell 98+code! Bad! Bad! Bad!++It could be solved with subtyping, but subtyping doesn't combine well with+polymorphism. Instead, we generalise the type of Just, when used as term:++   Just :: forall {p}. a %p-> Just a++This is solely a concern for higher-order code like this: when called fully+applied linear constructors are more general than constructors with unrestricted+fields. In particular, linear constructors can always be eta-expanded to their+Haskell 98 type. This is explained in the paper (but there, we had a different+strategy to resolve this type mismatch in higher-order code. It turned out to be+insufficient, which is explained in the wiki page as well as the proposal).++We only generalise linear fields this way: fields with multiplicity Many, or+other multiplicity expressions are exclusive to -XLinearTypes, hence don't have+backward compatibility implications.++The implementation is described in Note [Typechecking data constructors]+in GHC.Tc.Gen.Head.++More details in the proposal.+-}++{-+Note [Adding new multiplicities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To add a new multiplicity, you need to:+* Add the new type with Multiplicity kind+* Update cases in mkMultAdd, mkMultMul, mkMultSup, submult, tcSubMult+* Check supUE function that computes sup of a multiplicity+  and Zero+-}++isMultMul :: Mult -> Maybe (Mult, Mult)+isMultMul ty | Just (tc, [x, y]) <- splitTyConApp_maybe ty+             , tc `hasKey` multMulTyConKey = Just (x, y)+             | otherwise = Nothing++{-+Note [Overapproximating multiplicities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions mkMultAdd, mkMultMul, mkMultSup perform operations+on multiplicities. They can return overapproximations: their result+is merely guaranteed to be a submultiplicity of the actual value.++They should be used only when an upper bound is acceptable.+In most cases, they are used in usage environments (UsageEnv);+in usage environments, replacing a usage with a larger one can only+cause more programs to fail to typecheck.++In future work, instead of approximating we might add type families+and allow users to write types involving operations on multiplicities.+In this case, we could enforce more invariants in Mult, for example,+enforce that it is in the form of a sum of products, and even+that the summands and factors are ordered somehow, to have more equalities.+-}++-- With only two multiplicities One and Many, we can always replace+-- p + q by Many. See Note [Overapproximating multiplicities].+mkMultAdd :: Mult -> Mult -> Mult+mkMultAdd _ _ = ManyTy++mkMultMul :: Mult -> Mult -> Mult+mkMultMul OneTy  p      = p+mkMultMul p      OneTy  = p+mkMultMul ManyTy _      = ManyTy+mkMultMul _      ManyTy = ManyTy+mkMultMul p q = mkTyConApp multMulTyCon [p, q]++scaleScaled :: Mult -> Scaled a -> Scaled a+scaleScaled m' (Scaled m t) = Scaled (m' `mkMultMul` m) t++-- See Note [Joining usages]+-- | @mkMultSup w1 w2@ returns a multiplicity such that @mkMultSup w1+-- w2 >= w1@ and @mkMultSup w1 w2 >= w2@. See Note [Overapproximating multiplicities].+mkMultSup :: Mult -> Mult -> Mult+mkMultSup = mkMultMul+-- Note: If you are changing this logic, check 'supUE' in UsageEnv as well.++--+-- * Multiplicity ordering+--++data IsSubmult = Submult     -- Definitely a submult+               | Unknown     -- Could be a submult, need to ask the typechecker+               deriving (Show, Eq)++instance Outputable IsSubmult where+  ppr = text . show++-- | @submult w1 w2@ check whether a value of multiplicity @w1@ is allowed where a+-- value of multiplicity @w2@ is expected. This is a partial order.++submult :: Mult -> Mult -> IsSubmult+submult _     ManyTy = Submult+submult OneTy OneTy  = Submult+-- The 1 <= p rule+submult OneTy _    = Submult+submult _     _    = Unknown++pprArrowWithMultiplicity :: FunTyFlag -> Either Bool SDoc -> SDoc+-- Pretty-print a multiplicity arrow.  The multiplicity itself+-- is described by the (Either Bool SDoc)+--    Left False   -- Many+--    Left True    -- One+--    Right doc    -- Something else+-- In the Right case, the doc is in parens if not atomic+pprArrowWithMultiplicity af pp_mult+  | isFUNArg af+  = case pp_mult of+      Left False -> arrow+      Left True  -> lollipop+      Right doc  -> text "%" <> doc <+> arrow+  | otherwise+  = ppr (funTyFlagTyCon af)++-- | In Core, without `-dlinear-core-lint`, some function must ignore+-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint.+data MultiplicityFlag+  = RespectMultiplicities+  | IgnoreMultiplicities
+ GHC/Core/Opt/Arity.hs view
@@ -0,0 +1,3262 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++        Arity and eta expansion+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++-- | Arity and eta expansion+module GHC.Core.Opt.Arity+   ( -- Finding arity+     manifestArity, joinRhsArity, exprArity+   , findRhsArity, cheapArityType+   , ArityOpts(..)++   -- ** Eta expansion+   , exprEtaExpandArity, etaExpand, etaExpandAT++   -- ** Eta reduction+   , tryEtaReduce++   -- ** ArityType+   , ArityType, mkBotArityType+   , arityTypeArity, idArityType++   -- ** Bottoming things+   , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe++   -- ** typeArity and the state hack+   , typeArity, typeOneShots, typeOneShot+   , isOneShotBndr+   , isStateHackType++   -- * Lambdas+   , zapLamBndrs+++   -- ** Join points+   , etaExpandToJoinPoint, etaExpandToJoinPointRule++   -- ** Coercions and casts+   , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg+   , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo+   )+where++import GHC.Prelude++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.DataCon+import GHC.Core.TyCon     ( TyCon, tyConArity, isInjectiveTyCon )+import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )+import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy )+import GHC.Core.Multiplicity++-- We have two sorts of substitution:+--   GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst+-- Both have substTy, substCo  Hence need for qualification+import GHC.Core.Subst    as Core+import GHC.Core.Type     as Type+import GHC.Core.Coercion as Type+import GHC.Core.TyCo.Compare( eqType )++import GHC.Types.Demand+import GHC.Types.Cpr( CprSig, mkCprSig, botCpr )+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Types.Tickish++import GHC.Builtin.Types.Prim+import GHC.Builtin.Uniques++import GHC.Data.FastString+import GHC.Data.Graph.UnVar+import GHC.Data.Pair++import GHC.Utils.GlobalVars( unsafeHasNoStateHack )+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.List.NonEmpty ( nonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Maybe( isJust )++{-+************************************************************************+*                                                                      *+              manifestArity and exprArity+*                                                                      *+************************************************************************++exprArity is a cheap-and-cheerful version of exprEtaExpandArity.+It tells how many things the expression can be applied to before doing+any work.  It doesn't look inside cases, lets, etc.  The idea is that+exprEtaExpandArity will do the hard work, leaving something that's easy+for exprArity to grapple with.  In particular, Simplify uses exprArity to+compute the ArityInfo for the Id.++Originally I thought that it was enough just to look for top-level lambdas, but+it isn't.  I've seen this++        foo = PrelBase.timesInt++We want foo to get arity 2 even though the eta-expander will leave it+unchanged, in the expectation that it'll be inlined.  But occasionally it+isn't, because foo is blacklisted (used in a rule).++Similarly, see the ok_note check in exprEtaExpandArity.  So+        f = __inline_me (\x -> e)+won't be eta-expanded.++And in any case it seems more robust to have exprArity be a bit more intelligent.+But note that   (\x y z -> f x y z)+should have arity 3, regardless of f's arity.+-}++manifestArity :: CoreExpr -> Arity+-- ^ manifestArity sees how many leading value lambdas there are,+--   after looking through casts+manifestArity (Lam v e) | isId v        = 1 + manifestArity e+                        | otherwise     = manifestArity e+manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e+manifestArity (Cast e _)                = manifestArity e+manifestArity _                         = 0++joinRhsArity :: CoreExpr -> JoinArity+-- Join points are supposed to have manifestly-visible+-- lambdas at the top: no ticks, no casts, nothing+-- Moreover, type lambdas count in JoinArity+-- NB: For non-recursive bindings, the join arity of the binding may actually be+-- less that the number of manifestly-visible lambdas.+-- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal+joinRhsArity (Lam _ e) = 1 + joinRhsArity e+joinRhsArity _         = 0+++---------------+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig)+-- A cheap and cheerful function that identifies bottoming functions+-- and gives them a suitable strictness and CPR signatures.+-- It's used during float-out+exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e)++arityTypeBotSigs_maybe :: ArityType ->  Maybe (Arity, DmdSig, CprSig)+-- Arity of a divergent function+arityTypeBotSigs_maybe (AT lams div)+  | isDeadEndDiv div = Just ( arity+                            , mkVanillaDmdSig arity botDiv+                            , mkCprSig arity botCpr)+  | otherwise        = Nothing+  where+    arity = length lams+++{- Note [exprArity for applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come to an application we check that the arg is trivial.+   eg  f (fac x) does not have arity 2,+                 even if f has arity 3!++* We require that is trivial rather merely cheap.  Suppose f has arity 2.+  Then    f (Just y)+  has arity 0, because if we gave it arity 1 and then inlined f we'd get+          let v = Just y in \w. <f-body>+  which has arity 0.  And we try to maintain the invariant that we don't+  have arity decreases.++*  The `max 0` is important!  (\x y -> f x) has arity 2, even if f is+   unknown, hence arity 0+++************************************************************************+*                                                                      *+              typeArity and the "state hack"+*                                                                      *+********************************************************************* -}+++typeArity :: Type -> Arity+-- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after+-- looking through newtypes.  More generally, (typeOneShots ty) returns+-- ty's [OneShotInfo], based only on the type itself, using typeOneShot+-- on the argument type to access the "state hack".+typeArity = length . typeOneShots++typeOneShots :: Type -> [OneShotInfo]+-- How many value arrows are visible in the type?+-- We look through foralls, and newtypes+-- See Note [Arity invariants for bindings]+typeOneShots ty+  = go initRecTc ty+  where+    go rec_nts ty+      | Just (tcv, ty')  <- splitForAllTyCoVar_maybe ty+      = if isCoVar tcv+        then idOneShotInfo tcv : go rec_nts ty'+        else go rec_nts ty'++      | Just (_,_,arg,res) <- splitFunTy_maybe ty+      = typeOneShot arg : go rec_nts res++      | Just (tc,tys) <- splitTyConApp_maybe ty+      , Just (ty', _) <- instNewTyCon_maybe tc tys+      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes and products]+                                                -- in GHC.Core.TyCon+--   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes+--                              -- See Note [Newtype classes and eta expansion]+--                              (no longer required)+      = go rec_nts' ty'+        -- Important to look through non-recursive newtypes, so that, eg+        --      (f x)   where f has arity 2, f :: Int -> IO ()+        -- Here we want to get arity 1 for the result!+        --+        -- AND through a layer of recursive newtypes+        -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))++      | otherwise+      = []++typeOneShot :: Type -> OneShotInfo+typeOneShot ty+   | isStateHackType ty = OneShotLam+   | otherwise          = NoOneShotInfo++-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account+-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"+idStateHackOneShotInfo :: Id -> OneShotInfo+idStateHackOneShotInfo id+    | isStateHackType (idType id) = OneShotLam+    | otherwise                   = idOneShotInfo id++-- | Returns whether the lambda associated with the 'Id' is+--   certainly applied at most once+-- This one is the "business end", called externally.+-- It works on type variables as well as Ids, returning True+-- Its main purpose is to encapsulate the Horrible State Hack+-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"+isOneShotBndr :: Var -> Bool+isOneShotBndr var+  | isTyVar var                              = True+  | OneShotLam <- idStateHackOneShotInfo var = True+  | otherwise                                = False++isStateHackType :: Type -> Bool+isStateHackType ty+  | unsafeHasNoStateHack   -- Switch off with -fno-state-hack+  = False+  | otherwise+  = case tyConAppTyCon_maybe ty of+        Just tycon -> tycon == statePrimTyCon+        _          -> False+        -- This is a gross hack.  It claims that+        -- every function over realWorldStatePrimTy is a one-shot+        -- function.  This is pretty true in practice, and makes a big+        -- difference.  For example, consider+        --      a `thenST` \ r -> ...E...+        -- The early full laziness pass, if it doesn't know that r is one-shot+        -- will pull out E (let's say it doesn't mention r) to give+        --      let lvl = E in a `thenST` \ r -> ...lvl...+        -- When `thenST` gets inlined, we end up with+        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...+        -- and we don't re-inline E.+        --+        -- It would be better to spot that r was one-shot to start with, but+        -- I don't want to rely on that.+        --+        -- Another good example is in fill_in in PrelPack.hs.  We should be able to+        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.+++{- Note [Arity invariants for bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have the following invariants for let-bindings++  (1) In any binding f = e,+         idArity f <= typeArity (idType f)+      We enforce this with trimArityType, called in findRhsArity;+      see Note [Arity trimming].++      Note that we enforce this only for /bindings/.  We do /not/ insist that+         arityTypeArity (arityType e) <= typeArity (exprType e)+      because that is quite a bit more expensive to guaranteed; it would+      mean checking at every Cast in the recursive arityType, for example.++  (2) If typeArity (exprType e) = n,+      then manifestArity (etaExpand e n) = n++      That is, etaExpand can always expand as much as typeArity says+      (or less, of course). So the case analysis in etaExpand and in+      typeArity must match.++      Consequence: because of (1), if we eta-expand to (idArity f), we will+      end up with n manifest lambdas.++   (3) In any binding f = e,+         idArity f <= arityTypeArity (safeArityType (arityType e))+       That is, we call safeArityType before attributing e's arityType to f.+       See Note [SafeArityType].++       So we call safeArityType in findRhsArity.++Suppose we have+   f :: Int -> Int -> Int+   f x y = x+y    -- Arity 2++   g :: F Int+   g = case <cond> of { True  -> f |> co1+                      ; False -> g |> co2 }++where F is a type family.  Now, we can't eta-expand g to have arity 2,+because etaExpand, which works off the /type/ of the expression+(albeit looking through newtypes), doesn't know how to make an+eta-expanded binding+   g = (\a b. case x of ...) |> co+because it can't make up `co` or the types of `a` and `b`.++So invariant (1) ensures that every binding has an arity that is no greater+than the typeArity of the RHS; and invariant (2) ensures that etaExpand+and handle what typeArity says.++Why is this important?  Because++  - In GHC.Iface.Tidy we use exprArity/manifestArity to fix the *final+    arity* of each top-level Id, and in++  - In CorePrep we use etaExpand on each rhs, so that the visible+    lambdas actually match that arity, which in turn means that the+    StgRhs has a number of lambdas that precisely matches the arity.++Note [Arity trimming]+~~~~~~~~~~~~~~~~~~~~~+Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity,+which calls trimArityType to trim the ArityType to match the Arity of the+binding.  Failing to do so, and hence breaking invariant (1) led to #5441.++How to trim?  If we end in topDiv, it's easy.  But we must take great care with+dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"),+we'll get \??.⊥.  We absolutely must not trim that to \?.⊥, because that+claims that ((\x y. error "urk") |> co) diverges when given one argument,+which it absolutely does not. And Bad Things happen if we think something+returns bottom when it doesn't (#16066).++So, if we need to trim a dead-ending arity type, switch (conservatively) to+topDiv.++Historical note: long ago, we unconditionally switched to topDiv when we+encountered a cast, but that is far too conservative: see #5475++Note [Newtype classes and eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    NB: this nasty special case is no longer required, because+    for newtype classes we don't use the class-op rule mechanism+    at all.  See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013++-------- Old out of date comments, just for interest -----------+We have to be careful when eta-expanding through newtypes.  In general+it's a good idea, but annoyingly it interacts badly with the class-op+rule mechanism.  Consider++   class C a where { op :: a -> a }+   instance C b => C [b] where+     op x = ...++These translate to++   co :: forall a. (a->a) ~ C a++   $copList :: C b -> [b] -> [b]+   $copList d x = ...++   $dfList :: C b -> C [b]+   {-# DFunUnfolding = [$copList] #-}+   $dfList d = $copList d |> co@[b]++Now suppose we have:++   dCInt :: C Int++   blah :: [Int] -> [Int]+   blah = op ($dfList dCInt)++Now we want the built-in op/$dfList rule will fire to give+   blah = $copList dCInt++But with eta-expansion 'blah' might (and in #3772, which is+slightly more complicated, does) turn into++   blah = op (\eta. ($dfList dCInt |> sym co) eta)++and now it is *much* harder for the op/$dfList rule to fire, because+exprIsConApp_maybe won't hold of the argument to op.  I considered+trying to *make* it hold, but it's tricky and I gave up.++The test simplCore/should_compile/T3722 is an excellent example.+-------- End of old out of date comments, just for interest -----------+-}++{- ********************************************************************+*                                                                      *+                  Zapping lambda binders+*                                                                      *+********************************************************************* -}++zapLamBndrs :: FullArgCount -> [Var] -> [Var]+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear (in 't') under the \z.+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs+zapLamBndrs arg_count bndrs+  | no_need_to_zap = bndrs+  | otherwise      = zap_em arg_count bndrs+  where+    no_need_to_zap = all isOneShotBndr (drop arg_count bndrs)++    zap_em :: FullArgCount -> [Var] -> [Var]+    zap_em 0 bs = bs+    zap_em _ [] = []+    zap_em n (b:bs) | isTyVar b = b              : zap_em (n-1) bs+                    | otherwise = zapLamIdInfo b : zap_em (n-1) bs+++{- *********************************************************************+*                                                                      *+           Computing the "arity" of an expression+*                                                                      *+************************************************************************++Note [Definition of arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The "arity" of an expression 'e' is n if+   applying 'e' to *fewer* than n *value* arguments+   converges rapidly++Or, to put it another way++   there is no work lost in duplicating the partial+   application (e x1 .. x(n-1))++In the divergent case, no work is lost by duplicating because if the thing+is evaluated once, that's the end of the program.++Or, to put it another way, in any context C++   C[ (\x1 .. xn. e x1 .. xn) ]+         is as efficient as+   C[ e ]++It's all a bit more subtle than it looks:++Note [One-shot lambdas]+~~~~~~~~~~~~~~~~~~~~~~~+Consider one-shot lambdas+                let x = expensive in \y z -> E+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.++Note [Dealing with bottom]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC does some transformations that are technically unsound wrt+bottom, because doing so improves arities... a lot!  We describe+them in this Note.++The flag -fpedantic-bottoms (off by default) restore technically+correct behaviour at the cots of efficiency.++It's mostly to do with eta-expansion.  Consider++   f = \x -> case x of+               True  -> \s -> e1+               False -> \s -> e2++This happens all the time when f :: Bool -> IO ()+In this case we do eta-expand, in order to get that \s to the+top, and give f arity 2.++This isn't really right in the presence of seq.  Consider+        (f bot) `seq` 1++This should diverge!  But if we eta-expand, it won't.  We ignore this+"problem" (unless -fpedantic-bottoms is on), because being scrupulous+would lose an important transformation for many programs. (See+#5587 for an example.)++Consider also+        f = \x -> error "foo"+Here, arity 1 is fine.  But if it looks like this (see #22068)+        f = \x -> case x of+                        True  -> error "foo"+                        False -> \y -> x+y+then we want to get arity 2.  Technically, this isn't quite right, because+        (f True) `seq` 1+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we+do so; it improves some programs significantly, and increasing convergence+isn't a bad thing.  Hence the ABot/ATop in ArityType.++So these two transformations aren't always the Right Thing, and we+have several tickets reporting unexpected behaviour resulting from+this transformation.  So we try to limit it as much as possible:++ (1) Do NOT move a lambda outside a known-bottom case expression+       case undefined of { (a,b) -> \y -> e }+     This showed up in #5557++ (2) Do NOT move a lambda outside a case unless+     (a) The scrutinee is ok-for-speculation, or+     (b) more liberally: the scrutinee is cheap (e.g. a variable), and+         -fpedantic-bottoms is not enforced (see #2915 for an example)++Of course both (1) and (2) are readily defeated by disguising the bottoms.++There also is an interaction with Note [Combining arity type with demand info],+outlined in Wrinkle (CAD1).++Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~+Non-recursive newtypes are transparent, and should not get in the way.+We do (currently) eta-expand recursive newtypes too.  So if we have, say++        newtype T = MkT ([T] -> Int)++Suppose we have+        e = coerce T f+where f has arity 1.  Then: etaExpandArity e = 1;+that is, etaExpandArity looks through the coerce.++When we eta-expand e to arity 1: eta_expand 1 e T+we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)++  HOWEVER, note that if you use coerce bogusly you can ge+        coerce Int negate+  And since negate has arity 2, you might try to eta expand.  But you can't+  decompose Int to a function type.   Hence the final case in eta_expand.++Note [The state-transformer hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+        f = e+where e has arity n.  Then, if we know from the context that f has+a usage type like+        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...+then we can expand the arity to m.  This usage type says that+any application (x e1 .. en) will be applied to uniquely to (m-n) more args+Consider f = \x. let y = <expensive>+                 in case x of+                      True  -> foo+                      False -> \(s:RealWorld) -> e+where foo has arity 1.  Then we want the state hack to+apply to foo too, so we can eta expand the case.++Then we expect that if f is applied to one arg, it'll be applied to two+(that's the hack -- we don't really know, and sometimes it's false)+See also Id.isOneShotBndr.++Note [State hack and bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's a terrible idea to use the state hack on a bottoming function.+Here's what happens (#2861):++  f :: String -> IO T+  f = \p. error "..."++Eta-expand, using the state hack:++  f = \p. (\s. ((error "...") |> g1) s) |> g2+  g1 :: IO T ~ (S -> (S,T))+  g2 :: (S -> (S,T)) ~ IO T++Extrude the g2++  f' = \p. \s. ((error "...") |> g1) s+  f = f' |> (String -> g2)++Discard args for bottoming function++  f' = \p. \s. ((error "...") |> g1 |> g3+  g3 :: (S -> (S,T)) ~ (S,T)++Extrude g1.g3++  f'' = \p. \s. (error "...")+  f' = f'' |> (String -> S -> g1.g3)++And now we can repeat the whole loop.  Aargh!  The bug is in applying the+state hack to a function which then swallows the argument.++This arose in another guise in #3959.  Here we had++     catch# (throw exn >> return ())++Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].+After inlining (>>) we get++     catch# (\_. throw {IO ()} exn)++We must *not* eta-expand to++     catch# (\_ _. throw {...} exn)++because 'catch#' expects to get a (# _,_ #) after applying its argument to+a State#, not another function!++In short, we use the state hack to allow us to push let inside a lambda,+but not to introduce a new lambda.+++Note [ArityType]+~~~~~~~~~~~~~~~~+ArityType can be thought of as an abstraction of an expression.+The ArityType+   AT [ (IsCheap,     NoOneShotInfo)+      , (IsExpensive, OneShotLam)+      , (IsCheap,     OneShotLam) ] Dunno)++abstracts an expression like+   \x. let <expensive> in+       \y{os}.+       \z{os}. blah++In general we have (AT lams div).  Then+* In lams :: [(Cost,OneShotInfo)]+  * The Cost flag describes the part of the expression down+    to the first (value) lambda.+  * The OneShotInfo flag gives the one-shot info on that lambda.++* If 'div' is dead-ending ('isDeadEndDiv'), then application to+  'length lams' arguments will surely diverge, similar to the situation+  with 'DmdType'.++ArityType is the result of a compositional analysis on expressions,+from which we can decide the real arity of the expression (extracted+with function exprEtaExpandArity).++We use the following notation:+  at  ::= \p1..pn.div+  div ::= T | x | ⊥+  p   ::= (c o)+  c   ::= X | C    -- Expensive or Cheap+  o   ::= ? | 1    -- NotOneShot or OneShotLam+We may omit the \. if n = 0.+And ⊥ stands for `AT [] botDiv`++Here is an example demonstrating the notation:+  \(C?)(X1)(C1).T+stands for+   AT [ (IsCheap,NoOneShotInfo)+      , (IsExpensive,OneShotLam)+      , (IsCheap,OneShotLam) ]+      topDiv++See the 'Outputable' instance for more information. It's pretty simple.++How can we use ArityType?  Example:+      f = \x\y. let v = <expensive> in+          \s(one-shot) \t(one-shot). blah+      'f' has arity type \(C?)(C?)(X1)(C1).T+      The one-shot-ness means we can, in effect, push that+      'let' inside the \st, and expand to arity 4++Suppose f = \xy. x+y+Then  f             :: \(C?)(C?).T+      f v           :: \(C?).T+      f <expensive> :: \(X?).T++Here is what the fields mean. If an arbitrary expression 'f' has+ArityType 'at', then++ * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@+   definitely diverges. Partial applications to fewer than n args may *or+   may not* diverge.  Ditto exnDiv.++ * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at)+   arguments without losing sharing. This function checks that the either+   there are no expensive expressions, or the lambdas are one-shots.++   NB 'f' is an arbitrary expression, eg @f = g e1 e2@.  This 'f' can have+   arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves+   cheap.++ * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely+   really functions, or bottom, but *not* casts from a data type, in+   at least one case branch.  (If it's a function in one case branch but+   an unsafe cast from a data type in another, the program is bogus.)+   So eta expansion is dynamically ok; see Note [State hack and+   bottoming functions], the part about catch#++Wrinkles++* Wrinkle [Bottoming functions]: see function 'arityLam'.+  We treat bottoming functions as one-shot, because there is no point+  in floating work outside the lambda, and it's fine to float it inside.++  For example, this is fine (see test stranal/sigs/BottomFromInnerLambda)+       let x = <expensive> in \y. error (g x y)+       ==> \y. let x = <expensive> in error (g x y)++  Idea: perhaps we could enforce this invariant with+     data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost]+++Note [SafeArityType]+~~~~~~~~~~~~~~~~~~~~+The function safeArityType trims an ArityType to return a "safe" ArityType,+for which we use a type synonym SafeArityType.  It is "safe" in the sense+that (arityTypeArity at) really reflects the arity of the expression, whereas+a regular ArityType might have more lambdas in its [ATLamInfo] that the+(cost-free) arity of the expression.++For example+   \x.\y.let v = expensive in \z. blah+has+   arityType = AT [C?, C?, X?, C?] Top+But the expression actually has arity 2, not 4, because of the X.+So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo]+now reflects the (cost-free) arity of the expression++Why do we ever need an "unsafe" ArityType, such as the example above?+Because its (cost-free) arity may increased by combineWithCallCards+in findRhsArity. See Note [Combining arity type with demand info].++Thus the function `arityType` returns a regular "unsafe" ArityType, that+goes deeply into the lambdas (including under IsExpensive). But that is+very local; most ArityTypes are indeed "safe".  We use the type synonym+SafeArityType to indicate where we believe the ArityType is safe.+-}++-- | The analysis lattice of arity analysis. It is isomorphic to+--+-- @+--    data ArityType'+--      = AEnd Divergence+--      | ALam OneShotInfo ArityType'+-- @+--+-- Which is easier to display the Hasse diagram for:+--+-- @+--  ALam OneShotLam at+--          |+--      AEnd topDiv+--          |+--  ALam NoOneShotInfo at+--          |+--      AEnd exnDiv+--          |+--      AEnd botDiv+-- @+--+-- where the @at@ fields of @ALam@ are inductively subject to the same order.+-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@.+--+-- Why the strange Top element?+--   See Note [Combining case branches: optimistic one-shot-ness]+--+-- We rely on this lattice structure for fixed-point iteration in+-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].+data ArityType  -- See Note [ArityType]+  = AT ![ATLamInfo] !Divergence+    -- ^ `AT oss div` is an abstraction of the expression, which describes+    -- its lambdas, and how much work appears where.+    -- See Note [ArityType] for more information+    --+    -- If `div` is dead-ending ('isDeadEndDiv'), then application to+    -- `length os` arguments will surely diverge, similar to the situation+    -- with 'DmdType'.+  deriving Eq++type ATLamInfo = (Cost,OneShotInfo)+     -- ^ Info about one lambda in an ArityType+     -- See Note [ArityType]++type SafeArityType = ArityType -- See Note [SafeArityType]++data Cost = IsCheap | IsExpensive+          deriving( Eq )++allCosts :: (a -> Cost) -> [a] -> Cost+allCosts f xs = foldr (addCost . f) IsCheap xs++addCost :: Cost -> Cost -> Cost+addCost IsCheap IsCheap = IsCheap+addCost _       _       = IsExpensive++-- | This is the BNF of the generated output:+--+-- @+-- @+--+-- We format+-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and+-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively.+-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@.+-- If the one-shot info is empty, we omit the leading @\.@.+instance Outputable ArityType where+  ppr (AT oss div)+    | null oss  = pp_div div+    | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div+    where+      pp_div Diverges = char '⊥'+      pp_div ExnOrDiv = char 'x'+      pp_div Dunno    = char 'T'+      pp_os (IsCheap,     OneShotLam)    = text "(C1)"+      pp_os (IsExpensive, OneShotLam)    = text "(X1)"+      pp_os (IsCheap,     NoOneShotInfo) = text "(C?)"+      pp_os (IsExpensive, NoOneShotInfo) = text "(X?)"++mkBotArityType :: [OneShotInfo] -> ArityType+mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv++botArityType :: ArityType+botArityType = mkBotArityType []++topArityType :: ArityType+topArityType = AT [] topDiv++-- | The number of value args for the arity type+arityTypeArity :: SafeArityType -> Arity+arityTypeArity (AT lams _) = length lams++arityTypeOneShots :: SafeArityType -> [OneShotInfo]+-- Returns a list only as long as the arity should be+arityTypeOneShots (AT lams _) = map snd lams++safeArityType :: ArityType -> SafeArityType+-- ^ Assuming this ArityType is all we know, find the arity of+-- the function, and trim the argument info (and Divergence)+-- to match that arity. See Note [SafeArityType]+safeArityType at@(AT lams _)+  = case go 0 IsCheap lams of+      Nothing -> at  -- No trimming needed+      Just ar -> AT (take ar lams) topDiv+ where+   go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity+   go _ _ [] = Nothing+   go ar ch1 ((ch2,os):lams)+      = case (ch1 `addCost` ch2, os) of+          (IsExpensive, NoOneShotInfo) -> Just ar+          (ch,          _)             -> go (ar+1) ch lams++infixl 2 `trimArityType`++trimArityType :: Arity -> ArityType -> ArityType+-- ^ Trim an arity type so that it has at most the given arity.+-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if+-- they end in 'ABot'.  See Note [Arity trimming]+trimArityType max_arity at@(AT lams _)+  | lams `lengthAtMost` max_arity = at+  | otherwise                     = AT (take max_arity lams) topDiv++data ArityOpts = ArityOpts+  { ao_ped_bot :: !Bool -- See Note [Dealing with bottom]+  , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries]+  }++-- | The Arity returned is the number of value args the+-- expression can be applied to without doing much work+exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType+-- exprEtaExpandArity is used when eta expanding+--      e  ==>  \xy -> e x y+-- Nothing if the expression has arity 0+exprEtaExpandArity opts e+  | AT [] _ <- arity_type+  = Nothing+  | otherwise+  = Just arity_type+  where+    arity_type = safeArityType (arityType (findRhsArityEnv opts False) e)+++{- *********************************************************************+*                                                                      *+                   findRhsArity+*                                                                      *+********************************************************************* -}++findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr+             -> (Bool, SafeArityType)+-- This implements the fixpoint loop for arity analysis+-- See Note [Arity analysis]+--+-- The Bool is True if the returned arity is greater than (exprArity rhs)+--     so the caller should do eta-expansion+-- That Bool is never True for join points, which are never eta-expanded+--+-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr'+--         See Note [Arity trimming]++findRhsArity opts is_rec bndr rhs+  | isJoinId bndr+  = (False, join_arity_type)+    -- False: see Note [Do not eta-expand join points]+    -- But do return the correct arity and bottom-ness, because+    -- these are used to set the bndr's IdInfo (#15517)+    -- Note [Invariants on join points] invariant 2b, in GHC.Core++  | otherwise+  = (arity_increased, non_join_arity_type)+    -- arity_increased: eta-expand if we'll get more lambdas+    -- to the top of the RHS+  where+    old_arity = exprArity rhs++    init_env :: ArityEnv+    init_env = findRhsArityEnv opts (isJoinId bndr)++    -- Non-join-points only+    non_join_arity_type = case is_rec of+                             Recursive    -> go 0 botArityType+                             NonRecursive -> step init_env+    arity_increased = arityTypeArity non_join_arity_type > old_arity++    -- Join-points only+    -- See Note [Arity for non-recursive join bindings]+    -- and Note [Arity for recursive join bindings]+    join_arity_type = case is_rec of+                         Recursive    -> go 0 botArityType+                         NonRecursive -> trimArityType ty_arity (cheapArityType rhs)++    ty_arity     = typeArity (idType bndr)+    use_call_cards = useSiteCallCards bndr++    step :: ArityEnv -> SafeArityType+    step env = trimArityType ty_arity $+               safeArityType $ -- See Note [Arity invariants for bindings], item (3)+               combineWithCallCards env (arityType env rhs) use_call_cards+       -- trimArityType: see Note [Trim arity inside the loop]+       -- combineWithCallCards: take account of the demand on the+       -- binder.  Perhaps it is always called with 2 args+       --   let f = \x. blah in (f 3 4, f 1 9)+       -- f's demand-info says how many args it is called with++    -- The fixpoint iteration (go), done for recursive bindings. We+    -- always do one step, but usually that produces a result equal+    -- to old_arity, and then we stop right away, because old_arity+    -- is assumed to be sound. In other words, arities should never+    -- decrease.  Result: the common case is that there is just one+    -- iteration+    go :: Int -> SafeArityType -> SafeArityType+    go !n cur_at@(AT lams div)+      | not (isDeadEndDiv div)           -- the "stop right away" case+      , length lams <= old_arity = cur_at -- from above+      | next_at == cur_at        = cur_at+      | otherwise+         -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]+      = warnPprTrace (debugIsOn && n > 2)+            "Exciting arity"+            (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $+        go (n+1) next_at+      where+        next_at = step (extendSigEnv init_env bndr cur_at)++combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType+-- See Note [Combining arity type with demand info]+combineWithCallCards env at@(AT lams div) cards+  | null lams = at+  | otherwise = AT (zip_lams lams oss) div+  where+    oss = map card_to_oneshot cards+    card_to_oneshot n+      | isAtMostOnce n, not (pedanticBottoms env)+         -- Take care for -fpedantic-bottoms;+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | n == C_11+         -- Safe to eta-expand even in the presence of -fpedantic-bottoms+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | otherwise+      = NoOneShotInfo+    zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo]+    zip_lams lams []  = lams+    zip_lams []   oss | isDeadEndDiv div = []+                      | otherwise        = [ (IsExpensive,OneShotLam)+                                           | _ <- takeWhile isOneShotInfo oss]+    zip_lams ((ch,os1):lams) (os2:oss)+      = (ch, os1 `bestOneShot` os2) : zip_lams lams oss++useSiteCallCards :: Id -> [Card]+useSiteCallCards bndr+  = call_arity_one_shots `zip_cards` dmd_one_shots+  where+    call_arity_one_shots :: [Card]+    call_arity_one_shots+      | call_arity == 0 = []+      | otherwise       = C_0N : replicate (call_arity-1) C_01+    -- Call Arity analysis says /however often the function is called/, it is+    -- always applied to this many arguments.+    -- The first C_0N is because of the "however often it is called" part.+    -- Thus if Call Arity says "always applied to 3 args" then the one-shot info+    -- we get is [C_0N, C_01, C_01]+    call_arity = idCallArity bndr++    dmd_one_shots :: [Card]+    -- If the demand info is C(x,C(1,C(1,.))) then we know that an+    -- application to one arg is also an application to three+    dmd_one_shots = case idDemandInfo bndr of+      AbsDmd  -> [] -- There is no use in eta expanding+      BotDmd  -> [] -- when the binding could be dropped instead+      _ :* sd -> callCards sd++    -- Take the *longer* list+    zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2+    zip_cards []       ns2      = ns2+    zip_cards ns1      []       = ns1++{- Note [Arity analysis]+~~~~~~~~~~~~~~~~~~~~~~~~+The motivating example for arity analysis is this:++  f = \x. let g = f (x+1)+          in \y. ...g...++What arity does f have?  Really it should have arity 2, but a naive+look at the RHS won't see that.  You need a fixpoint analysis which+says it has arity "infinity" the first time round.++This example happens a lot; it first showed up in Andy Gill's thesis,+fifteen years ago!  It also shows up in the code for 'rnf' on lists+in #4138.++We do the necessary, quite simple fixed-point iteration in 'findRhsArity',+which assumes for a single binding 'ABot' on the first run and iterates+until it finds a stable arity type. Two wrinkles++* We often have to ask (see the Case or Let case of 'arityType') whether some+  expression is cheap. In the case of an application, that depends on the arity+  of the application head! That's why we have our own version of 'exprIsCheap',+  'myExprIsCheap', that will integrate the optimistic arity types we have on+  f and g into the cheapness check.++* Consider this (#18793)++    go = \ds. case ds of+           []     -> id+           (x:ys) -> let acc = go ys in+                     case blah of+                       True  -> acc+                       False -> \ x1 -> acc (negate x1)++  We must propagate go's optimistically large arity to @acc@, so that the+  tail call to @acc@ in the True branch has sufficient arity.  This is done+  by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case+  of 'arityType'.++Note [Exciting arity]+~~~~~~~~~~~~~~~~~~~~~+The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost+all cases. To get notified of cases where we need an usual number of iterations,+we emit a warning in debug mode, so that we can investigate and make sure that+we really can't do better. It's a gross hack, but catches real bugs (#18870).++Now, which number is "unusual"? We pick n > 2. Here's a pretty common and+expected example that takes two iterations and would ruin the specificity+of the warning (from T18937):++  f :: [Int] -> Int -> Int+  f []     = id+  f (x:xs) = let y = sum [0..x]+             in \z -> f xs (y + z)++Fixed-point iteration starts with arity type ⊥ for f. After the first+iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally+'floatIn' the let-binding (see its bottom case).  After the second iteration,+we get arity type \?.T, e.g. arity 1, because now we are no longer allowed+to floatIn the non-cheap let-binding.  Which is all perfectly benign, but+means we do two iterations (well, actually 3 'step's to detect we are stable)+and don't want to emit the warning.++Note [Trim arity inside the loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's an example (from gadt/nbe.hs) which caused trouble.+  data Exp g t where+     Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b)++  eval :: Exp g t -> g -> t+  eval (Lam _ e) g = \a -> eval e (g,a)++The danger is that we get arity 3 from analysing this; and the+next time arity 4, and so on for ever.  Solution: use trimArityType+on each iteration.++Note [Combining arity type with demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let f = \x. let y = <expensive> in \p \q{os}. blah+   in ...(f a b)...(f c d)...++* From the RHS we get an ArityType like+    AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno+  where "?" means NoOneShotInfo++* From the body, the demand analyser (or Call Arity) will tell us+  that the function is always applied to at least two arguments.++Combining these two pieces of info, we can get the final ArityType+    AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno+result: arity=3, which is better than we could do from either+source alone.++The "combining" part is done by combineWithCallCards.  It+uses info from both Call Arity and demand analysis.++We may have /more/ call demands from the calls than we have lambdas+in the binding.  E.g.+    let f1 = \x. g x x in ...(f1 p q r)...+    -- Demand on f1 is C(x,C(1,C(1,L)))++    let f2 = \y. error y in ...(f2 p q r)...+    -- Demand on f2 is C(x,C(1,C(1,L)))++In both these cases we can eta expand f1 and f2 to arity 3.+But /only/ for called-once demands.  Suppose we had+    let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)...++Now we don't want to eta-expand f1 to have 3 args; only two.+Nor, in the case of f2, do we want to push that error call under+a lambda.  Hence the takeWhile in combineWithDemandDoneShots.++Wrinkles:++(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms+  (See Note [Dealing with bottom]). Consider++    let f = \x y. error "blah" in+    f 2 1 `seq` Just (f 3 2 1)+      -- Demand on f is C(x,C(1,C(M,L)))++  Usually, it is OK to consider a lambda that is called *at most* once (so call+  cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it.+  But with -fpedantic-bottoms that is no longer true: If we were to eta-expand+  f to arity 3, we'd discard the error raised when evaluating `f 2 1`.+  Hence in the presence of -fpedantic-bottoms, we must have C_11 for+  eta-expansion.++Note [Do not eta-expand join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similarly to CPR (see Note [Don't w/w join points for CPR] in+GHC.Core.Opt.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 [Arity for recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = joinrec j 0 = \ a b c -> (a,x,b)+                j n = j (n-1)+        in j 20++Obviously `f` should get arity 4.  But it's a bit tricky:++1. Remember, we don't eta-expand join points; see+   Note [Do not eta-expand join points].++2. But even though we aren't going to eta-expand it, we still want `j` to get+   idArity=4, via the findRhsArity fixpoint.  Then when we are doing findRhsArity+   for `f`, we'll call arityType on f's RHS:+    - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType+      for `j` (See Note [arityType for non-recursive let-bindings]+      in GHC.Core.Opt.Arity)b+    - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3+      result.++3. All this, even though j's /join-arity/ (stored in the JoinId) is 1.+   This is is the Main Reason that we want the idArity to sometimes be+   larger than the join-arity c.f. Note [Invariants on join points] item 2b+   in GHC.Core.++4. Be very careful of things like this (#21755):+     g x = let j 0 = \y -> (x,y)+               j n = expensive n `seq` j (n-1)+           in j x+   Here we do /not/ want eta-expand `g`, lest we duplicate all those+   (expensive n) calls.++   But it's fine: the findRhsArity fixpoint calculation will compute arity-1+   for `j` (not arity 2); and that's just what we want. But we do need that+   fixpoint.++   Historical note: an earlier version of GHC did a hack in which we gave+   join points an ArityType of ABot, but that did not work with this #21755+   case.++5. arityType does not usually expect to encounter free join points;+   see GHC.Core.Opt.Arity Note [No free join points in arityType].+   But consider+          f x = join    j1 y = .... in+                joinrec j2 z = ...j1 y... in+                j2 v++   When doing findRhsArity on `j2` we'll encounter the free `j1`.+   But that is fine, because we aren't going to eta-expand `j2`;+   we just want to know its arity.  So we have a flag am_no_eta,+   switched on when doing findRhsArity on a join point RHS. If+   the flag is on, we allow free join points, but not otherwise.+++Note [Arity for non-recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Arity for recursive join bindings] deals with recursive join+bindings. But what about /non-recursive/ones?  If we just call+findRhsArity, it will call arityType.  And that can be expensive when+we have deeply nested join points:+  join j1 x1 = join j2 x2 = join j3 x3 = blah3+                            in blah2+               in blah1+(e.g. test T18698b).++So we call cheapArityType instead.  It's good enough for practical+purposes.++(Side note: maybe we should use cheapArity for the RHS of let bindings+in the main arityType function.)+-}+++{- *********************************************************************+*                                                                      *+                   arityType+*                                                                      *+********************************************************************* -}++arityLam :: Id -> ArityType -> ArityType+arityLam id (AT oss div)+  = AT ((IsCheap, one_shot) : oss) div+  where+    one_shot | isDeadEndDiv div = OneShotLam+             | otherwise        = idStateHackOneShotInfo id+    -- If the body diverges, treat it as one-shot: no point+    -- in floating out, and no penalty for floating in+    -- See Wrinkle [Bottoming functions] in Note [ArityType]++floatIn :: Cost -> ArityType -> ArityType+-- We have something like (let x = E in b),+-- where b has the given arity type.+-- NB: be as lazy as possible in the Cost-of-E argument;+--     we can often get away without ever looking at it+--     See Note [Care with nested expressions]+floatIn ch at@(AT lams div)+  = case lams of+      []                 -> at+      (IsExpensive,_):_  -> at+      (_,os):lams        -> AT ((ch,os):lams) div++addWork :: ArityType -> ArityType+-- Add work to the outermost level of the arity type+addWork at@(AT lams div)+  = case lams of+      []      -> at+      lam:lams' -> AT (add_work lam : lams') div++add_work :: ATLamInfo -> ATLamInfo+add_work (_,os) = (IsExpensive,os)++arityApp :: ArityType -> Cost -> ArityType+-- Processing (fun arg) where at is the ArityType of fun,+-- Knock off an argument and behave like 'let'+arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div)+arityApp at                     _   = at++-- | Least upper bound in the 'ArityType' lattice.+-- See the haddocks on 'ArityType' for the lattice.+--+-- Used for branches of a @case@.+andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType+andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2)+  | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2)+  = AT ((lam1 `and_lam` lam2) : lams') div'+  where+    (ch1,os1) `and_lam` (ch2,os2)+      = ( ch1 `addCost` ch2, os1 `bestOneShot` os2)+        -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness]++andArityType env (AT [] div1) at2 = andWithTail env div1 at2+andArityType env at1 (AT [] div2) = andWithTail env div2 at1++andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType+andWithTail env div1 at2@(AT lams2 _)+  | isDeadEndDiv div1    -- case x of { T -> error; F -> \y.e }+  = at2                  -- See Note+  | pedanticBottoms env  --    [Combining case branches: andWithTail]+  = AT [] topDiv++  | otherwise  -- case x of { T -> plusInt <expensive>; F -> \y.e }+  = AT (map add_work lams2) topDiv    -- We know div1 = topDiv+    -- See Note [Combining case branches: andWithTail]++{- Note [Combining case branches: optimistic one-shot-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with+andArityType) and both ArityTypes have ATLamInfo, then we just combine+their expensive-ness and one-shot info.  The tricky point is when we+have++     case x of True -> \x{one-shot). blah1+               Fale -> \y.           blah2++Since one-shot-ness is about the /consumer/ not the /producer/, we+optimistically assume that if either branch is one-shot, we combine+the best of the two branches, on the (slightly dodgy) basis that if we+know one branch is one-shot, then they all must be.  Surprisingly,+this means that the one-shot arity type is effectively the top element+of the lattice.++Hence the call to `bestOneShot` in `andArityType`.++Here's an example:+  go = \x. let z = go e0+               go2 = \x. case x of+                           True  -> z+                           False -> \s(one-shot). e1+           in go2 x++We *really* want to respect the one-shot annotation provided by the+user and eta-expand go and go2.  In the first fixpoint iteration of+'go' we'll bind 'go' to botArityType (written \.⊥, see Note+[ArityType]).  So 'z' will get arityType \.⊥; so we end up combining+the True and False branches:++      \.⊥ `andArityType` \1.T++That gives \1.T (see Note [Combining case branches: andWithTail],+first bullet).  So 'go2' gets an arityType of \(C?)(C1).T, which is+what we want.++Note [Care with nested expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    arityType (Just <big-expressions>)+We will take+    arityType Just = AT [(IsCheap,os)] topDiv+and then do+    arityApp (AT [(IsCheap os)] topDiv) (exprCost <big-expression>)+The result will be AT [] topDiv.  It doesn't matter what <big-expresison>+is!  The same is true of+    arityType (let x = <rhs> in <body>)+where the cost of <rhs> doesn't matter unless <body> has a useful+arityType.++TL;DR in `floatIn`, do not to look at the Cost argument until you have to.++I found this when looking at #24471, although I don't think it was really+the main culprit.++Note [Combining case branches: andWithTail]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and one side or the other has run out of ATLamInfo; then we get+into `andWithTail`.++* If one branch is guaranteed bottom (isDeadEndDiv), we just take+  the other. Consider   case x of+             True  -> \x.  error "urk"+             False -> \xy. error "urk2"++  Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely+  diverge".  So we need \??.⊥ for the whole thing, the /max/ of both+  arities.++* Otherwise, if pedantic-bottoms is on, we just have to return+  AT [] topDiv.  E.g. if we have+    f x z = case x of True  -> \y. blah+                      False -> z+  then we can't eta-expand, because that would change the behaviour+  of (f False bottom().++* But if pedantic-bottoms is not on, we allow ourselves to push+  `z` under a lambda (much as we allow ourselves to put the `case x`+  under a lambda).  However we know nothing about the expensiveness+  or one-shot-ness of `z`, so we'd better assume it looks like+  (Expensive, NoOneShotInfo) all the way. Remembering+  Note [Combining case branches: optimistic one-shot-ness],+  we just add work to ever ATLamInfo, keeping the one-shot-ness.++Note [Eta expanding through CallStacks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Just as it's good to eta-expand through dictionaries, so it is good to+do so through CallStacks.  #20103 is a case in point, where we got+  foo :: HasCallStack => Int -> Int+  foo = \(d::CallStack). let d2 = pushCallStack blah d in+        \(x:Int). blah++We really want to eta-expand this!  #20103 is quite convincing!+We do this regardless of -fdicts-cheap; it's not really a dictionary.++We also want to check both for (IP blah CallStack) and for CallStack itself.+We might have either+   d :: IP blah CallStack    -- Or HasCallStack+   d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack)+or just+   cs :: CallStack+   cs = cs-expr++Test T20103 is an example of the latter.++Note [Eta expanding through dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the experimental -fdicts-cheap flag is on, we eta-expand through+dictionary bindings.  This improves arities. Thereby, it also+means that full laziness is less prone to floating out the+application of a function to its dictionary arguments, which+can thereby lose opportunities for fusion.  Example:+        foo :: Ord a => a -> ...+     foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....+        -- So foo has arity 1++     f = \x. foo dInt $ bar x++The (foo DInt) is floated out, and makes ineffective a RULE+     foo (bar x) = ...++One could go further and make exprIsCheap reply True to any+dictionary-typed expression, but that's more work.+-}++---------------------------++data ArityEnv+  = AE { am_opts :: !ArityOpts++       , am_sigs :: !(IdEnv SafeArityType)+         -- NB `SafeArityType` so we can use this in myIsCheapApp+         -- See Note [Arity analysis] for details about fixed-point iteration.++       , am_free_joins :: !Bool  -- True <=> free join points allowed+         -- Used /only/ to support assertion checks+       }++instance Outputable ArityEnv where+  ppr (AE { am_sigs = sigs, am_free_joins = free_joins })+    = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins+                                , text "sigs:" <+> ppr sigs ])++-- | The @ArityEnv@ used by 'findRhsArity'.+findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv+findRhsArityEnv opts free_joins+  = AE { am_opts       = opts+       , am_free_joins = free_joins+       , am_sigs       = emptyVarEnv }++freeJoinsOK :: ArityEnv -> Bool+freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins++-- First some internal functions in snake_case for deleting in certain VarEnvs+-- of the ArityType. Don't call these; call delInScope* instead!++modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv+modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs }+{-# INLINE modifySigEnv #-}++del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal!+del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id)+{-# INLINE del_sig_env #-}++del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal!+del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids)+{-# INLINE del_sig_env_list #-}++-- end of internal deletion functions++extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv+extendSigEnv env id ar_ty+  = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $+    env++delInScope :: ArityEnv -> Id -> ArityEnv+delInScope env id = del_sig_env id env++delInScopeList :: ArityEnv -> [Id] -> ArityEnv+delInScopeList env ids = del_sig_env_list ids env++lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType+lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id++-- | Whether the analysis should be pedantic about bottoms.+-- 'exprBotStrictness_maybe' always is.+pedanticBottoms :: ArityEnv -> Bool+pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot++exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost+exprCost env e mb_ty+  | myExprIsCheap env e mb_ty = IsCheap+  | otherwise                 = IsExpensive++-- | A version of 'exprIsCheap' that considers results from arity analysis+-- and optionally the expression's type.+-- Under 'exprBotStrictness_maybe', no expressions are cheap.+myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool+myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty+  = cheap_dict || cheap_fun e+  where+    cheap_dict = case mb_ty of+                     Nothing -> False+                     Just ty -> (ao_dicts_cheap opts && isDictTy ty)+                                || isCallStackPredTy ty || isCallStackTy ty+        -- See Note [Eta expanding through dictionaries]+        -- See Note [Eta expanding through CallStacks]++    cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e++-- | A version of 'isCheapApp' that considers results from arity analysis.+-- See Note [Arity analysis] for what's in the signature environment and why+-- it's important.+myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun+myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of++  -- Nothing means not a local function, fall back to regular+  -- 'GHC.Core.Utils.isCheapApp'+  Nothing -> isCheapApp fn n_val_args++  -- `Just at` means local function with `at` as current SafeArityType.+  -- NB the SafeArityType bit: that means we can ignore the cost flags+  --    in 'lams', and just consider the length+  -- Roughly approximate what 'isCheapApp' is doing.+  Just (AT lams div)+    | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils+    | n_val_args == 0          -> True -- Essentially+    | n_val_args < length lams -> True -- isWorkFreeApp+    | otherwise                -> False++----------------+arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType+-- Precondition: all the free join points of the expression+--               are bound by the ArityEnv+-- See Note [No free join points in arityType]+--+-- Returns ArityType, not SafeArityType.  The caller must do+-- trimArityType if necessary.+arityType env (Var v)+  | Just at <- lookupSigEnv env v -- Local binding+  = at+  | otherwise+  = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $+    -- All join-point should be in the ae_sigs+    -- See Note [No free join points in arityType]+    idArityType v++arityType env (Cast e _)+  = arityType env e++        -- Lambdas; increase arity+arityType env (Lam x e)+  | isId x    = arityLam x (arityType env' e)+  | otherwise = arityType env' e+  where+    env' = delInScope env x++        -- Applications; decrease arity, except for types+arityType env (App fun (Type _))+   = arityType env fun+arityType env (App fun arg )+   = arityApp fun_at arg_cost+   where+     fun_at   = arityType env fun+     arg_cost = exprCost env arg Nothing++        -- Case/Let; keep arity if either the expression is cheap+        -- or it's a 1-shot lambda+        -- The former is not really right for Haskell+        --      f x = case x of { (a,b) -> \y. e }+        --  ===>+        --      f x y = case x of { (a,b) -> e }+        -- The difference is observable using 'seq'+        --+arityType env (Case scrut bndr _ altList)+  | not $ exprIsDeadEnd scrut, Just alts <- nonEmpty altList+  = let env' = delInScope env bndr+        arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs+        alts_type = foldr1 (andArityType env) (NE.map arity_type_alt alts)+    in if+      | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]+      , myExprIsCheap env scrut (Just (idType bndr))+       -> alts_type++      | exprOkForSpeculation scrut+       -> alts_type++      | otherwise            -- In the remaining cases we may not push+       -> addWork alts_type -- evaluation of the scrutinee in+  | otherwise = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]++arityType env (Let (NonRec b rhs) e)+  = -- See Note [arityType for non-recursive let-bindings]+    floatIn rhs_cost (arityType env' e)+  where+    rhs_cost = exprCost env rhs (Just (idType b))+    env'     = extendSigEnv env b (safeArityType (arityType env rhs))++arityType env (Let (Rec prs) e)+  = -- See Note [arityType for recursive let-bindings]+    floatIn (allCosts bind_cost prs) (arityType env' e)+  where+    bind_cost (b,e) = exprCost env' e (Just (idType b))+    env'            = foldl extend_rec env prs+    extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv+    extend_rec env (b,_) = extendSigEnv env b  $+                           idArityType b+      -- See Note [arityType for recursive let-bindings]++arityType env (Tick t e)+  | not (tickishIsCode t)     = arityType env e++arityType _ _ = topArityType++--------------------+idArityType :: Id -> ArityType+idArityType v+  | strict_sig <- idDmdSig v+  , (ds, div) <- splitDmdSig strict_sig+  , isDeadEndDiv div+  = AT (takeList ds one_shots) div++  | isEmptyTy id_ty+  = botArityType++  | otherwise+  = AT (take (idArity v) one_shots) topDiv+  where+    id_ty = idType v++    one_shots :: [(Cost,OneShotInfo)]  -- One-shot-ness derived from the type+    one_shots = repeat IsCheap `zip` typeOneShots id_ty++--------------------+cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType+-- A fast and cheap version of arityType.+-- Returns an ArityType with IsCheap everywhere+-- c.f. GHC.Core.Utils.exprIsDeadEnd+--+-- /Can/ encounter a free join-point Id; e.g. via the call+--   in exprBotStrictness_maybe, which is called in lots+--   of places+--+-- Returns ArityType, not SafeArityType.  The caller must do+-- trimArityType if necessary.+cheapArityType e = go e+  where+    go (Var v)                  = idArityType v+    go (Cast e _)               = go e+    go (Lam x e)  | isId x      = arityLam x (go e)+                  | otherwise   = go e+    go (App e a)  | isTypeArg a = go e+                  | otherwise   = arity_app a (go e)++    go (Tick t e) | not (tickishIsCode t) = go e++    -- Null alts: see Note [Empty case alternatives] in GHC.Core+    go (Case _ _ _ alts) | null alts = botArityType++    -- Give up on let, case.  In particular, unlike arityType,+    -- we make no attempt to look inside let's.+    go _ = topArityType++    -- Specialised version of arityApp; all costs in ArityType are IsCheap+    -- See Note [exprArity for applications]+    -- NB: (1) coercions count as a value argument+    --     (2) we use the super-cheap exprIsTrivial rather than the+    --         more complicated and expensive exprIsCheap+    arity_app _ at@(AT [] _) = at+    arity_app arg at@(AT ((cost,_):lams) div)+       | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $+         isDeadEndDiv div  = AT lams div+       | exprIsTrivial arg = AT lams topDiv+       | otherwise         = topArityType++---------------+exprArity :: CoreExpr -> Arity+-- ^ An approximate, even faster, version of 'cheapArityType'+-- Roughly   exprArity e = arityTypeArity (cheapArityType e)+-- But it's a bit less clever about bottoms+--+-- We do /not/ guarantee that exprArity e <= typeArity e+-- You may need to do arity trimming after calling exprArity+-- See Note [Arity trimming]+-- Reason: if we do arity trimming here we have take exprType+--         and that can be expensive if there is a large cast+exprArity e = go e+  where+    go (Var v)                     = idArity v+    go (Lam x e) | isId x          = go e + 1+                 | otherwise       = go e+    go (Tick t e) | not (tickishIsCode t) = go e+    go (Cast e _)                  = go e+    go (App e (Type _))            = go e+    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0+        -- See Note [exprArity for applications]+        -- NB: coercions count as a value argument++    go _                           = 0++---------------+exprIsDeadEnd :: CoreExpr -> Bool+-- See Note [Bottoming expressions]+-- This function is, in effect, just a specialised (and hence cheap)+--    version of cheapArityType:+--    exprIsDeadEnd e = case cheapArityType e of+--                         AT lams div -> null lams && isDeadEndDiv div+-- See also exprBotStrictness_maybe, which uses cheapArityType+exprIsDeadEnd e+  = go 0 e+  where+    go :: Arity -> CoreExpr -> Bool+    -- (go n e) = True <=> expr applied to n value args is bottom+    go _ (Lit {})                = False+    go _ (Type {})               = False+    go _ (Coercion {})           = False+    go n (App e a) | isTypeArg a = go n e+                   | otherwise   = go (n+1) e+    go n (Tick _ e)              = go n e+    go n (Cast e _)              = go n e+    go n (Let _ e)               = go n e+    go n (Lam v e) | isTyVar v   = go n e+                   | otherwise   = False++    go _ (Case _ _ _ alts)       = null alts+       -- See Note [Empty case alternatives] in GHC.Core++    go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True+                 | isEmptyTy (idType v)           = True+                 | otherwise                      = False++{- Note [Bottoming expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A bottoming expression is guaranteed to diverge, or raise an+exception.  We can test for it in two different ways, and exprIsDeadEnd+checks for both of these situations:++* Visibly-bottom computations.  For example+      (error Int "Hello")+  is visibly bottom.  The strictness analyser also finds out if+  a function diverges or raises an exception, and puts that info+  in its strictness signature.++* Empty types.  If a type is empty, its only inhabitant is bottom.+  For example:+      data T+      f :: T -> Bool+      f = \(x:t). case x of Bool {}+  Since T has no data constructors, the case alternatives are of course+  empty.  However note that 'x' is not bound to a visibly-bottom value;+  it's the *type* that tells us it's going to diverge.++A GADT may also be empty even though it has constructors:+        data T a where+          T1 :: a -> T Bool+          T2 :: T Int+        ...(case (x::T Char) of {})...+Here (T Char) is uninhabited.  A more realistic case is (Int ~ Bool),+which is likewise uninhabited.++Note [No free join points in arityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we call arityType on this expression (EX1)+   \x . case x of True  -> \y. e+                  False -> $j 3+where $j is a join point.  It really makes no sense to talk of the arity+of this expression, because it has a free join point.  In particular, we+can't eta-expand the expression because we'd have do the same thing to the+binding of $j, and we can't see that binding.++If we had (EX2)+   \x. join $j y = blah+       case x of True  -> \y. e+                 False -> $j 3+then it would make perfect sense: we can determine $j's ArityType, and+propagate it to the usage site as usual.++But how can we get (EX1)?  It doesn't make much sense, because $j can't+be a join point under the \x anyway.  So we make it a precondition of+arityType that the argument has no free join-point Ids.  (This is checked+with an assert in the Var case of arityType.)++Wrinkles++* We /do/ allow free join point when doing findRhsArity for join-point+  right-hand sides. See Note [Arity for recursive join bindings]+  point (5) in GHC.Core.Opt.Simplify.Utils.++* The invariant (no free join point in arityType) risks being+  invalidated by one very narrow special case: runRW#++   join $j y = blah+   runRW# (\s. case x of True  -> \y. e+                         False -> $j x)++  We have special magic in OccurAnal, and Simplify to allow continuations to+  move into the body of a runRW# call.++  So we are careful never to attempt to eta-expand the (\s.blah) in the+  argument to runRW#, at least not when there is a literal lambda there,+  so that OccurAnal has seen it and allowed join points bound outside.+  See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration.++Note [arityType for non-recursive let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For non-recursive let-bindings, we just get the arityType of the RHS,+and extend the environment.  That works nicely for things like this+(#18793):+  go = \ ds. case ds_a2CF of {+               []     -> id+               : y ys -> case y of { GHC.Types.I# x ->+                         let acc = go ys in+                         case x ># 42# of {+                            __DEFAULT -> acc+                            1# -> \x1. acc (negate x2)++Here we want to get a good arity for `acc`, based on the ArityType+of `go`.++All this is particularly important for join points. Consider this (#18328)++  f x = join j y = case y of+                      True -> \a. blah+                      False -> \b. blah+        in case x of+              A -> j True+              B -> \c. blah+              C -> j False++and suppose the join point is too big to inline.  Now, what is the+arity of f?  If we inlined the join point, we'd definitely say "arity+2" because we are prepared to push case-scrutinisation inside a+lambda. It's important that we extend the envt with j's ArityType, so+that we can use that information in the A/C branch of the case.++Note [arityType for recursive let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For /recursive/ bindings it's more difficult, to call arityType+(as we do in Note [arityType for non-recursive let-bindings])+because we don't have an ArityType to put in the envt for the+recursively bound Ids.  So for we satisfy ourselves with whizzing up+up an ArityType from the idArity of the function, via idArityType.++That is nearly equivalent to deleting the binder from the envt, at+which point we'll call idArityType at the occurrences.  But doing it+here means++  (a) we only call idArityType once, no matter how many+      occurrences, and++  (b) we can check (in the arityType (Var v) case) that+      we don't mention free join-point Ids. See+      Note [No free join points in arityType].++But see Note [Arity for recursive join bindings] in+GHC.Core.Opt.Simplify.Utils for dark corners.+-}++{-+%************************************************************************+%*                                                                      *+              The main eta-expander+%*                                                                      *+%************************************************************************++We go for:+   f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym+                                 (n >= 0)++where (in both cases)++        * The xi can include type variables++        * The yi are all value variables++        * N is a NORMAL FORM (i.e. no redexes anywhere)+          wanting a suitable number of extra args.++The biggest reason for doing this is for cases like++        f = \x -> case x of+                    True  -> \y -> e1+                    False -> \y -> e2++Here we want to get the lambdas together.  A good example is the nofib+program fibheaps, which gets 25% more allocation if you don't do this+eta-expansion.++We may have to sandwich some coerces between the lambdas+to make the types work.   exprEtaExpandArity looks through coerces+when computing arity; and etaExpand adds the coerces as necessary when+actually computing the expansion.++Note [No crap in eta-expanded code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The eta expander is careful not to introduce "crap".  In particular,+given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it+returns a CoreExpr satisfying the same invariant. See Note [Eta+expansion and the CorePrep invariants] in CorePrep.++This means the eta-expander has to do a bit of on-the-fly+simplification but it's not too hard.  The alternative, of relying on+a subsequent clean-up phase of the Simplifier to de-crapify the result,+means you can't really use it in CorePrep, which is painful.++Note [Eta expansion for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The no-crap rule is very tiresome to guarantee when+we have join points. Consider eta-expanding+   let j :: Int -> Int -> Bool+       j x = e+   in b++The simple way is+  \(y::Int). (let j x = e in b) y++The no-crap way is+  \(y::Int). let j' :: Int -> Bool+                 j' x = e y+             in b[j'/j] y+where I have written b[j'/j] to stress that j's type has+changed.  Note that (of course!) we have to push the application+inside the RHS of the join as well as into the body.  AND if j+has an unfolding we have to push it into there too.  AND j might+be recursive...++So for now I'm abandoning the no-crap rule in this case, conscious that this+causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep].++(Moreover, I think that casts can make the no-crap rule fail too.)++Note [Eta expansion and SCCs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that SCCs are not treated specially by etaExpand.  If we have+        etaExpand 2 (\x -> scc "foo" e)+        = (\xy -> (scc "foo" e) y)+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"++Note [Eta expansion and source notes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrep puts floatable ticks outside of value applications, but not+type applications. As a result we might be trying to eta-expand an+expression like++  (src<...> v) @a++which we want to lead to code like++  \x -> src<...> v @a x++This means that we need to look through type applications and be ready+to re-add floats on the top.++Note [Eta expansion with ArityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The etaExpandAT function takes an ArityType (not just an Arity) to+guide eta-expansion.  Why? Because we want to preserve one-shot info.+Consider+  foo = \x. case x of+              True  -> (\s{os}. blah) |> co+              False -> wubble+We'll get an ArityType for foo of \?1.T.++Then we want to eta-expand to+  foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co++That 'eta' binder is fresh, and we really want it to have the+one-shot flag from the inner \s{os}.  By expanding with the+ArityType gotten from analysing the RHS, we achieve this neatly.++This makes a big difference to the one-shot monad trick;+see Note [The one-shot state monad trick] in GHC.Utils.Monad.+-}++-- | @etaExpand n e@ returns an expression with+-- the same meaning as @e@, but with arity @n@.+--+-- Given:+--+-- > e' = etaExpand n e+--+-- We should have that:+--+-- > ty = exprType e = exprType e'++etaExpand :: Arity -> CoreExpr -> CoreExpr+etaExpand n orig_expr+  = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr+  where+    in_scope = {-#SCC "eta_expand:in-scopeX" #-}+               mkInScopeSet (exprFreeVars orig_expr)++etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr+-- See Note [Eta expansion with ArityType]+--+-- We pass in the InScopeSet from the simplifier to avoid recomputing+-- it here, which can be jolly expensive if the casts are big+-- In #18223 it took 10% of compile time just to do the exprFreeVars!+etaExpandAT in_scope at orig_expr+  = eta_expand in_scope (arityTypeOneShots at) orig_expr++-- etaExpand arity e = res+-- Then 'res' has at least 'arity' lambdas at the top+--    possibly with a cast wrapped around the outside+-- See Note [Eta expansion with ArityType]+--+-- etaExpand deals with for-alls. For example:+--              etaExpand 1 E+-- where  E :: forall a. a -> a+-- would return+--      (/\b. \y::a -> E b y)++eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr+eta_expand in_scope one_shots (Cast expr co)+  = mkCast (eta_expand in_scope one_shots expr) co+    -- This mkCast is important, because eta_expand might return an+    -- expression with a cast at the outside; and tryCastWorkerWrapper+    -- asssumes that we don't have nested casts. Makes a difference+    -- in compile-time for T18223++eta_expand in_scope one_shots orig_expr+  = go in_scope one_shots [] orig_expr+  where+      -- Strip off existing lambdas and casts before handing off to mkEtaWW+      -- This is mainly to avoid spending time cloning binders and substituting+      -- when there is actually nothing to do.  It's slightly awkward to deal+      -- with casts here, apart from the topmost one, and they are rare, so+      -- if we find one we just hand off to mkEtaWW anyway+      -- Note [Eta expansion and SCCs]+    go _ [] _ _ = orig_expr  -- Already has the specified arity; no-op++    go in_scope oss@(_:oss1) vs (Lam v body)+      | isTyVar v = go (in_scope `extendInScopeSet` v) oss  (v:vs) body+      | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body++    go in_scope oss rev_vs expr+      = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $+        retick $+        etaInfoAbs top_eis $+        etaInfoApp in_scope' sexpr eis+      where+          (in_scope', eis@(EI eta_bndrs mco))+                    = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)+          top_bndrs = reverse rev_vs+          top_eis   = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco)++          -- Find ticks behind type apps.+          -- See Note [Eta expansion and source notes]+          -- I don't really understand this code SLPJ May 21+          (expr', args) = collectArgs expr+          (ticks, expr'') = stripTicksTop tickishFloatable expr'+          sexpr = mkApps expr'' args+          retick expr = foldr mkTick expr ticks++{- *********************************************************************+*                                                                      *+              The EtaInfo mechanism+          mkEtaWW, etaInfoAbs, etaInfoApp+*                                                                      *+********************************************************************* -}++{- Note [The EtaInfo mechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (e :: ty) and we want to eta-expand it to arity N.+This what eta_expand does.  We do it in two steps:++1.  mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes+    the shape of the expansion necessary to expand to arity N.++2.  Build the term+       \ v1..vn.  e v1 .. vn+    where those abstractions and applications are described by+    the same EtaInfo.  Specifically we build the term++       etaInfoAbs etas (etaInfoApp in_scope e etas)++   where etas :: EtaInfo+         etaInfoAbs builds the lambdas+         etaInfoApp builds the applications++   Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp++To a first approximation EtaInfo is just [Var].  But casts complicate+the question.  If we have+   newtype N a = MkN (S -> a)+     axN :: N a  ~  S -> a+and+   e :: N (N Int)+then the eta-expansion should look like+   (\(x::S) (y::S) -> (e |> co) x y) |> sym co+where+  co :: N (N Int) ~ S -> S -> Int+  co = axN @(N Int) ; (S -> axN @Int)++We want to get one cast, at the top, to account for all those+nested newtypes. This is expressed by the EtaInfo type:++   data EtaInfo = EI [Var] MCoercionR++Precisely, here is the (EtaInfo Invariant):++  EI bs co :: EtaInfo++describes a particular eta-expansion, thus:++  Abstraction:  (\b1 b2 .. bn. []) |> sym co+  Application:  ([] |> co) b1 b2 .. bn++  e  :: T+  co :: T ~R (t1 -> t2 -> .. -> tn -> tr)+  e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co+++Note [Check for reflexive casts in eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out that the casts created by the above mechanism are often Refl.+When casts are very deeply nested (as happens in #18223), the repetition+of types can make the overall term very large.  So there is a big+payoff in cancelling out casts aggressively wherever possible.+(See also Note [No crap in eta-expanded code].)++This matters particularly in etaInfoApp, where we+* Do beta-reduction on the fly+* Use getArg_maybe to get a cast out of the way,+  so that we can do beta reduction+Together this makes a big difference.  Consider when e is+   case x of+      True  -> (\x -> e1) |> c1+      False -> (\p -> e2) |> c2++When we eta-expand this to arity 1, say, etaInfoAbs will wrap+a (\eta) around the outside and use etaInfoApp to apply each+alternative to 'eta'.  We want to beta-reduce all that junk+away.++#18223 was a dramatic example in which the intermediate term was+grotesquely huge, even though the next Simplifier iteration squashed+it.  Better to kill it at birth.++The crucial spots in etaInfoApp are:+* `checkReflexiveMCo` in the (Cast e co) case of `go`+* `checkReflexiveMCo` in `pushCoArg`+* Less important: checkReflexiveMCo in the final case of `go`+Collectively these make a factor-of-5 difference to the total+allocation of T18223, so take care if you change this stuff!++Example:+   newtype N = MkN (Y->Z)+   f :: X -> N+   f = \(x::X). ((\(y::Y). blah) |> fco)++where fco :: (Y->Z) ~ N++mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co+  where+    eta_co :: (X->N) ~ (X->Y->Z)+    eta_co =  (<X> -> nco)+    nco :: N ~ (Y->Z)  -- Comes from topNormaliseNewType_maybe++Now, when we push that eta_co inward in etaInfoApp:+* In the (Cast e co) case, the 'fco' and 'nco' will meet, and+  should cancel.+* When we meet the (\y.e) we want no cast on the y.++-}++--------------+data EtaInfo = EI [Var] MCoercionR+     -- See Note [The EtaInfo mechanism]++instance Outputable EtaInfo where+  ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco)+++etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr+-- (etaInfoApp s e (EI bs mco) returns something equivalent to+--             ((substExpr s e) |> mco b1 .. bn)+-- See Note [The EtaInfo mechanism]+--+-- NB: With very deeply nested casts, this function can be expensive+--     In T18223, this function alone costs 15% of allocation, all+--     spent in the calls to substExprSC and substBindSC++etaInfoApp in_scope expr eis+  = go (mkEmptySubst in_scope) expr eis+  where+    go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr+    -- 'go' pushed down the eta-infos into the branch of a case+    -- and the body of a let; and does beta-reduction if possible+    --   go subst fun co [b1,..,bn]  returns  (subst(fun) |> co) b1 .. bn+    go subst (Tick t e) eis+      = Tick (substTickish subst t) (go subst e eis)++    go subst (Cast e co) (EI bs mco)+      = go subst e (EI bs mco')+      where+        mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco)+               -- See Note [Check for reflexive casts in eta expansion]++    go subst (Case e b ty alts) eis+      = Case (Core.substExprSC subst e) b1 ty' alts'+      where+        (subst1, b1) = Core.substBndr subst b+        alts' = map subst_alt alts+        ty'   = etaInfoAppTy (substTyUnchecked subst ty) eis+        subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis)+                 where+                  (subst2,bs') = Core.substBndrs subst1 bs++    go subst (Let b e) eis+      | not (isJoinBind b) -- See Note [Eta expansion for join points]+      = Let b' (go subst' e eis)+      where+        (subst', b') = Core.substBindSC subst b++    -- Beta-reduction if possible, pushing any intervening casts past+    -- the argument. See Note [The EtaInfo mechanism]+    go subst (Lam v e) (EI (b:bs) mco)+      | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b)+      = go (Core.extendSubst subst v arg) e (EI bs mco')++    -- Stop pushing down; just wrap the expression up+    -- See Note [Check for reflexive casts in eta expansion]+    go subst e (EI bs mco) = Core.substExprSC subst e+                             `mkCastMCo` checkReflexiveMCo mco+                             `mkVarApps` bs++--------------+etaInfoAppTy :: Type -> EtaInfo -> Type+-- If                    e :: ty+-- then   etaInfoApp e eis :: etaInfoApp ty eis+etaInfoAppTy ty (EI bs mco)+  = applyTypeToArgs ty1 (map varToCoreExpr bs)+  where+    ty1 = case mco of+             MRefl  -> ty+             MCo co -> coercionRKind co++--------------+etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr+-- See Note [The EtaInfo mechanism]+etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco++--------------+-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding+-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the+-- free variables of @e@.+--+-- Note that this function is entirely unconcerned about cost centres and other+-- semantically-irrelevant source annotations, so call sites must take care to+-- preserve that info. See Note [Eta expansion and SCCs].+mkEtaWW+  :: [OneShotInfo]+  -- ^ How many value arguments to eta-expand+  -> SDoc+  -- ^ The pretty-printed original expression, for warnings.+  -> InScopeSet+  -- ^ A super-set of the free vars of the expression to eta-expand.+  -> Type+  -> (InScopeSet, EtaInfo)+  -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'.+  -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the+  -- fresh variables in 'EtaInfo'.++mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty+  = go 0 orig_oss empty_subst orig_ty+  where+    empty_subst = mkEmptySubst in_scope++    go :: Int                -- For fresh names+       -> [OneShotInfo]      -- Number of value args to expand to+       -> Subst -> Type   -- We are really looking at subst(ty)+       -> (InScopeSet, EtaInfo)+    -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co)+    --    co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr++    go _ [] subst _+       ----------- Done!  No more expansion needed+       = (substInScopeSet subst, EI [] MRefl)++    go n oss@(one_shot:oss1) subst ty+       ----------- Forall types  (forall a. ty)+       | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty+       , (subst', tcv') <- Type.substVarBndr subst tcv+       , let oss' | isTyVar tcv = oss+                  | otherwise   = oss1+         -- A forall can bind a CoVar, in which case+         -- we consume one of the [OneShotInfo]+       , (in_scope, EI bs mco) <- go n oss' subst' ty'+       = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco))++       ----------- Function types  (t1 -> t2)+       | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty+       , typeHasFixedRuntimeRep arg_ty+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- See also test case typecheck/should_run/EtaExpandLevPoly++       , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)+          -- Avoid free vars of the original expression++       , let eta_id' = eta_id `setIdOneShotInfo` one_shot+       , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty+       = (in_scope, EI (eta_id' : bs) (mkFunResMCo eta_id' mco))++       ----------- Newtypes+       -- Given this:+       --      newtype T = MkT ([T] -> Int)+       -- Consider eta-expanding this+       --      eta_expand 1 e T+       -- We want to get+       --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)+       | Just (co, ty') <- topNormaliseNewType_maybe ty+       , -- co :: ty ~ ty'+         let co' = Type.substCo subst co+             -- Remember to apply the substitution to co (#16979)+             -- (or we could have applied to ty, but then+             --  we'd have had to zap it for the recursive call)+       , (in_scope, EI bs mco) <- go n oss subst ty'+         -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr+       = (in_scope, EI bs (mkTransMCoR co' mco))++       | otherwise       -- We have an expression of arity > 0,+                         -- but its type isn't a function, or a binder+                         -- does not have a fixed runtime representation+       = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)+         (substInScopeSet subst, EI [] MRefl)+        -- This *can* legitimately happen:+        -- e.g.  coerce Int (\x. x) Essentially the programmer is+        -- playing fast and loose with types (Happy does this a lot).+        -- So we simply decline to eta-expand.  Otherwise we'd end up+        -- with an explicit lambda having a non-function type++mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion+mkEtaForAllMCo (Bndr tcv vis) ty mco+  = case mco of+      MRefl | vis == coreTyLamForAllTyFlag -> MRefl+            | otherwise                    -> mk_fco (mkRepReflCo ty)+      MCo co                               -> mk_fco co+  where+    mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag+                                (mkNomReflCo (varType tcv)) co)+    -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly+    -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has+    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]+    -- in GHC.Core.TyCo.Rep++{-+************************************************************************+*                                                                      *+                Eta reduction+*                                                                      *+************************************************************************++Note [Eta reduction makes sense]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's eta reduction transforms+   \x y. <fun> x y  --->  <fun>+We discuss when this is /sound/ in Note [Eta reduction soundness].+But even assuming it is sound, when is it /desirable/.  That+is what we discuss here.++This test is made by `ok_fun` in tryEtaReduce.++1. We want to eta-reduce only if we get all the way to a trivial+   expression; we don't want to remove extra lambdas unless we are+   going to avoid allocating this thing altogether.++   Trivial means *including* casts and type lambdas:+     * `\x. f x |> co  -->  f |> (ty(x) -> co)` (provided `co` doesn't mention `x`)+     * `/\a. \x. f @(Maybe a) x -->  /\a. f @(Maybe a)`+   See Note [Do not eta reduce PAPs] for why we insist on a trivial head.++Of course, eta reduction is not always sound. See Note [Eta reduction soundness]+for when it is.++When there are multiple arguments, we might get multiple eta-redexes. Example:+   \x y. e x y+   ==> { reduce \y. (e x) y in context \x._ }+   \x. e x+   ==> { reduce \x. e x in context _ }+   e+And (1) implies that we never want to stop with `\x. e x`, because that is not a+trivial expression. So in practice, the implementation works by considering a+whole group of leading lambdas to reduce.++These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF'+in 'tryEtaReduce'. Alas.++Note [Eta reduction soundness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's eta reduction transforms+   \x y. <fun> x y  --->  <fun>+For soundness, we obviously require that `x` and `y`+to not occur free. But what /other/ restrictions are there for+eta reduction to be sound?++We discuss separately what it means for eta reduction to be+/desirable/, in Note [Eta reduction makes sense].++Eta reduction is *not* a sound transformation in general, because it+may change termination behavior if *value* lambdas are involved:+  `bot`  /=  `\x. bot x`   (as can be observed by a simple `seq`)+The past has shown that oversight of this fact can not only lead to endless+loops or exceptions, but also straight out *segfaults*.++Nevertheless, we can give the following criteria for when it is sound to+perform eta reduction on an expression with n leading lambdas `\xs. e xs`+(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the+case where `e` is trivial):++(A) It is sound to eta-reduce n arguments as long as n does not exceed the+    `exprArity` of `e`. (Needs Arity analysis.)+    This criterion exploits information about how `e` is *defined*.++    Example: If `e = \x. bot` then we know it won't diverge until it is called+    with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`.+    By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`:+    `e 42` diverges when `(\x y. e x y) 42` does not.++(S) It is sound to eta-reduce n arguments in an evaluation context in which all+    calls happen with at least n arguments. (Needs Strictness analysis.)+    NB: This treats evaluations like a call with 0 args.+    NB: This criterion exploits information about how `e` is *used*.++    Example: Given a function `g` like+      `g c = Just (c 1 2 + c 2 3)`+    it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without+    knowing *anything* about `e` (perhaps it's a parameter occ itself), simply+    because `g` always calls its parameter with 2 arguments.+    It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`.+    By contrast, it would *unsound* to eta-reduce 3 args in a call site+    like `g (\x y z. e x y z)` to `g e`, because that diverges when+    `e = \x y. bot`.++    Could we relax to "*At least one call in the same trace* is with n args"?+    No. Consider what happens for+      ``g2 c = c True `seq` c False 42``+    Here, `g2` will call `c` with 2 arguments (if there is a call at all).+    But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e`+    when `e = \x. if x then bot else id`, because the latter will diverge when+    the former would not. Fortunately, the strictness analyser will report+    "Not always called with two arguments" for `g2` and we won't eta-expand.++    See Note [Eta reduction based on evaluation context] for the implementation+    details. This criterion is tested extensively in T21261.++(R) Note [Eta reduction in recursive RHSs] tells us that we should not+    eta-reduce `f` in its own RHS and describes our fix.+    There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which+    might change a terminating program (think @f `seq` e@) to a non-terminating+    one.++(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the+    boundary of (A) and (S), when we know that a fun binder `f` is in+    WHNF, we simply assume it has arity 1 and apply (A).  Example:+       g f = f `seq` \x. f x+    Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom+    after the `seq`. This turned up in #7542.++ T. If the binders are all type arguments, it's always safe to eta-reduce,+    regardless of the arity of f.+       /\a b. f @a @b  --> f++2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it+   is always sound to reduce /type lambdas/, thus:+        (/\a -> f a)  -->   f+   Moreover, we always want to, because it makes RULEs apply more often:+      This RULE:    `forall g. foldr (build (/\a -> g a))`+      should match  `foldr (build (/\b -> ...something complex...))`+   and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.++   More debatably, we extend this to dictionary arguments too, because the type+   checker can insert these eta-expanded versions, with both type and dictionary+   lambdas; hence the slightly ad-hoc (all ok_lam bndrs).  That is, we eta-reduce+        \(d::Num a). f d   -->   f+   regardless of f's arity. Its not clear whether or not this is important, and+   it is not in general sound.  But that's the way it is right now.++And here are a few more technical criteria for when it is *not* sound to+eta-reduce that are specific to Core and GHC:++(J) We may not undersaturate join points.+    See Note [Invariants on join points] in GHC.Core, and #20599.++(B) We may not undersaturate functions with no binding.+    See Note [Eta expanding primops].++(W) We may not undersaturate StrictWorkerIds.+    See Note [CBV Function Ids] in GHC.Types.Id.Info.++Here is a list of historic accidents surrounding unsound eta-reduction:++* Consider+        f = \x.f x+        h y = case (case y of { True -> f `seq` True; False -> False }) of+                True -> ...; False -> ...+  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser+  says f=bottom, and replaces the (f `seq` True) with just+  (f `cast` unsafe-co).+  [SG in 2022: I don't think worker/wrapper would do this today.]+  BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also+  wrongly). So CorePrep eta-expands the definition again, so that it does not+  terminate after all.+  Result: seg-fault because the boolean case actually gets a function value.+  See #1947.++* Never *reduce* arity. For example+      f = \xy. g x y+  Then if h has arity 1 we don't want to eta-reduce because then+  f's arity would decrease, and that is bad+  [SG in 2022: I don't understand this point. There is no `h`, perhaps that+   should have been `g`. Even then, this proposed eta-reduction is invalid by+   criterion (A), which might actually be the point this anecdote is trying to+   make. Perhaps the "no arity decrease" idea is also related to+   Note [Arity robustness]?]++Note [Do not eta reduce PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I considered eta-reducing if the result is a PAP:+   \x. f e1 e2 x  ==>   f e1 e2++This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs]+in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand+a PAP.  If eta-expanding is bad, then eta-reducing is good!++Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep+Note [No eta reduction needed in rhsToBody].++But note that we don't want to eta-reduce+     \x y.  f <expensive> x y+to+     f <expensive>+The former has arity 2, and repeats <expensive> for every call of the+function; the latter has arity 0, and shares <expensive>.  We don't want+to change behaviour.  Hence the call to exprIsCheap in ok_fun.++I noticed this when examining #18993 and, although it is delicate,+eta-reducing to a PAP happens to fix the regression in #18993.++HOWEVER, if we transform+   \x. f y x   ==>   f y+that might mean that f isn't saturated any more, and does not inline.+This led to some other regressions.++TL;DR currently we do /not/ eta reduce if the result is a PAP.++Note [Eta reduction with casted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    (\(x:t3). f (x |> g)) :: t3 -> t2+  where+    f :: t1 -> t2+    g :: t3 ~ t1+This should be eta-reduced to++    f |> (sym g -> t2)++So we need to accumulate a coercion, pushing it inward (past+variable arguments only) thus:+   f (x |> co_arg) |> co  -->  (f |> (sym co_arg -> co)) x+   f (x:t)         |> co  -->  (f |> (t -> co)) x+   f @ a           |> co  -->  (f |> (forall a.co)) @ a+   f @ (g:t1~t2)   |> co  -->  (f |> (t1~t2 => co)) @ (g:t1~t2)+These are the equations for ok_arg.++Note [Eta reduction with casted function]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since we are pushing a coercion inwards, it is easy to accommodate+    (\xy. (f x |> g) y)+    (\xy. (f x y) |> g)++See the `(Cast e co)` equation for `go` in `tryEtaReduce`.  The+eta-expander pushes those casts outwards, so you might think we won't+ever see a cast here, but if we have+  \xy. (f x y |> g)+we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to+work.  This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where+eta-expansion may be turned off (by sm_eta_expand).++Note [Eta reduction based on evaluation context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Eta reduction soundness], criterion (S) allows us to eta-reduce+`g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with+at least 2 arguments. So how do we read that off `g`'s demand signature?++Let's take the simple example of #21261, where `g` (actually, `f`) is defined as+  g c = c 1 2 + c 3 4+Then this is how the pieces are put together:++  * Demand analysis infers `<SC(S,C(1,L))>` for `g`'s demand signature++  * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it+    looks up the *evaluation context* of the argument in the form of the+    sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'.+    (Why does it drop the outer evaluation cardinality of the demand, `S`?+    Because it's irrelevant! When we simplify an expression, we do so under the+    assumption that it is currently under evaluation.)+    This sub-demand literally says "Whenever this expression is evaluated, it+    is called with at least two arguments, potentially multiple times".++  * Then the simplifier takes apart the lambda and simplifies the lambda group+    and then calls 'tryEtaReduce' when rebuilding the lambda, passing the+    evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call+    sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and+    `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce+    `\x y. e x y` to `e`.++Note [Eta reduction in recursive RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following recursive function:+  f = \x. ....g (\y. f y)....+The recursive call of f in its own RHS seems like a fine opportunity for+eta-reduction because f has arity 1. And often it is!++Alas, that is unsound in general if the eta-reduction happens in a tail context.+Making the arity visible in the RHS allows us to eta-reduce+  f = \x -> f x+to+  f = f+which means we optimise terminating programs like (f `seq` ()) into+non-terminating ones. Nor is this problem just for tail calls.  Consider+  f = id (\x -> f x)+where we have (for some reason) not yet inlined `id`.  We must not eta-reduce to+  f = id f+because that will then simplify to `f = f` as before.++An immediate idea might be to look at whether the called function is a local+loopbreaker and refrain from eta-expanding. But that doesn't work for mutually+recursive function like in #21652:+  f = g+  g* x = f x+Here, g* is the loopbreaker but f isn't.++What can we do?++Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when+    entering the let body.+    Has the disadvantage that other transformations which make use of arity+    (such as dropping of `seq`s when arity > 0) will no longer work in the RHS.+    Plus it requires non-trivial refactorings to both the simple optimiser (in+    the way `subst_opt_bndr` is used) as well as the Simplifier (in the way+    `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's+    substitution twice in the process. A very complicated stop-gap.++Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are+    the ones we should not eta-reduce. All call-site must maintain this set.+    Example:+      rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }...+          ; f2 = ...f1... }+    when eta-reducing those inner lambdas, we need to know that we are in the+    rec group for {f1, f2, g}.+    This is very much like the solution in Note [Speculative evaluation] in+    GHC.CoreToStg.Prep.+    It is a bit tiresome to maintain this info, because it means another field+    in SimplEnv and SimpleOptEnv.++We implement Fix (2) because of it isn't as complicated to maintain as (1).+Plus, it is the correct fix to begin with. After all, the arity is correct,+but doing the transformation isn't. The moving parts are:+  * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders+  * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind`+  * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce`+The situation is very similar to Note [Speculative evaluation] which has the+same fix.+-}++-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated+-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`.+-- See Note [Eta reduction soundness]+-- and Note [Eta reduction makes sense] when that is the case.+tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr+-- Return an expression equal to (\bndrs. body)+tryEtaReduce rec_ids bndrs body eval_sd+  = go (reverse bndrs) body (mkRepReflCo (exprType body))+  where+    incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2)++    go :: [Var]            -- Binders, innermost first, types [a3,a2,a1]+       -> CoreExpr         -- Of type tr+       -> Coercion         -- Of type tr ~ ts+       -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts+    -- See Note [Eta reduction with casted arguments]+    -- for why we have an accumulating coercion+    --+    -- Invariant: (go bs body co) returns an expression+    --            equivalent to (\(reverse bs). (body |> co))++    -- See Note [Eta reduction with casted function]+    go bs (Cast e co1) co2+      = go bs e (co1 `mkTransCo` co2)++    go bs (Tick t e) co+      | tickishFloatable t+      = fmap (Tick t) $ go bs e co+      -- Float app ticks: \x -> Tick t (e x) ==> Tick t e++    go (b : bs) (App fun arg) co+      | Just (co', ticks) <- ok_arg b arg co (exprType fun)+      = fmap (flip (foldr mkTick) ticks) $ go bs fun co'+            -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e++    go remaining_bndrs fun co+      | all isTyVar remaining_bndrs+            -- If all the remaining_bnrs are tyvars, then the etad_exp+            --    will be trivial, which is what we want.+            -- e.g. We might have  /\a \b. f [a] b, and we want to+            --      eta-reduce to  /\a. f [a]+            -- We don't want to give up on this one: see #20040+            -- See Note [Eta reduction makes sense], point (1)+      , remaining_bndrs `ltLength` bndrs+            -- Only reply Just if /something/ has happened+      , ok_fun fun+      , let used_vars     = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co+            reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs)+            -- reduced_bndrs are the ones we are eta-reducing away+      , used_vars `disjointVarSet` reduced_bndrs+          -- Check for any of the reduced_bndrs (about to be dropped)+          -- free in the result, including the accumulated coercion.+          -- See Note [Eta reduction makes sense], intro and point (1)+          -- NB: don't compute used_vars from exprFreeVars (mkCast fun co)+          --     because the latter may be ill formed if the guard fails (#21801)+      = Just (mkLams (reverse remaining_bndrs) (mkCast fun co))++    go _remaining_bndrs _fun  _  = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $+                                   Nothing++    ---------------+    -- See Note [Eta reduction makes sense], point (1)+    ok_fun (App fun (Type {})) = ok_fun fun+    ok_fun (Cast fun _)        = ok_fun fun+    ok_fun (Tick _ expr)       = ok_fun expr+    ok_fun (Var fun_id)        = is_eta_reduction_sound fun_id+    ok_fun _fun                = False++    ---------------+    -- See Note [Eta reduction soundness], this is THE place to check soundness!+    is_eta_reduction_sound fun+      | fun `elemUnVarSet` rec_ids          -- Criterion (R)+      = False -- Don't eta-reduce in fun in its own recursive RHSs++      | cantEtaReduceFun fun                -- Criteria (J), (W), (B)+      = False -- Function can't be eta reduced to arity 0+              -- without violating invariants of Core and GHC++      | otherwise+      = -- Check that eta-reduction won't make the program stricter...+        fun_arity fun >= incoming_arity          -- Criterion (A) and (E)+        || all_calls_with_arity incoming_arity   -- Criterion (S)+        || all ok_lam bndrs                      -- Criterion (T)++    all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd)+       -- See Note [Eta reduction based on evaluation context]++    ---------------+    fun_arity fun+       | arity > 0                           = arity+       | isEvaldUnfolding (idUnfolding fun)  = 1+           -- See Note [Eta reduction soundness], criterion (E)+       | otherwise                           = 0+       where+         arity = idArity fun++    ---------------+    ok_lam v = isTyVar v || isEvId v+    -- See Note [Eta reduction makes sense], point (2)++    ---------------+    ok_arg :: Var              -- Of type bndr_t+           -> CoreExpr         -- Of type arg_t+           -> Coercion         -- Of kind (t1~t2)+           -> Type             -- Type (arg_t -> t1) of the function+                               --      to which the argument is supplied+           -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)+                               --   (and similarly for tyvars, coercion args)+                    , [CoreTickish])+    -- See Note [Eta reduction with casted arguments]+    ok_arg bndr (Type arg_ty) co fun_ty+       | Just tv <- getTyVar_maybe arg_ty+       , bndr == tv  = case splitForAllForAllTyBinder_maybe fun_ty of+           Just (Bndr _ vis, _) -> Just (fco, [])+             where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co+                   -- The lambda we are eta-reducing always has visibility+                   -- 'coreTyLamForAllTyFlag' which may or may not match+                   -- the visibility on the inner function (#24014)+                   kco = mkNomReflCo (tyVarKind tv)+           Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"+                               (text "fun:" <+> ppr bndr+                                $$ text "arg:" <+> ppr arg_ty+                                $$ text "fun_ty:" <+> ppr fun_ty)+    ok_arg bndr (Var v) co fun_ty+       | bndr == v+       , let mult = idMult bndr+       , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty+       , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort+       = Just (mkFunResCo Representational bndr co, [])+    ok_arg bndr (Cast e co_arg) co fun_ty+       | (ticks, Var v) <- stripTicksTop tickishFloatable e+       , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty+       , bndr == v+       , fun_mult `eqType` idMult bndr+       = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks)+       -- The simplifier combines multiple casts into one,+       -- so we can have a simple-minded pattern match here+    ok_arg bndr (Tick t arg) co fun_ty+       | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty+       = Just (co', t:ticks)++    ok_arg _ _ _ _ = Nothing++-- | Can we eta-reduce the given function+-- See Note [Eta reduction soundness], criteria (B), (J), and (W).+cantEtaReduceFun :: Id -> Bool+cantEtaReduceFun fun+  =    hasNoBinding fun -- (B)+       -- Don't undersaturate functions with no binding.++    ||  isJoinId fun    -- (J)+       -- Don't undersaturate join points.+       -- See Note [Invariants on join points] in GHC.Core, and #20599++    || (isJust (idCbvMarks_maybe fun)) -- (W)+       -- Don't undersaturate StrictWorkerIds.+       -- See Note [CBV Function Ids] in GHC.Types.Id.Info.+++{- *********************************************************************+*                                                                      *+              The "push rules"+*                                                                      *+************************************************************************++Here we implement the "push rules" from FC papers:++* The push-argument rules, where we can move a coercion past an argument.+  We have+      (fun |> co) arg+  and we want to transform it to+    (fun arg') |> co'+  for some suitable co' and transformed arg'.++* The PushK rule for data constructors.  We have+       (K e1 .. en) |> co+  and we want to transform to+       (K e1' .. en')+  by pushing the coercion into the arguments+-}++pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)+pushCoArgs co []         = return ([], MCo co)+pushCoArgs co (arg:args) = do { (arg',  m_co1) <- pushCoArg  co  arg+                              ; case m_co1 of+                                  MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args+                                                 ; return (arg':args', m_co2) }+                                  MRefl  -> return (arg':args, MRefl) }++pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+pushMCoArg MRefl    arg = Just (arg, MRefl)+pushMCoArg (MCo co) arg = pushCoArg co arg++pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+-- We have (fun |> co) arg, and we want to transform it to+--         (fun arg) |> co+-- This may fail, e.g. if (fun :: N) where N is a newtype+-- C.f. simplCast in GHC.Core.Opt.Simplify+-- 'co' is always Representational+pushCoArg co arg+  | Type ty <- arg+  = do { (ty', m_co') <- pushCoTyArg co ty+       ; return (Type ty', m_co') }+  | otherwise+  = do { (arg_mco, m_co') <- pushCoValArg co+       ; let arg_mco' = checkReflexiveMCo arg_mco+             -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion]+             -- The coercion is very often (arg_co -> res_co), but without+             -- the argument coercion actually being ReflCo+       ; return (arg `mkCastMCo` arg_mco', m_co') }++pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)+-- We have (fun |> co) @ty+-- Push the coercion through to return+--         (fun @ty') |> co'+-- 'co' is always Representational+-- If the returned coercion is Nothing, then it would have been reflexive;+-- it's faster not to compute it, though.+pushCoTyArg co ty+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (ty, Nothing)++  | isReflCo co+  = Just (ty, MRefl)++  | isForAllTy_ty tyL+  = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $+    Just (ty `mkCastTy` co1, MCo co2)++  | otherwise+  = Nothing+  where+    Pair tyL tyR = coercionKind co+       -- co :: tyL ~R tyR+       -- tyL = forall (a1 :: k1). ty1+       -- tyR = forall (a2 :: k2). ty2++    co1 = mkSymCo (mkSelCo SelForAll co)+       -- co1 :: k2 ~N k1+       -- Note that SelCo extracts a Nominal equality between the+       -- kinds of the types related by a coercion between forall-types.+       -- See the SelCo case in GHC.Core.Lint.++    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)+        -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ]+        -- Arg of mkInstCo is always nominal, hence Nominal++-- | If @pushCoValArg co = Just (co_arg, co_res)@, then+--+-- > (\x.body) |> co  =  (\y. let { x = y |> co_arg } in body) |> co_res)+--+-- or, equivalently+--+-- > (fun |> co) arg  =  (fun (arg |> co_arg)) |> co_res+--+-- If the LHS is well-typed, then so is the RHS. In particular, the argument+-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)+pushCoValArg co+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (mkRepReflCo arg, Nothing)++  | isReflCo co+  = Just (MRefl, MRefl)++  | isFunTy tyL+  , (_, co1, co2) <- decomposeFunCo co+      -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)+      -- then co1 :: tyL1 ~ tyR1+      --      co2 :: tyL2 ~ tyR2++  , typeHasFixedRuntimeRep new_arg_ty+    -- We can't push the coercion inside if it would give rise to+    -- a representation-polymorphic argument.++  = assertPpr (isFunTy tyL && isFunTy tyR)+     (vcat [ text "co:" <+> ppr co+           , text "old_arg_ty:" <+> ppr old_arg_ty+           , text "new_arg_ty:" <+> ppr new_arg_ty ]) $+    Just (coToMCo (mkSymCo co1), coToMCo co2)+    -- Critically, coToMCo to checks for ReflCo; the whole coercion may not+    -- be reflexive, but either of its components might be+    -- We could use isReflexiveCo, but it's not clear if the benefit+    -- is worth the cost, and it makes no difference in #18223++  | otherwise+  = Nothing+  where+    old_arg_ty = funArgTy tyR+    new_arg_ty = funArgTy tyL+    Pair tyL tyR = coercionKind co++pushCoercionIntoLambda+    :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)+-- This implements the Push rule from the paper on coercions+--    (\x. e) |> co+-- ===>+--    (\x'. e |> co')+pushCoercionIntoLambda in_scope x e co+    | assert (not (isTyVar x) && not (isCoVar x)) True+    , Pair s1s2 t1t2 <- coercionKind co+    , Just {}              <- splitFunTy_maybe s1s2+    , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2+    , (_, co1, co2)  <- decomposeFunCo co+    , typeHasFixedRuntimeRep t1+      -- We can't push the coercion into the lambda if it would create+      -- a representation-polymorphic binder.+    = let+          -- Should we optimize the coercions here?+          -- Otherwise they might not match too well+          x' = x `setIdType` t1 `setIdMult` w1+          in_scope' = in_scope `extendInScopeSet` x'+          subst = extendIdSubst (mkEmptySubst in_scope')+                                x+                                (mkCast (Var x') (mkSymCo co1))+            -- We substitute x' for x, except we need to preserve types.+            -- The types are as follows:+            --   x :: s1,  x' :: t1,  co1 :: s1 ~# t1,+            -- so we extend the substitution with x |-> (x' |> sym co1).+      in Just (x', substExpr subst e `mkCast` co2)+    | otherwise+    = Nothing++pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR+              -> Maybe (DataCon+                       , [Type]      -- Universal type args+                       , [CoreExpr]) -- All other args incl existentials+-- Implement the KPush reduction rule as described in "Down with kinds"+-- The transformation applies iff we have+--      (C e1 ... en) `cast` co+-- where co :: (T t1 .. tn) ~ (T s1 .. sn)+-- The left-hand one must be a T, because exprIsConApp returned True+-- but the right-hand one might not be.  (Though it usually will.)+pushCoDataCon dc dc_args MRefl    = Just $! (push_dc_refl dc dc_args)+pushCoDataCon dc dc_args (MCo co) = push_dc_gen  dc dc_args co (coercionKind co)++push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr])+push_dc_refl dc dc_args+  = (dc, map exprToType univ_ty_args, rest_args)+  where+    !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args++push_dc_gen :: DataCon -> [CoreExpr] -> CoercionR -> Pair Type+            -> Maybe (DataCon, [Type], [CoreExpr])+push_dc_gen dc dc_args co (Pair from_ty to_ty)+  | from_ty `eqType` to_ty  -- try cheap test first+  = Just $! (push_dc_refl dc dc_args)++  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty+  , to_tc == dataConTyCon dc+        -- These two tests can fail; we might see+        --      (C x y) `cast` (g :: T a ~ S [a]),+        -- where S is a type function.  In fact, exprIsConApp+        -- will probably not be called in such circumstances,+        -- but there's nothing wrong with it+  = Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational)++  | otherwise+  = Nothing+++push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr]+              -> CoercionR -> Role                  -- Coercion and its role+              -> (DataCon, [Type], [CoreExpr])+push_data_con to_tc to_tc_arg_tys dc dc_args co role+  = assertPpr (eqType from_ty dc_app_ty)     dump_doc $+    assertPpr (equalLength val_args arg_tys) dump_doc $+    assertPpr (role == coercionRole co)      dump_doc $+    assertPpr (isInjectiveTyCon to_tc role)  dump_doc $+    -- isInjectiveTyCon: see (UCM9) in Note [Unary class magic]+    --                   in GHC.Core.TyCon+    (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)+  where+    Pair from_ty to_ty = coercionKind co+    tc_arity       = tyConArity to_tc+    dc_univ_tyvars = dataConUnivTyVars dc+    dc_ex_tcvars   = dataConExTyCoVars dc+    arg_tys        = dataConRepArgTys dc++    dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)++    non_univ_args  = dropList dc_univ_tyvars dc_args+    (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args++    -- Make the "Psi" from the paper+    omegas = decomposeCo tc_arity co (tyConRolesX role to_tc)+    (psi_subst, to_ex_arg_tys)+      = liftCoSubstWithEx dc_univ_tyvars+                          omegas+                          dc_ex_tcvars+                          (map exprToType ex_args)++      -- Cast the value arguments (which include dictionaries)+    new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args+    cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)++    to_ex_args = map Type to_ex_arg_tys++    dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars+                    , ppr arg_tys, ppr dc_args+                    , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc+                    , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]++collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)+-- Collect lambda binders, pushing coercions inside if possible+-- E.g.   (\x.e) |> g         g :: <Int> -> blah+--        = (\x. e |> SelCo (SelFun SelRes) g)+--+-- That is,+--+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g)+collectBindersPushingCo e+  = go [] e+  where+    -- Peel off lambdas until we hit a cast.+    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)+    -- The accumulator is in reverse order+    go bs (Lam b e)   = go (b:bs) e+    go bs (Cast e co) = go_c bs e co+    go bs e           = (reverse bs, e)++    -- We are in a cast; peel off casts until we hit a lambda.+    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_c bs e c) is same as (go bs e (e |> c))+    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)+    go_c bs (Lam b e)    co  = go_lam bs b e co+    go_c bs e            co  = (reverse bs, mkCast e co)++    -- We are in a lambda under a cast; peel off lambdas and build a+    -- new coercion for the body.+    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)+    go_lam bs b e co+      | isTyVar b+      , let Pair tyL tyR = coercionKind co+      , assert (isForAllTy_ty tyL) $+        isForAllTy_ty tyR+      , isReflCo (mkSelCo SelForAll co)  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))++      | isCoVar b+      , let Pair tyL tyR = coercionKind co+      , assert (isForAllTy_co tyL) $+        isForAllTy_co tyR+      , isReflCo (mkSelCo SelForAll co)  -- See Note [collectBindersPushingCo]+      , let cov = mkCoVarCo b+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))++      | isId b+      , let Pair tyL tyR = coercionKind co+      , assert (isFunTy tyL) $ isFunTy tyR+      , (co_mult, co_arg, co_res) <- decomposeFunCo co+      , isReflCo co_mult -- See Note [collectBindersPushingCo]+      , isReflCo co_arg  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e co_res++      | otherwise = (reverse bs, mkCast (Lam b e) co)++{- Note [collectBindersPushingCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We just look for coercions of form+   <type> % w -> blah+(and similarly for foralls) to keep this function simple.  We could do+more elaborate stuff, but it'd involve substitution etc.+-}++{- *********************************************************************+*                                                                      *+                Join points+*                                                                      *+********************************************************************* -}++-------------------+-- | Split an expression into the given number of binders and a body,+-- eta-expanding if necessary. Counts value *and* type binders.+etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)+etaExpandToJoinPoint join_arity expr+  = go join_arity [] expr+  where+    go 0 rev_bs e         = (reverse rev_bs, e)+    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e+    go n rev_bs e         = case etaBodyForJoinPoint n e of+                              (bs, e') -> (reverse rev_bs ++ bs, e')++etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule+etaExpandToJoinPointRule _ rule@(BuiltinRule {})+  = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule)+      -- How did a local binding get a built-in rule anyway? Probably a plugin.+    rule+etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs+                                               , ru_args  = args })+  | need_args == 0+  = rule+  | need_args < 0+  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)+  | otherwise+  = rule { ru_bndrs = bndrs ++ new_bndrs+         , ru_args  = args ++ new_args+         , ru_rhs   = new_rhs }+  -- new_rhs really ought to be occ-analysed (see GHC.Core Note+  -- [OccInfo in unfoldings and rules]), but it makes a module loop to+  -- do so; it doesn't happen often; and it doesn't really matter if+  -- the outer binders have bogus occurrence info; and new_rhs won't+  -- have dead code if rhs didn't.++  where+    need_args = join_arity - length args+    (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs+    new_args = varsToCoreExprs new_bndrs++-- Adds as many binders as asked for; assumes expr is not a lambda+etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)+etaBodyForJoinPoint need_args body+  = go need_args body_ty (mkEmptySubst in_scope) [] body+  where+    go 0 _  _     rev_bs e+      = (reverse rev_bs, e)+    go n ty subst rev_bs e+      | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty+      , let (subst', tv') = substVarBndr subst tv+      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')+        -- The varToCoreExpr is important: `tv` might be a coercion variable++      | Just (_, mult, arg_ty, res_ty) <- splitFunTy_maybe ty+      , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty)+      = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b)+        -- The varToCoreExpr is important: `b` might be a coercion variable++      | otherwise+      = pprPanic "etaBodyForJoinPoint" $ int need_args $$+                                         ppr body $$ ppr (exprType body)++    body_ty = exprType body+    in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty)+    -- in_scope is a bit tricky.+    -- - We are wrapping `body` in some value lambdas, so must not shadow+    --   any free vars of `body`+    -- - We are wrapping `body` in some type lambdas, so must not shadow any+    --   tyvars in body_ty.  Example: body is just a variable+    --            (g :: forall (a::k). T k a -> Int)+    --   We must not shadown that `k` when adding the /\a. So treat the free vars+    --   of body_ty as in-scope.  Showed up in #23026.++--------------+freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id)+-- Make a fresh Id, with specified type (after applying substitution)+-- It should be "fresh" in the sense that it's not in the in-scope set+-- of the TvSubstEnv; and it should itself then be added to the in-scope+-- set of the TvSubstEnv+--+-- The Int is just a reasonable starting point for generating a unique;+-- it does not necessarily have to be unique itself.+freshEtaId n subst ty+      = (subst', eta_id')+      where+        Scaled mult' ty' = Type.substScaledTyUnchecked subst ty+        eta_id' = uniqAway (substInScopeSet subst) $+                  mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty'+                  -- "OrCoVar" since this can be used to eta-expand+                  -- coercion abstractions+        subst'  = extendSubstInScope subst eta_id'
+ GHC/Core/Opt/CSE.hs view
@@ -0,0 +1,936 @@+{-+(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.Env ( mkInScopeSet, mkInScopeSetList )+import GHC.Types.Id+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 *don't* 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 in CSE]+~~~~~~~~~~~~~~~~~~~~~~~+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) init_env binds)+  where+    init_env  = emptyCSEnv $+                mkInScopeSetList (bindersOfBinds binds)+                -- Put all top-level binders into scope; it is possible to have+                -- forward references.  See Note [Glomming] in GHC.Core.Opt.OccurAnal+                -- Missing this caused #25468++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)       = addNonRecBinder toplevel 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 toplevel 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 toplevel 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))++  | JoinPoint arity <- idJoinPointHood 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)++* There can be a subtle order-dependency, as described in #25526;+  it may matter whether we end up with f=g or g=f.+++---- 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 (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 (all isDeadBinder bndrs1) (ppr alts) $+    Alt DEFAULT [] rhs1 : filtered_alts++  | otherwise+  = alts+  where++    find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])+       -- The (Just alt) is an alt where all fields are dead+    find_bndr_free_alt []+      = (Nothing, [])+    find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)+      | all isDeadBinder 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 check isDeadBinder on field binders in order to collapse into a DEFAULT alt.+But alas, the simplifer often zaps occ-info on field binders in DataAlts when+the case binder is alive; see Note [DataAlt 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 accept that we do not catch cases such as+      case x of c+        A _   -> blah[c]+        B _ _ -> blah[c]+  where the case binder c is alive and no alternative is 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 :: InScopeSet -> CSEnv+emptyCSEnv in_scope+    = CS { cs_map     = emptyCoreMap+         , cs_rec_map = emptyCoreMap+         , cs_subst   = mkEmptySubst in_scope }++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 in CSE] 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++addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var)+-- Don't clone at top level+addNonRecBinder top_lvl cse v+  | isTopLevel top_lvl = (cse,                      v)+  | otherwise          = (cse { cs_subst = sub' }, v')+  where+    (sub', v') = substBndr (cs_subst cse) v++addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id)+-- Don't clone at top level+addRecBinders top_lvl cse vs+  | isTopLevel top_lvl  = (cse,                     vs)+  | otherwise           = (cse { cs_subst = sub' }, vs')+  where+    (sub', vs') = substRecBndrs (cs_subst cse) vs+{-# INLINE addRecBinders #-}
+ GHC/Core/Opt/CallArity.hs view
@@ -0,0 +1,763 @@+--+-- Copyright (c) 2014 Joachim Breitner+--+++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 )+import Data.List.NonEmpty ( NonEmpty (..) )+++{-+%************************************************************************+%*                                                                      *+              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
+ GHC/Core/Opt/CallerCC.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TupleSections #-}++-- | Adds cost-centers to call sites selected with the @-fprof-caller=...@+-- flag.+module GHC.Core.Opt.CallerCC+    ( addCallerCostCentres+    , CallerCcFilter(..)+    , NamePattern(..)+    , parseCallerCcFilter+    ) where++import Data.Maybe++import Control.Applicative+import GHC.Utils.Monad.State.Strict+import Control.Monad++import GHC.Prelude+import GHC.Utils.Outputable as Outputable+import GHC.Driver.DynFlags+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.SrcLoc+import GHC.Types.Var+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Core.Opt.CallerCC.Types+++addCallerCostCentres :: ModGuts -> CoreM ModGuts+addCallerCostCentres guts = do+  dflags <- getDynFlags+  let filters = callerCcFilters dflags+  let env :: Env+      env = Env+        { thisModule = mg_module guts+        , ccState = newCostCentreState+        , countEntries = gopt Opt_ProfCountEntries dflags+        , revParents = []+        , filters = filters+        }+  let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)+                   }+  return guts'++doCoreProgram :: Env -> CoreProgram -> CoreProgram+doCoreProgram env binds = flip evalState newCostCentreState $ do+    mapM (doBind env) binds++doBind :: Env -> CoreBind -> M CoreBind+doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs+doBind env (Rec bs) = Rec <$> mapM doPair bs+  where+    doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs++doExpr :: Env -> CoreExpr -> M CoreExpr+doExpr env e@(Var v)+  | needsCallSiteCostCentre env v = do+    let nameDoc :: SDoc+        nameDoc = withUserStyle alwaysQualify DefaultDepth $+          hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)++        ccName :: CcName+        ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc+    ccIdx <- getCCIndex' ccName+    let count = countEntries env+        span = case revParents env of+          top:_ -> nameSrcSpan $ varName top+          _     -> noSrcSpan+        cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span+        tick :: CoreTickish+        tick = ProfNote cc count True+    pure $ Tick tick e+  | otherwise = pure e+doExpr _env e@(Lit _)       = pure e+doExpr env (f `App` x)      = App <$> doExpr env f <*> doExpr env x+doExpr env (Lam b x)        = Lam b <$> doExpr env x+doExpr env (Let b rhs)      = Let <$> doBind env b <*> doExpr env rhs+doExpr env (Case scrut b ty alts) =+    Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts+  where+    doAlt (Alt con bs rhs)  = Alt con bs <$> doExpr env rhs+doExpr env (Cast expr co)   = Cast <$> doExpr env expr <*> pure co+doExpr env (Tick t e)       = Tick t <$> doExpr env e+doExpr _env e@(Type _)      = pure e+doExpr _env e@(Coercion _)  = pure e++type M = State CostCentreState++getCCIndex' :: FastString -> M CostCentreIndex+getCCIndex' name = state (getCCIndex name)++data Env = Env+  { thisModule  :: Module+  , countEntries :: !Bool+  , ccState     :: CostCentreState+  , revParents  :: [Id]+  , filters     :: [CallerCcFilter]+  }++addParent :: Id -> Env -> Env+addParent i env = env { revParents = i : revParents env }++parents :: Env -> [Id]+parents env = reverse (revParents env)++needsCallSiteCostCentre :: Env -> Id -> Bool+needsCallSiteCostCentre env i =+    any matches (filters env)+  where+    matches :: CallerCcFilter -> Bool+    matches ccf =+        checkModule && checkFunc+      where+        checkModule =+          case ccfModuleName ccf of+            Just modFilt+              | Just iMod <- nameModule_maybe (varName i)+              -> moduleName iMod == modFilt+              | otherwise -> False+            Nothing -> True+        checkFunc =+            occNameMatches (ccfFuncName ccf) (getOccName i)+
+ GHC/Core/Opt/CallerCC/Types.hs view
@@ -0,0 +1,122 @@+module GHC.Core.Opt.CallerCC.Types ( NamePattern(..)+                                   , CallerCcFilter(..)+                                   , occNameMatches+                                   , parseCallerCcFilter+                                   , parseNamePattern+                                   ) where++import Data.Word (Word8)+import Data.Maybe++import Control.Applicative+import Data.Either+import Control.Monad+import qualified Text.ParserCombinators.ReadP as P++import GHC.Prelude+import GHC.Utils.Outputable as Outputable+import GHC.Types.Name hiding (varName)+import GHC.Utils.Panic+import qualified GHC.Utils.Binary as B+import Data.Char+import Control.DeepSeq++import Language.Haskell.Syntax.Module.Name+++data NamePattern+    = PChar Char NamePattern+    | PWildcard NamePattern+    | PEnd++instance Outputable NamePattern where+  ppr (PChar c rest) = char c <> ppr rest+  ppr (PWildcard rest) = char '*' <> ppr rest+  ppr PEnd = Outputable.empty++instance NFData NamePattern where+  rnf (PChar c n) = rnf c `seq` rnf n+  rnf (PWildcard np) = rnf np+  rnf PEnd = ()++instance B.Binary NamePattern where+  get bh = do+    tag <- B.get bh+    case tag :: Word8 of+      0 -> PChar <$> B.get bh <*> B.get bh+      1 -> PWildcard <$> B.get bh+      2 -> pure PEnd+      _ -> panic "Binary(NamePattern): Invalid tag"+  put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y+  put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x+  put_ bh PEnd = B.put_ bh (2 :: Word8)++occNameMatches :: NamePattern -> OccName -> Bool+occNameMatches pat = go pat . occNameString+  where+    go :: NamePattern -> String -> Bool+    go PEnd "" = True+    go (PChar c rest) (d:s)+      = d == c && go rest s+    go (PWildcard rest) s+      = go rest s || go (PWildcard rest) (tail s)+    go _ _  = False++++type Parser = P.ReadP++parseNamePattern :: Parser NamePattern+parseNamePattern = namePattern+  where+    namePattern = star P.<++ wildcard P.<++ char P.<++ end+    star = PChar '*' <$ P.string "\\*" <*> namePattern+    wildcard = do+      void $ P.char '*'+      PWildcard <$> namePattern+    char = PChar <$> P.get <*> namePattern+    end = PEnd <$ P.eof++data CallerCcFilter+    = CallerCcFilter { ccfModuleName  :: Maybe ModuleName+                     , ccfFuncName    :: NamePattern+                     }++instance NFData CallerCcFilter where+  rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n++instance Outputable CallerCcFilter where+  ppr ccf =+    maybe (char '*') ppr (ccfModuleName ccf)+    <> char '.'+    <> ppr (ccfFuncName ccf)++instance B.Binary CallerCcFilter where+  get bh = CallerCcFilter <$> B.get bh <*> B.get bh+  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y++parseCallerCcFilter :: String -> Either String CallerCcFilter+parseCallerCcFilter inp =+    case P.readP_to_S parseCallerCcFilter' inp of+      ((result, ""):_) -> Right result+      _ -> Left $ "parse error on " ++ inp++parseCallerCcFilter' :: Parser CallerCcFilter+parseCallerCcFilter' =+  CallerCcFilter+    <$> moduleFilter+    <*  P.char '.'+    <*> parseNamePattern+  where+    moduleFilter :: Parser (Maybe ModuleName)+    moduleFilter =+      (Just . mkModuleName <$> moduleName)+      <|>+      (Nothing <$ P.char '*')++    moduleName :: Parser String+    moduleName = do+      c <- P.satisfy isUpper+      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')+      rest <- optional $ P.char '.' >> fmap ('.':) moduleName+      return $ c : (cs ++ fromMaybe "" rest)
+ GHC/Core/Opt/ConstantFold.hs view
@@ -0,0 +1,3634 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Conceptually, constant folding should be parameterized with the kind+of target machine to get identical behaviour during compilation time+and runtime. We cheat a little bit here...++ToDo:+   check boundaries before folding, e.g. we can fold the Float addition+   (i1 + i2) only if it results in a valid Float.+-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}++-- | Constant Folder+module GHC.Core.Opt.ConstantFold+   ( primOpRules+   , builtinRules+   , caseRules+   , caseRules2+   )+where++import GHC.Prelude++import GHC.Platform+import GHC.Float++import GHC.Types.Id.Make ( unboxedUnitExpr )+import GHC.Types.Id+import GHC.Types.Literal+import GHC.Types.Name.Occurrence ( occNameFS )+import GHC.Types.Tickish+import GHC.Types.Name ( Name, nameOccName )+import GHC.Types.Basic++import GHC.Core+import GHC.Core.Make+import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )+import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )+import GHC.Core.Utils  ( cheapEqExpr, exprIsHNF+                       , stripTicksTop, stripTicksTopT, mkTicks )+import GHC.Core.Multiplicity+import GHC.Core.Rules.Config+import GHC.Core.Type+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCon+   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize+   , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon )+import GHC.Core.Map.Expr ( eqCoreExpr )++import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )+import GHC.Builtin.PrimOps.Ids (primOpId)+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Names++import GHC.Cmm.MachOp ( FMASign(..) )+import GHC.Cmm.Type ( Width(..) )++import GHC.Data.FastString++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Applicative ( Alternative(..) )+import Control.Monad+import Data.Functor (($>))+import qualified Data.ByteString as BS+import Data.Ratio+import Data.Word+import Data.Maybe (fromMaybe, fromJust)++{-+Note [Constant folding]+~~~~~~~~~~~~~~~~~~~~~~~+primOpRules generates a rewrite rule for each primop+These rules do what is often called "constant folding"+E.g. the rules for +# might say+        4 +# 5 = 9+Well, of course you'd need a lot of rules if you did it+like that, so we use a BuiltinRule instead, so that we+can match in any two literal values.  So the rule is really+more like+        (Lit x) +# (Lit y) = Lit (x+#y)+where the (+#) on the rhs is done at compile time++That is why these rules are built in here.+-}++primOpRules ::  Name -> PrimOp -> Maybe CoreRule+primOpRules nm = \case+   TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]+   DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ]+   DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ]++   -- Int8 operations+   Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))+                                    , identity zeroI8+                                    , addFoldingRules Int8AddOp int8Ops+                                    ]+   Int8SubOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (-))+                                    , rightIdentity zeroI8+                                    , equalArgs $> Lit zeroI8+                                    , subFoldingRules Int8SubOp int8Ops+                                    ]+   Int8MulOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (*))+                                    , zeroElem+                                    , identity oneI8+                                    , mulFoldingRules Int8MulOp int8Ops+                                    ]+   Int8QuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI8+                                    , equalArgs $> Lit oneI8+                                    , quotFoldingRules int8Ops+                                    ]+   Int8RemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI8+                                    , equalArgs $> Lit zeroI8 ]+   Int8NegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int8NegOp ]+   Int8SllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftL)+                                    , rightIdentity zeroI8 ]+   Int8SraOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftR)+                                    , rightIdentity zeroI8 ]+   Int8SrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 $ const $ shiftRightLogical @Word8+                                    , rightIdentity zeroI8 ]++   -- Word8 operations+   Word8AddOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (+))+                                    , identity zeroW8+                                    , addFoldingRules Word8AddOp word8Ops+                                    ]+   Word8SubOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (-))+                                    , rightIdentity zeroW8+                                    , equalArgs $> Lit zeroW8+                                    , subFoldingRules Word8SubOp word8Ops+                                    ]+   Word8MulOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (*))+                                    , identity oneW8+                                    , mulFoldingRules Word8MulOp word8Ops+                                    ]+   Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)+                                    , rightIdentity oneW8+                                    , quotFoldingRules word8Ops+                                    ]+   Word8RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW8+                                    , equalArgs $> Lit zeroW8 ]+   Word8AndOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identity (mkLitWord8 0xFF)+                                    , sameArgIdempotentCommut Word8AndOp+                                    , andFoldingRules word8Ops+                                    ]+   Word8OrOp   -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.))+                                    , idempotent+                                    , identity zeroW8+                                    , sameArgIdempotentCommut Word8OrOp+                                    , orFoldingRules word8Ops+                                    ]+   Word8XorOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor)+                                    , identity zeroW8+                                    , equalArgs $> Lit zeroW8 ]+   Word8NotOp  -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word8NotOp ]+   Word8SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 (const shiftL) ]+   Word8SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord8 $ const $ shiftRightLogical @Word8 ]+++   -- Int16 operations+   Int16AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (+))+                                    , identity zeroI16+                                    , addFoldingRules Int16AddOp int16Ops+                                    ]+   Int16SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (-))+                                    , rightIdentity zeroI16+                                    , equalArgs $> Lit zeroI16+                                    , subFoldingRules Int16SubOp int16Ops+                                    ]+   Int16MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (*))+                                    , zeroElem+                                    , identity oneI16+                                    , mulFoldingRules Int16MulOp int16Ops+                                    ]+   Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI16+                                    , equalArgs $> Lit oneI16+                                    , quotFoldingRules int16Ops+                                    ]+   Int16RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI16+                                    , equalArgs $> Lit zeroI16 ]+   Int16NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int16NegOp ]+   Int16SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftL)+                                    , rightIdentity zeroI16 ]+   Int16SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftR)+                                    , rightIdentity zeroI16 ]+   Int16SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 $ const $ shiftRightLogical @Word16+                                    , rightIdentity zeroI16 ]++   -- Word16 operations+   Word16AddOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (+))+                                    , identity zeroW16+                                    , addFoldingRules Word16AddOp word16Ops+                                    ]+   Word16SubOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (-))+                                    , rightIdentity zeroW16+                                    , equalArgs $> Lit zeroW16+                                    , subFoldingRules Word16SubOp word16Ops+                                    ]+   Word16MulOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (*))+                                    , identity oneW16+                                    , mulFoldingRules Word16MulOp word16Ops+                                    ]+   Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)+                                    , rightIdentity oneW16+                                    , quotFoldingRules word16Ops+                                    ]+   Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW16+                                    , equalArgs $> Lit zeroW16 ]+   Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identity (mkLitWord16 0xFFFF)+                                    , sameArgIdempotentCommut Word16AndOp+                                    , andFoldingRules word16Ops+                                    ]+   Word16OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.))+                                    , idempotent+                                    , identity zeroW16+                                    , sameArgIdempotentCommut Word16OrOp+                                    , orFoldingRules word16Ops+                                    ]+   Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor)+                                    , identity zeroW16+                                    , equalArgs $> Lit zeroW16 ]+   Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word16NotOp ]+   Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 (const shiftL) ]+   Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord16 $ const $ shiftRightLogical @Word16 ]+++   -- Int32 operations+   Int32AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (+))+                                    , identity zeroI32+                                    , addFoldingRules Int32AddOp int32Ops+                                    ]+   Int32SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (-))+                                    , rightIdentity zeroI32+                                    , equalArgs $> Lit zeroI32+                                    , subFoldingRules Int32SubOp int32Ops+                                    ]+   Int32MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (*))+                                    , zeroElem+                                    , identity oneI32+                                    , mulFoldingRules Int32MulOp int32Ops+                                    ]+   Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI32+                                    , equalArgs $> Lit oneI32+                                    , quotFoldingRules int32Ops+                                    ]+   Int32RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI32+                                    , equalArgs $> Lit zeroI32 ]+   Int32NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int32NegOp ]+   Int32SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftL)+                                    , rightIdentity zeroI32 ]+   Int32SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftR)+                                    , rightIdentity zeroI32 ]+   Int32SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 $ const $ shiftRightLogical @Word32+                                    , rightIdentity zeroI32 ]++   -- Word32 operations+   Word32AddOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (+))+                                    , identity zeroW32+                                    , addFoldingRules Word32AddOp word32Ops+                                    ]+   Word32SubOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (-))+                                    , rightIdentity zeroW32+                                    , equalArgs $> Lit zeroW32+                                    , subFoldingRules Word32SubOp word32Ops+                                    ]+   Word32MulOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (*))+                                    , identity oneW32+                                    , mulFoldingRules Word32MulOp word32Ops+                                    ]+   Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)+                                    , rightIdentity oneW32+                                    , quotFoldingRules word32Ops+                                    ]+   Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW32+                                    , equalArgs $> Lit zeroW32 ]+   Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identity (mkLitWord32 0xFFFFFFFF)+                                    , sameArgIdempotentCommut Word32AndOp+                                    , andFoldingRules word32Ops+                                    ]+   Word32OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.))+                                    , idempotent+                                    , identity zeroW32+                                    , sameArgIdempotentCommut Word32OrOp+                                    , orFoldingRules word32Ops+                                    ]+   Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor)+                                    , identity zeroW32+                                    , equalArgs $> Lit zeroW32 ]+   Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word32NotOp ]+   Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 (const shiftL) ]+   Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord32 $ const $ shiftRightLogical @Word32 ]++   -- Int64 operations+   Int64AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+))+                                    , identity zeroI64+                                    , addFoldingRules Int64AddOp int64Ops+                                    ]+   Int64SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-))+                                    , rightIdentity zeroI64+                                    , equalArgs $> Lit zeroI64+                                    , subFoldingRules Int64SubOp int64Ops+                                    ]+   Int64MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*))+                                    , zeroElem+                                    , identity oneI64+                                    , mulFoldingRules Int64MulOp int64Ops+                                    ]+   Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI64+                                    , equalArgs $> Lit oneI64+                                    , quotFoldingRules int64Ops+                                    ]+   Int64RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI64+                                    , equalArgs $> Lit zeroI64 ]+   Int64NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int64NegOp ]+   Int64SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL)+                                    , rightIdentity zeroI64 ]+   Int64SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR)+                                    , rightIdentity zeroI64 ]+   Int64SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64+                                    , rightIdentity zeroI64 ]++   -- Word64 operations+   Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+))+                                    , identity zeroW64+                                    , addFoldingRules Word64AddOp word64Ops+                                    ]+   Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-))+                                    , rightIdentity zeroW64+                                    , equalArgs $> Lit zeroW64+                                    , subFoldingRules Word64SubOp word64Ops+                                    ]+   Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*))+                                    , identity oneW64+                                    , mulFoldingRules Word64MulOp word64Ops+                                    ]+   Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)+                                    , rightIdentity oneW64+                                    , quotFoldingRules word64Ops+                                    ]+   Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW64+                                    , equalArgs $> Lit zeroW64 ]+   Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identity (mkLitWord64 0xFFFFFFFFFFFFFFFF)+                                    , sameArgIdempotentCommut Word64AndOp+                                    , andFoldingRules word64Ops+                                    ]+   Word64OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.))+                                    , idempotent+                                    , identity zeroW64+                                    , sameArgIdempotentCommut Word64OrOp+                                    , orFoldingRules word64Ops+                                    ]+   Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor)+                                    , identity zeroW64+                                    , equalArgs $> Lit zeroW64 ]+   Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word64NotOp ]+   Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ]+   Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ]++   -- Int operations+   IntAddOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))+                                    , identityPlatform zeroi+                                    , addFoldingRules IntAddOp intOps+                                    ]+   IntSubOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))+                                    , rightIdentityPlatform zeroi+                                    , equalArgs >> retLit zeroi+                                    , subFoldingRules IntSubOp intOps+                                    ]+   IntAddCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))+                                    , identityCPlatform zeroi ]+   IntSubCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))+                                    , rightIdentityCPlatform zeroi+                                    , equalArgs >> retLitNoC zeroi ]+   IntMulOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))+                                    , zeroElem+                                    , identityPlatform onei+                                    , mulFoldingRules IntMulOp intOps+                                    ]+   IntMul2Op   -> mkPrimOpRule nm 2 [ do+                                        [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs+                                        platform <- getPlatform+                                        let r = l1 * l2+                                        pure $ mkCoreUnboxedTuple+                                          [ Lit (if platformInIntRange platform r then zeroi platform else onei platform)+                                          , mkIntLitWrap platform (r `shiftR` platformWordSizeInBits platform)+                                          , mkIntLitWrap platform r+                                          ]++                                    , zeroElem >>= \z ->+                                        pure (mkCoreUnboxedTuple [z,z,z])++                                      -- timesInt2# 1# other+                                      -- ~~~>+                                      -- (# 0#, 0# -# (other >># (WORD_SIZE_IN_BITS-1)), other #)+                                      -- The second element is the sign bit+                                      -- repeated to fill a word.+                                    , identityPlatform onei >>= \other -> do+                                        platform <- getPlatform+                                        pure $ mkCoreUnboxedTuple+                                          [ Lit (zeroi platform)+                                          , mkCoreApps (Var (primOpId IntSubOp))+                                              [ Lit (zeroi platform)+                                              , mkCoreApps (Var (primOpId IntSrlOp))+                                                [ other+                                                , mkIntLit platform (fromIntegral (platformWordSizeInBits platform - 1))+                                                ]+                                              ]+                                          , other+                                          ]+                                    ]+   IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)+                                    , leftZero+                                    , rightIdentityPlatform onei+                                    , equalArgs >> retLit onei+                                    , quotFoldingRules intOps+                                    ]+   IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)+                                    , leftZero+                                    , oneLit 1 >> retLit zeroi+                                    , equalArgs >> retLit zeroi ]+   IntAndOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identityPlatform (\p -> mkLitInt p (-1))+                                    , sameArgIdempotentCommut IntAndOp+                                    , andFoldingRules intOps+                                    ]+   IntOrOp     -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zeroi+                                    , sameArgIdempotentCommut IntOrOp+                                    , orFoldingRules intOps+                                    ]+   IntXorOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)+                                    , identityPlatform zeroi+                                    , equalArgs >> retLit zeroi ]+   IntNotOp    -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp IntNotOp ]+   IntNegOp    -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp IntNegOp ]+   IntSllOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftL)+                                    , rightIdentityPlatform zeroi ]+   IntSraOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftR)+                                    , rightIdentityPlatform zeroi ]+   IntSrlOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogicalNative+                                    , rightIdentityPlatform zeroi ]++   -- Word operations+   WordAddOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))+                                    , identityPlatform zerow+                                    , addFoldingRules WordAddOp wordOps+                                    ]+   WordSubOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))+                                    , rightIdentityPlatform zerow+                                    , equalArgs >> retLit zerow+                                    , subFoldingRules WordSubOp wordOps+                                    ]+   WordAddCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))+                                    , identityCPlatform zerow ]+   WordSubCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))+                                    , rightIdentityCPlatform zerow+                                    , equalArgs >> retLitNoC zerow ]+   WordMulOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))+                                    , identityPlatform onew+                                    , mulFoldingRules WordMulOp wordOps+                                    ]+   WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)+                                    , rightIdentityPlatform onew+                                    , quotFoldingRules wordOps+                                    ]+   WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)+                                    , leftZero+                                    , oneLit 1 >> retLit zerow+                                    , equalArgs >> retLit zerow ]+   WordAndOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , identityPlatform (\p -> mkLitWord p (platformMaxWord p))+                                    , sameArgIdempotentCommut WordAndOp+                                    , andFoldingRules wordOps+                                    ]+   WordOrOp    -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zerow+                                    , sameArgIdempotentCommut WordOrOp+                                    , orFoldingRules wordOps+                                    ]+   WordXorOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)+                                    , identityPlatform zerow+                                    , equalArgs >> retLit zerow ]+   WordNotOp   -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp WordNotOp ]+   WordSllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]+   WordSrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ]++   PopCnt8Op   -> mkPrimOpRule nm 1 [ pop_count @Word8  ]+   PopCnt16Op  -> mkPrimOpRule nm 1 [ pop_count @Word16 ]+   PopCnt32Op  -> mkPrimOpRule nm 1 [ pop_count @Word32 ]+   PopCnt64Op  -> mkPrimOpRule nm 1 [ pop_count @Word64 ]+   PopCntOp    -> mkPrimOpRule nm 1 [ getWordSize >>= \case+                                        PW4 -> pop_count @Word32+                                        PW8 -> pop_count @Word64+                                    ]++   Ctz8Op      -> mkPrimOpRule nm 1 [ ctz @Word8  ]+   Ctz16Op     -> mkPrimOpRule nm 1 [ ctz @Word16 ]+   Ctz32Op     -> mkPrimOpRule nm 1 [ ctz @Word32 ]+   Ctz64Op     -> mkPrimOpRule nm 1 [ ctz @Word64 ]+   CtzOp       -> mkPrimOpRule nm 1 [ getWordSize >>= \case+                                        PW4 -> ctz @Word32+                                        PW8 -> ctz @Word64+                                    ]++   Clz8Op      -> mkPrimOpRule nm 1 [ clz @Word8  ]+   Clz16Op     -> mkPrimOpRule nm 1 [ clz @Word16 ]+   Clz32Op     -> mkPrimOpRule nm 1 [ clz @Word32 ]+   Clz64Op     -> mkPrimOpRule nm 1 [ clz @Word64 ]+   ClzOp       -> mkPrimOpRule nm 1 [ getWordSize >>= \case+                                        PW4 -> clz @Word32+                                        PW8 -> clz @Word64+                                    ]++   -- coercions++   Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform convertToIntLit ]+   IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit+                                       , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]+   IntToInt16Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit+                                       , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]+   IntToInt32Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit+                                       , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]+   IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]++   Word8ToWordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit+                                       , extendNarrowPassthrough WordToWord8Op 0xFF+                                       ]+   Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit+                                       , extendNarrowPassthrough WordToWord16Op 0xFFFF+                                       ]+   Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit+                                       , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF+                                       ]+   Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform convertToWordLit ]++   WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit+                                       , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]+   WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit+                                       , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]+   WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit+                                       , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]+   WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]++   Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8) ]+   Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8) ]+   Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16) ]+   Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16) ]+   Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32) ]+   Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32) ]+   Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64) ]+   Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64) ]++   WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt) ]+   IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord) ]++   Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd IntAndOp Narrow8IntOp 8 ]+   Narrow16IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt16)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd IntAndOp Narrow16IntOp 16 ]+   Narrow32IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt32)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , subsumedByPrimOp Narrow32IntOp+                                       , removeOp32+                                       , narrowSubsumesAnd IntAndOp Narrow32IntOp 32 ]+   Narrow8WordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord8)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd WordAndOp Narrow8WordOp 8 ]+   Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord16)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd WordAndOp Narrow16WordOp 16 ]+   Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord32)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , subsumedByPrimOp Narrow32WordOp+                                       , removeOp32+                                       , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ]++   CastWord64ToDoubleOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitNumber _ n+             | v <- castWord64ToDouble (fromInteger n)+             -- we can't represent those float literals in Core until #18897 is fixed+             , not (isNaN v || isInfinite v || isNegativeZero v)+             -> Just (mkDoubleLitDouble v)+         _   -> Nothing+      ]++   CastWord32ToFloatOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitNumber _ n+              | v <- castWord32ToFloat (fromInteger n)+              -- we can't represent those float literals in Core until #18897 is fixed+              , not (isNaN v || isInfinite v || isNegativeZero v)+              -> Just (mkFloatLitFloat v)+          _   -> Nothing+      ]++   CastDoubleToWord64Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitDouble n -> Just (mkWord64LitWord64 (castDoubleToWord64 (fromRational n)))+         _           -> Nothing+      ]++   CastFloatToWord32Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitFloat n -> Just (mkWord32LitWord32 (castFloatToWord32 (fromRational n)))+          _          -> Nothing+      ]++   OrdOp          -> mkPrimOpRule nm 1 [ liftLit charToIntLit+                                       , semiInversePrimOp ChrOp ]+   ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs+                                            guard (litFitsInChar lit)+                                            liftLit intToCharLit+                                       , semiInversePrimOp OrdOp ]+   FloatToIntOp    -> mkPrimOpRule nm 1 [ liftLit floatToIntLit ]+   IntToFloatOp    -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ]+   DoubleToIntOp   -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ]+   IntToDoubleOp   -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ]+   -- SUP: Not sure what the standard says about precision in the following 2 cases+   FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ]+   DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]++   -- Float+   FloatAddOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))+                                          , identity zerof ]+   FloatSubOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))+                                          , rightIdentity zerof ]+   FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))+                                          , identity onef+                                          , strengthReduction twof FloatAddOp  ]+   FloatFMAdd        -> mkPrimOpRule nm 3 (fmaRules FMAdd  W32)+   FloatFMSub        -> mkPrimOpRule nm 3 (fmaRules FMSub  W32)+   FloatFNMAdd       -> mkPrimOpRule nm 3 (fmaRules FNMAdd W32)+   FloatFNMSub       -> mkPrimOpRule nm 3 (fmaRules FNMSub W32)++             -- zeroElem zerof doesn't hold because of NaN+   FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))+                                          , rightIdentity onef ]+   FloatNegOp        -> mkPrimOpRule nm 1 [ unaryLit negOp+                                          , semiInversePrimOp FloatNegOp ]+   FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]++   -- Double+   DoubleAddOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))+                                             , identity zerod ]+   DoubleSubOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))+                                             , rightIdentity zerod ]+   DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))+                                             , identity oned+                                             , strengthReduction twod DoubleAddOp  ]+   DoubleFMAdd          -> mkPrimOpRule nm 3 (fmaRules FMAdd  W64)+   DoubleFMSub          -> mkPrimOpRule nm 3 (fmaRules FMSub  W64)+   DoubleFNMAdd         -> mkPrimOpRule nm 3 (fmaRules FNMAdd W64)+   DoubleFNMSub         -> mkPrimOpRule nm 3 (fmaRules FNMSub W64)+              -- zeroElem zerod doesn't hold because of NaN+   DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))+                                             , rightIdentity oned ]+   DoubleNegOp          -> mkPrimOpRule nm 1 [ unaryLit negOp+                                             , semiInversePrimOp DoubleNegOp ]+   DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]++   -- Relational operators, equality++   Int8EqOp   -> mkRelOpRule nm (==) [ litEq True ]+   Int8NeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   Int16EqOp  -> mkRelOpRule nm (==) [ litEq True ]+   Int16NeOp  -> mkRelOpRule nm (/=) [ litEq False ]++   Int32EqOp  -> mkRelOpRule nm (==) [ litEq True ]+   Int32NeOp  -> mkRelOpRule nm (/=) [ litEq False ]++   Int64EqOp  -> mkRelOpRule nm (==) [ litEq True ]+   Int64NeOp  -> mkRelOpRule nm (/=) [ litEq False ]++   IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]+   IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]++   Word8EqOp  -> mkRelOpRule nm (==) [ litEq True ]+   Word8NeOp  -> mkRelOpRule nm (/=) [ litEq False ]++   Word16EqOp -> mkRelOpRule nm (==) [ litEq True ]+   Word16NeOp -> mkRelOpRule nm (/=) [ litEq False ]++   Word32EqOp -> mkRelOpRule nm (==) [ litEq True ]+   Word32NeOp -> mkRelOpRule nm (/=) [ litEq False ]++   Word64EqOp -> mkRelOpRule nm (==) [ litEq True ]+   Word64NeOp -> mkRelOpRule nm (/=) [ litEq False ]++   WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   FloatEqOp  -> mkFloatingRelOpRule nm (==)+   FloatNeOp  -> mkFloatingRelOpRule nm (/=)++   DoubleEqOp -> mkFloatingRelOpRule nm (==)+   DoubleNeOp -> mkFloatingRelOpRule nm (/=)++   -- Relational operators, ordering++   Int8GtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Int8GeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Int8LeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Int8LtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Int16GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Int16GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Int16LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Int16LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Int32GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Int32GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Int32LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Int32LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Int64GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Int64GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Int64LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Int64LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Word8GtOp  -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Word8GeOp  -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Word8LeOp  -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Word8LtOp  -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Word16GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Word16GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Word16LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Word16LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Word32GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Word32GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Word32LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Word32LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   Word64GtOp -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   Word64GeOp -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   Word64LeOp -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   Word64LtOp -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   FloatGtOp  -> mkFloatingRelOpRule nm (>)+   FloatGeOp  -> mkFloatingRelOpRule nm (>=)+   FloatLeOp  -> mkFloatingRelOpRule nm (<=)+   FloatLtOp  -> mkFloatingRelOpRule nm (<)++   DoubleGtOp -> mkFloatingRelOpRule nm (>)+   DoubleGeOp -> mkFloatingRelOpRule nm (>=)+   DoubleLeOp -> mkFloatingRelOpRule nm (<=)+   DoubleLtOp -> mkFloatingRelOpRule nm (<)++   -- Misc++   AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]++   SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]++   _          -> Nothing++{-+************************************************************************+*                                                                      *+\subsection{Doing the business}+*                                                                      *+************************************************************************+-}++-- useful shorthands+mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule+mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)++mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+            -> [RuleM CoreExpr] -> Maybe CoreRule+mkRelOpRule nm cmp extra+  = mkPrimOpRule nm 2 $+    binaryCmpLit cmp : equal_rule : extra+  where+        -- x `cmp` x does not depend on x, so+        -- compute it for the arbitrary value 'True'+        -- and use that result+    equal_rule = do { equalArgs+                    ; platform <- getPlatform+                    ; return (if cmp True True+                              then trueValInt  platform+                              else falseValInt platform) }++{- Note [Rules for floating-point comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need different rules for floating-point values because for floats+it is not true that x = x (for NaNs); so we do not want the equal_rule+rule that mkRelOpRule uses.++Note also that, in the case of equality/inequality, we do /not/+want to switch to a case-expression.  For example, we do not want+to convert+   case (eqFloat# x 3.8#) of+     True -> this+     False -> that+to+  case x of+    3.8#::Float# -> this+    _            -> that+See #9238.  Reason: comparing floating-point values for equality+delicate, and we don't want to implement that delicacy in the code for+case expressions.  So we make it an invariant of Core that a case+expression never scrutinises a Float# or Double#.++This transformation is what the litEq rule does;+see Note [The litEq rule: converting equality to case].+So we /refrain/ from using litEq for mkFloatingRelOpRule.+-}++mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+                    -> Maybe CoreRule+-- See Note [Rules for floating-point comparisons]+mkFloatingRelOpRule nm cmp+  = mkPrimOpRule nm 2 [binaryCmpLit cmp]++-- common constants+zeroi, onei, zerow, onew :: Platform -> Literal+zeroi platform = mkLitInt  platform 0+onei  platform = mkLitInt  platform 1+zerow platform = mkLitWord platform 0+onew  platform = mkLitWord platform 1++zeroI8, oneI8, zeroW8, oneW8 :: Literal+zeroI8 = mkLitInt8  0+oneI8  = mkLitInt8  1+zeroW8 = mkLitWord8 0+oneW8  = mkLitWord8 1++zeroI16, oneI16, zeroW16, oneW16 :: Literal+zeroI16 = mkLitInt16  0+oneI16  = mkLitInt16  1+zeroW16 = mkLitWord16 0+oneW16  = mkLitWord16 1++zeroI32, oneI32, zeroW32, oneW32 :: Literal+zeroI32 = mkLitInt32  0+oneI32  = mkLitInt32  1+zeroW32 = mkLitWord32 0+oneW32  = mkLitWord32 1++zeroI64, oneI64, zeroW64, oneW64 :: Literal+zeroI64 = mkLitInt64  0+oneI64  = mkLitInt64  1+zeroW64 = mkLitWord64 0+oneW64  = mkLitWord64 1++zerof, onef, twof, zerod, oned, twod :: Literal+zerof = mkLitFloat 0.0+onef  = mkLitFloat 1.0+twof  = mkLitFloat 2.0+zerod = mkLitDouble 0.0+oned  = mkLitDouble 1.0+twod  = mkLitDouble 2.0++cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)+      -> Literal -> Literal -> Maybe CoreExpr+cmpOp platform cmp = go+  where+    done True  = Just $ trueValInt  platform+    done False = Just $ falseValInt platform++    -- These compares are at different types+    go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)+    go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)+    go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)+    go (LitNumber nt1 i1) (LitNumber nt2 i2)+      | nt1 /= nt2 = Nothing+      | otherwise  = done (i1 `cmp` i2)+    go _               _               = Nothing++--------------------------++negOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Negate+negOp env = \case+   (LitFloat 0.0)  -> Nothing  -- can't represent -0.0 as a Rational+   (LitFloat f)    -> Just (mkFloatVal env (-f))+   (LitDouble 0.0) -> Nothing+   (LitDouble d)   -> Just (mkDoubleVal env (-d))+   (LitNumber nt i)+      | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i)))+   _ -> Nothing++complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement+complementOp env (LitNumber nt i) =+   Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i)))+complementOp _      _            = Nothing++int8Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int8Op2 op _ (LitNumber LitNumInt8 i1) (LitNumber LitNumInt8 i2) =+  int8Result (fromInteger i1 `op` fromInteger i2)+int8Op2 _ _ _ _ = Nothing++int16Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int16Op2 op _ (LitNumber LitNumInt16 i1) (LitNumber LitNumInt16 i2) =+  int16Result (fromInteger i1 `op` fromInteger i2)+int16Op2 _ _ _ _ = Nothing++int32Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) =+  int32Result (fromInteger i1 `op` fromInteger i2)+int32Op2 _ _ _ _ = Nothing++int64Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) =+  int64Result (fromInteger i1 `op` fromInteger i2)+int64Op2 _ _ _ _ = Nothing++intOp2 :: (Integral a, Integral b)+       => (a -> b -> Integer)+       -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2 = intOp2' . const++intOp2' :: (Integral a, Integral b)+        => (RuleOpts -> a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =+  let o = op env+  in  intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)+intOp2' _ _ _ _ = Nothing++intOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =+  intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)+intOpC2 _ _ _ _ = Nothing++shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer+shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: t)++-- | Shift right, putting zeros in rather than sign-propagating as+-- 'Bits.shiftR' would do. Do this by converting to the appropriate Word+-- and back. Obviously this won't work for too-big values, but its ok as+-- we use it here.+shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer+shiftRightLogicalNative platform =+    case platformWordSize platform of+      PW4 -> shiftRightLogical @Word32+      PW8 -> shiftRightLogical @Word64++--------------------------+retLit :: (Platform -> Literal) -> RuleM CoreExpr+retLit l = do platform <- getPlatform+              return $ Lit $ l platform++retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr+retLitNoC l = do platform <- getPlatform+                 let lit = l platform+                 return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)]++word8Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) =+  word8Result (fromInteger i1 `op` fromInteger i2)+word8Op2 _ _ _ _ = Nothing++word16Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) =+  word16Result (fromInteger i1 `op` fromInteger i2)+word16Op2 _ _ _ _ = Nothing++word32Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) =+  word32Result (fromInteger i1 `op` fromInteger i2)+word32Op2 _ _ _ _ = Nothing++word64Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) =+  word64Result (fromInteger i1 `op` fromInteger i2)+word64Op2 _ _ _ _ = Nothing++wordOp2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2)+    = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOp2 _ _ _ _ = Nothing++wordOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =+  wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOpC2 _ _ _ _ = Nothing++shiftRule :: LitNumType+          -> (Platform -> Integer -> Int -> Integer)+          -> RuleM CoreExpr+-- Shifts take an Int; hence third arg of op is Int+-- Used for shift primops+--    IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int#+--    SllOp, SrlOp                 :: Word# -> Int# -> Word#+shiftRule lit_num_ty shift_op = do+  platform <- getPlatform+  [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs++  bit_size <- case litNumBitSize platform lit_num_ty of+   Nothing -> mzero+   Just bs -> pure (toInteger bs)++  case e1 of+    _ | shift_len == 0 -> pure e1++      -- See Note [Guarding against silly shifts]+    _ | shift_len < 0 || shift_len >= bit_size+      -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0+           -- Be sure to use lit_num_ty here, so we get a correctly typed zero.+           -- See #18589++    Lit (LitNumber nt x)+       | 0 < shift_len && shift_len <= bit_size+       -> assert (nt == lit_num_ty) $+          let op = shift_op platform+              -- Do the shift at type Integer, but shift length is Int.+              -- Using host's Int is ok even if target's Int has a different size+              -- because we test that shift_len <= bit_size (which is at most 64)+              y  = x `op` fromInteger shift_len+          in pure $ Lit $ mkLitNumberWrap platform nt y++    _ -> mzero++--------------------------+floatOp2 :: (Rational -> Rational -> Rational)+         -> RuleOpts -> Literal -> Literal+         -> Maybe (Expr CoreBndr)+floatOp2 op env (LitFloat f1) (LitFloat f2)+  = Just (mkFloatVal env (f1 `op` f2))+floatOp2 _ _ _ _ = Nothing++--------------------------+floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr+floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))+  = Just $ mkCoreUnboxedTuple [ mkIntVal (roPlatform env) (toInteger m)+                              , mkIntVal (roPlatform env) (toInteger e) ]+floatDecodeOp _   _+  = Nothing++--------------------------+doubleOp2 :: (Rational -> Rational -> Rational)+          -> RuleOpts -> Literal -> Literal+          -> Maybe (Expr CoreBndr)+doubleOp2 op env (LitDouble f1) (LitDouble f2)+  = Just (mkDoubleVal env (f1 `op` f2))+doubleOp2 _ _ _ _ = Nothing++--------------------------+doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr+doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))+  = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m))+                              , mkIntVal platform (toInteger e) ]+  where+    platform = roPlatform env+doubleDecodeOp _   _+  = Nothing++--------------------------++-- | Constant folding rules for fused multiply-add operations.+fmaRules :: FMASign -> Width -> [RuleM CoreExpr]+fmaRules signs width =+     [ fmaLit signs width+     , fmaZero_z signs width+     , fmaOne signs width ]++-- | Compute @a * b + c@ when @a@, @b@, @c@ are all literals.+fmaLit :: FMASign -> Width -> RuleM CoreExpr+fmaLit signs width = do+  env <- getRuleOpts+  [Lit l1, Lit l2, Lit l3] <- getArgs+  liftMaybe $+    op env+      (convFloating env l1)+      (convFloating env l2)+      (convFloating env l3)++  where+    op env l1 l2 l3 =+      case width of+        W32+          | LitFloat x <- l1+          , LitFloat y <- l2+          , LitFloat z <- l3+          -> Just $ mkFloatVal env $+            case signs of+              FMAdd  -> x * y + z+              FMSub  -> x * y - z+              FNMAdd -> negate ( x * y ) + z+              FNMSub -> negate ( x * y ) - z+        W64+          | LitDouble x <- l1+          , LitDouble y <- l2+          , LitDouble z <- l3+          -> Just $ mkDoubleVal env $+            case signs of+              FMAdd  -> x * y + z+              FMSub  -> x * y - z+              FNMAdd -> negate ( x * y ) + z+              FNMSub -> negate ( x * y ) - z+        _ -> Nothing++-- | @x * y + 0 = x * y@.+fmaZero_z :: FMASign -> Width -> RuleM CoreExpr+fmaZero_z signs width = do+  [x, y, Lit z] <- getArgs+  let+    -- TODO: we should additionally check the sign of z.+    -- FMAdd, FNMAdd: should be -0.0.+    -- FMSub, FNMSub: should be +0.0.+    ok =+      case width of+        W32+          | LitFloat 0 <- z+          -> True+        W64+          | LitDouble 0 <- z+          -> True+        _ -> False+    neg = case width of+      W32 ->  FloatNegOp+      W64 -> DoubleNegOp+      _   -> panic "fmaZero_xy: not Float# or Double#"+    mul = case width of+      W32 ->  FloatMulOp+      W64 -> DoubleMulOp+      _   -> panic "fmaZero_z: not Float# or Double#"+  if ok+  then return $ case signs of+    FMAdd  -> Var (primOpId mul) `App` x `App` y+    FMSub  -> Var (primOpId mul) `App` x `App` y+    FNMAdd -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y)+    FNMSub -> Var (primOpId neg) `App` (Var (primOpId mul) `App` x `App` y)+  else mzero++-- | @±1 * y + z ==> z ± y@ and @x * ±1 + z ==> z ± x@.+fmaOne :: FMASign -> Width -> RuleM CoreExpr+fmaOne signs width = do+  [x, y, z] <- getArgs+  let+    posNegOne_maybe :: Rational -> Maybe Bool+    posNegOne_maybe i+      | i == 1+      = Just False+      | i == -1+      = Just True+      | otherwise+      = Nothing+    ok =+      case width of+        W32+          | Lit (LitFloat i) <- x+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, y)+          | Lit (LitFloat i) <- y+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, x)+        W64+          | Lit (LitDouble i) <- x+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, y)+          | Lit (LitDouble i) <- y+          , Just sgn <- posNegOne_maybe i+          -> Just (sgn, x)+        _ -> Nothing+    neg = case width of+      W32 ->  FloatNegOp+      W64 -> DoubleNegOp+      _   -> panic "fmaOne: not Float# or Double#"+    add = case width of+      W32 ->  FloatAddOp+      W64 -> DoubleAddOp+      _   -> panic "fmaOne: not Float# or Double#"+    sub = case width of+      W32 ->  FloatSubOp+      W64 -> DoubleSubOp+      _   -> panic "fmaOne: not Float# or Double#"+  case ok of+    Nothing  -> mzero+    Just (sgn, t) -> return $+      if -- t + z+         |  ( signs ==  FMAdd && sgn == False )+         || ( signs == FNMAdd && sgn == True  )+         -> Var (primOpId add) `App` t `App` z+         -- - t + z+         |  signs ==  FMAdd+         || signs == FNMAdd+         -> Var (primOpId sub) `App` z `App` t+         -- t - z+         |  ( signs ==  FMSub && sgn == False )+         || ( signs == FNMSub && sgn == True  )+         -> Var (primOpId sub) `App` t `App` z+         -- - t - z+         |  signs ==  FMSub+         || signs == FNMSub+         -> Var (primOpId neg) `App` (Var (primOpId add) `App` t `App` z)+         | otherwise+         -> pprPanic "fmaOne: non-exhaustive pattern match" $+              vcat [ text "signs:" <+> text (show signs)+                   , text "sign:" <+> ppr sgn ]++--------------------------+{- Note [The litEq rule: converting equality to case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This stuff turns+     n ==# 3#+into+     case n of+       3# -> True+       m  -> False++This is a Good Thing, because it allows case-of case things+to happen, and case-default absorption to happen.  For+example:++     if (n ==# 3#) || (n ==# 4#) then e1 else e2+will transform to+     case n of+       3# -> e1+       4# -> e1+       m  -> e2+(modulo the usual precautions to avoid duplicating e1)+-}++litEq :: Bool  -- True <=> equality, False <=> inequality+      -> RuleM CoreExpr+litEq is_eq = msum+  [ do [Lit lit, expr] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr+  , do [expr, Lit lit] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr ]+  where+    do_lit_eq platform lit expr = do+      guard (not (litIsLifted lit))+      return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy+                    [ Alt DEFAULT      [] val_if_neq+                    , Alt (LitAlt lit) [] val_if_eq])+      where+        val_if_eq  | is_eq     = trueValInt  platform+                   | otherwise = falseValInt platform+        val_if_neq | is_eq     = falseValInt platform+                   | otherwise = trueValInt  platform+++-- | Check if there is comparison with minBound or maxBound, that is+-- always true or false. For instance, an Int cannot be smaller than its+-- minBound, so we can replace such comparison with False.+boundsCmp :: Comparison -> RuleM CoreExpr+boundsCmp op = do+  platform <- getPlatform+  [a, b] <- getArgs+  liftMaybe $ mkRuleFn platform op a b++data Comparison = Gt | Ge | Lt | Le++mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr+mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn _ _ _ _                                           = Nothing++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int8Result :: Integer -> Maybe CoreExpr+int8Result result = Just (int8Result' result)++int8Result' :: Integer -> CoreExpr+int8Result' result = Lit (mkLitInt8Wrap result)++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int16Result :: Integer -> Maybe CoreExpr+int16Result result = Just (int16Result' result)++int16Result' :: Integer -> CoreExpr+int16Result' result = Lit (mkLitInt16Wrap result)++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int32Result :: Integer -> Maybe CoreExpr+int32Result result = Just (int32Result' result)++int32Result' :: Integer -> CoreExpr+int32Result' result = Lit (mkLitInt32Wrap result)++intResult :: Platform -> Integer -> Maybe CoreExpr+intResult platform result = Just (intResult' platform result)++intResult' :: Platform -> Integer -> CoreExpr+intResult' platform result = Lit (mkLitIntWrap platform result)++-- | Create an unboxed pair of an Int literal expression, ensuring the given+-- Integer is in the target Int range and the corresponding overflow flag+-- (@0#@/@1#@) if it wasn't.+intCResult :: Platform -> Integer -> Maybe CoreExpr+intCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c])+  where+    (lit, b) = mkLitIntWrapC platform result+    c = if b then onei platform else zeroi platform++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word8Result :: Integer -> Maybe CoreExpr+word8Result result = Just (word8Result' result)++word8Result' :: Integer -> CoreExpr+word8Result' result = Lit (mkLitWord8Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word16Result :: Integer -> Maybe CoreExpr+word16Result result = Just (word16Result' result)++word16Result' :: Integer -> CoreExpr+word16Result' result = Lit (mkLitWord16Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word32Result :: Integer -> Maybe CoreExpr+word32Result result = Just (word32Result' result)++word32Result' :: Integer -> CoreExpr+word32Result' result = Lit (mkLitWord32Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+wordResult :: Platform -> Integer -> Maybe CoreExpr+wordResult platform result = Just (wordResult' platform result)++wordResult' :: Platform -> Integer -> CoreExpr+wordResult' platform result = Lit (mkLitWordWrap platform result)++-- | Create an unboxed pair of a Word literal expression, ensuring the given+-- Integer is in the target Word range and the corresponding carry flag+-- (@0#@/@1#@) if it wasn't.+wordCResult :: Platform -> Integer -> Maybe CoreExpr+wordCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c])+  where+    (lit, b) = mkLitWordWrapC platform result+    c = if b then onei platform else zeroi platform++int64Result :: Integer -> Maybe CoreExpr+int64Result result = Just (int64Result' result)++int64Result' :: Integer -> CoreExpr+int64Result' result = Lit (mkLitInt64Wrap result)++word64Result :: Integer -> Maybe CoreExpr+word64Result result = Just (word64Result' result)++word64Result' :: Integer -> CoreExpr+word64Result' result = Lit (mkLitWord64Wrap result)+++-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'.+semiInversePrimOp :: PrimOp -> RuleM CoreExpr+semiInversePrimOp primop = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId primop primop_id+  return e++subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr+this `subsumesPrimOp` that = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId that primop_id+  return (Var (primOpId this) `App` e)++subsumedByPrimOp :: PrimOp -> RuleM CoreExpr+subsumedByPrimOp primop = do+  [e@(Var primop_id `App` _)] <- getArgs+  matchPrimOpId primop primop_id+  return e++-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`+extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr+extendNarrowPassthrough narrow_primop n = do+  [Var primop_id `App` x] <- getArgs+  matchPrimOpId narrow_primop primop_id+  return (Var (primOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))++-- | narrow subsumes bitwise `and` with full mask (cf #16402):+--+--       narrowN (x .&. m)+--       m .&. (2^N-1) = 2^N-1+--       ==> narrowN x+--+-- e.g.  narrow16 (x .&. 0xFFFF)+--       ==> narrow16 x+--+narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr+narrowSubsumesAnd and_primop narrw n = do+  [Var primop_id `App` x `App` y] <- getArgs+  matchPrimOpId and_primop primop_id+  let mask = bit n -1+      g v (Lit (LitNumber _ m)) = do+         guard (m .&. mask == mask)+         return (Var (primOpId narrw) `App` v)+      g _ _ = mzero+  g x y <|> g y x++idempotent :: RuleM CoreExpr+idempotent = do [e1, e2] <- getArgs+                guard $ cheapEqExpr e1 e2+                return e1++-- | Match+--       (op (op v e) e)+--    or (op e (op v e))+--    or (op (op e v) e)+--    or (op e (op e v))+--  and return the innermost (op v e) or (op e v).+sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr+sameArgIdempotentCommut op = do+  [a,b] <- getArgs+  case (a,b) of+    (is_binop op -> Just (e1,e2), e3)+      | cheapEqExpr e2 e3 -> return a+      | cheapEqExpr e1 e3 -> return a+    (e3, is_binop op -> Just (e1,e2))+      | cheapEqExpr e2 e3 -> return b+      | cheapEqExpr e1 e3 -> return b+    _ -> mzero++{-+Note [Guarding against silly shifts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  import Data.Bits( (.|.), shiftL )+  chunkToBitmap :: [Bool] -> Word32+  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]++This optimises to:+Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->+    case w1_sCT of _ {+      [] -> 0##;+      : x_aAW xs_aAX ->+        case x_aAW of _ {+          GHC.Types.False ->+            case w_sCS of wild2_Xh {+              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;+              9223372036854775807 -> 0## };+          GHC.Types.True ->+            case GHC.Prim.>=# w_sCS 64 of _ {+              GHC.Types.False ->+                case w_sCS of wild3_Xh {+                  __DEFAULT ->+                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->+                      GHC.Prim.or# (GHC.Prim.narrow32Word#+                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))+                                   ww_sCW+                     };+                  9223372036854775807 ->+                    GHC.Prim.narrow32Word#+!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)+                };+              GHC.Types.True ->+                case w_sCS of wild3_Xh {+                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;+                  9223372036854775807 -> 0##+                } } } }++Note the massive shift on line "!!!!".  It can't happen, because we've checked+that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!+Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we+can't constant fold it, but if it gets to the assembler we get+     Error: operand type mismatch for `shl'++So the best thing to do is to rewrite the shift with a call to error,+when the second arg is large. However, in general we cannot do this; consider+this case++    let x = I# (uncheckedIShiftL# n 80)+    in ...++Here x contains an invalid shift and consequently we would like to rewrite it+as follows:++    let x = I# (error "invalid shift")+    in ...++This was originally done in the fix to #16449 but this breaks the+let-can-float invariant (see Note [Core let-can-float invariant] in+GHC.Core) as noted in #16742.  For the reasons discussed under+"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps)+there is no safe way to rewrite the argument of I# such that it bottoms.++Consequently we instead take advantage of the fact that the result of a+large shift is unspecified (see associated documentation in primops.txt.pp)+and transform the invalid shift into an "obviously incorrect" value.++There are two cases:++- Shifting fixed-width things: the primops IntSll, Sll, etc+  These are handled by shiftRule.++  We are happy to shift by any amount up to wordSize but no more.++- Shifting Bignums (Integer, Natural): these are handled by bignum_shift.++  Here we could in principle shift by any amount, but we arbitrary+  limit the shift to 4 bits; in particular we do not want shift by a+  huge amount, which can happen in code like that above.++The two cases are more different in their code paths that is comfortable,+but that is only a historical accident.+++************************************************************************+*                                                                      *+\subsection{Vaguely generic functions}+*                                                                      *+************************************************************************+-}++mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule+-- Gives the Rule the same name as the primop itself+mkBasicRule op_name n_args rm+  = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),+                  ru_fn    = op_name,+                  ru_nargs = n_args,+                  ru_try   = runRuleM rm }++newtype RuleM r = RuleM+  { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }+  deriving (Functor)++instance Applicative RuleM where+    pure x = RuleM $ \_ _ _ _ -> Just x+    (<*>) = ap++instance Monad RuleM where+  RuleM f >>= g+    = RuleM $ \env iu fn args ->+              case f env iu fn args of+                Nothing -> Nothing+                Just r  -> runRuleM (g r) env iu fn args++instance MonadFail RuleM where+    fail _ = mzero++instance Alternative RuleM where+  empty = RuleM $ \_ _ _ _ -> Nothing+  RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->+    f1 env iu fn args <|> f2 env iu fn args++instance MonadPlus RuleM++getPlatform :: RuleM Platform+getPlatform = roPlatform <$> getRuleOpts++getWordSize :: RuleM PlatformWordSize+getWordSize = platformWordSize <$> getPlatform++getRuleOpts :: RuleM RuleOpts+getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts++liftMaybe :: Maybe a -> RuleM a+liftMaybe Nothing = mzero+liftMaybe (Just x) = return x++liftLit :: (Literal -> Literal) -> RuleM CoreExpr+liftLit f = liftLitPlatform (const f)++liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr+liftLitPlatform f = do+  platform <- getPlatform+  [Lit lit] <- getArgs+  return $ Lit (f platform lit)++removeOp32 :: RuleM CoreExpr+removeOp32 = do+  platform <- getPlatform+  case platformWordSize platform of+    PW4 -> do+      [e] <- getArgs+      return e+    PW8 ->+      mzero++getArgs :: RuleM [CoreExpr]+getArgs = RuleM $ \_ _ _ args -> Just args++getInScopeEnv :: RuleM InScopeEnv+getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu++getFunction :: RuleM Id+getFunction = RuleM $ \_ _ fn _ -> Just fn++isLiteral :: CoreExpr -> RuleM Literal+isLiteral e = do+    env <- getInScopeEnv+    case exprIsLiteral_maybe env e of+        Nothing -> mzero+        Just l  -> pure l++-- | Match BigNat#, Integer and Natural literals+isBignumLiteral :: CoreExpr -> RuleM Integer+isBignumLiteral e = isNumberLiteral e <|> isIntegerLiteral e <|> isNaturalLiteral e++-- | Match numeric literals+isNumberLiteral :: CoreExpr -> RuleM Integer+isNumberLiteral e = isLiteral e >>= \case+  LitNumber _ x -> pure x+  _             -> mzero++-- | Match the application of a DataCon to a numeric literal.+--+-- Can be used to match e.g.:+--  IS 123#+--  IP bigNatLiteral+--  W# 123##+isLitNumConApp :: CoreExpr -> RuleM (DataCon,Integer)+isLitNumConApp e = do+  env <- getInScopeEnv+  case exprIsConApp_maybe env e of+    Just (_env,_fb,dc,_tys,[arg]) -> case exprIsLiteral_maybe env arg of+      Just (LitNumber _ i) -> pure (dc,i)+      _                    -> mzero+    _ -> mzero++isIntegerLiteral :: CoreExpr -> RuleM Integer+isIntegerLiteral e = do+  (dc,i) <- isLitNumConApp e+  if | dc == integerISDataCon -> pure i+     | dc == integerINDataCon -> pure (negate i)+     | dc == integerIPDataCon -> pure i+     | otherwise              -> mzero++isBigIntegerLiteral :: CoreExpr -> RuleM Integer+isBigIntegerLiteral e = do+  (dc,i) <- isLitNumConApp e+  if | dc == integerINDataCon -> pure (negate i)+     | dc == integerIPDataCon -> pure i+     | otherwise              -> mzero++isNaturalLiteral :: CoreExpr -> RuleM Integer+isNaturalLiteral e = do+  (dc,i) <- isLitNumConApp e+  if | dc == naturalNSDataCon -> pure i+     | dc == naturalNBDataCon -> pure i+     | otherwise              -> mzero++-- return the n-th argument of this rule, if it is a literal+-- argument indices start from 0+getLiteral :: Int -> RuleM Literal+getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of+  (Lit l:_) -> Just l+  _ -> Nothing++unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+unaryLit op = do+  env <- getRuleOpts+  [Lit l] <- getArgs+  liftMaybe $ op env (convFloating env l)++binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+binaryLit op = do+  env <- getRuleOpts+  [Lit l1, Lit l2] <- getArgs+  liftMaybe $ op env (convFloating env l1) (convFloating env l2)++binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr+binaryCmpLit op = do+  platform <- getPlatform+  binaryLit (\_ -> cmpOp platform op)++leftIdentity :: Literal -> RuleM CoreExpr+leftIdentity id_lit = leftIdentityPlatform (const id_lit)++rightIdentity :: Literal -> RuleM CoreExpr+rightIdentity id_lit = rightIdentityPlatform (const id_lit)++identity :: Literal -> RuleM CoreExpr+identity lit = leftIdentity lit `mplus` rightIdentity lit++leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  return e2++-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityCPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUnboxedTuple [e2, no_c])++rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  return e1++-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityCPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUnboxedTuple [e1, no_c])++identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityPlatform lit =+  leftIdentityPlatform lit `mplus` rightIdentityPlatform lit++-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition+-- to the result, we have to indicate that no carry/overflow occurred.+identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityCPlatform lit =+  leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit++leftZero :: RuleM CoreExpr+leftZero = do+  [Lit l1, _] <- getArgs+  guard $ isZeroLit l1+  return $ Lit l1++rightZero :: RuleM CoreExpr+rightZero = do+  [_, Lit l2] <- getArgs+  guard $ isZeroLit l2+  return $ Lit l2++zeroElem :: RuleM CoreExpr+zeroElem = leftZero `mplus` rightZero++equalArgs :: RuleM ()+equalArgs = do+  [e1, e2] <- getArgs+  guard $ e1 `cheapEqExpr` e2++nonZeroLit :: Int -> RuleM ()+nonZeroLit n = getLiteral n >>= guard . not . isZeroLit++oneLit :: Int -> RuleM ()+oneLit n = getLiteral n >>= guard . isOneLit++lift_bits_op :: forall a. (Num a, FiniteBits a) => (a -> Integer) -> RuleM CoreExpr+lift_bits_op op = do+  platform <- getPlatform+  [Lit (LitNumber _ l)] <- getArgs+  pure $ mkWordLit platform $ op (fromInteger l :: a)++pop_count :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+pop_count = lift_bits_op @a (fromIntegral . popCount)++ctz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+ctz = lift_bits_op @a (fromIntegral . countTrailingZeros)++clz :: forall a. (Num a, FiniteBits a) => RuleM CoreExpr+clz = lift_bits_op @a (fromIntegral . countLeadingZeros)++-- When excess precision is not requested, cut down the precision of the+-- Rational value to that of Float/Double. We confuse host architecture+-- and target architecture here, but it's convenient (and wrong :-).+convFloating :: RuleOpts -> Literal -> Literal+convFloating env (LitFloat  f) | not (roExcessRationalPrecision env) =+   LitFloat  (toRational (fromRational f :: Float ))+convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =+   LitDouble (toRational (fromRational d :: Double))+convFloating _ l = l++guardFloatDiv :: RuleM ()+guardFloatDiv = do+  [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs+  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]+       && f2 /= 0            -- avoid NaN and Infinity/-Infinity++guardDoubleDiv :: RuleM ()+guardDoubleDiv = do+  [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs+  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]+       && d2 /= 0            -- avoid NaN and Infinity/-Infinity+-- Note [negative zero]+-- ~~~~~~~~~~~~~~~~~~~~+-- Avoid (0 / -d), otherwise 0/(-1) reduces to+-- zero, but we might want to preserve the negative zero here which+-- is representable in Float/Double but not in (normalised)+-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?++strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr+strengthReduction two_lit add_op = do -- Note [Strength reduction]+  arg <- msum [ do [arg, Lit mult_lit] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg+              , do [Lit mult_lit, arg] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg ]+  return $ Var (primOpId add_op) `App` arg `App` arg++-- Note [Strength reduction]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- This rule turns floating point multiplications of the form 2.0 * x and+-- x * 2.0 into x + x addition, because addition costs less than multiplication.+-- See #7116++-- Note [What's true and false]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- trueValInt and falseValInt represent true and false values returned by+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.+-- True is represented as an unboxed 1# literal, while false is represented+-- as 0# literal.+-- We still need Bool data constructors (True and False) to use in a rule+-- for constant folding of equal Strings++trueValInt, falseValInt :: Platform -> Expr CoreBndr+trueValInt  platform = Lit $ onei  platform -- see Note [What's true and false]+falseValInt platform = Lit $ zeroi platform++trueValBool, falseValBool :: Expr CoreBndr+trueValBool   = Var trueDataConId -- see Note [What's true and false]+falseValBool  = Var falseDataConId++ltVal, eqVal, gtVal :: Expr CoreBndr+ltVal = Var ordLTDataConId+eqVal = Var ordEQDataConId+gtVal = Var ordGTDataConId++mkIntVal :: Platform -> Integer -> Expr CoreBndr+mkIntVal platform i = Lit (mkLitInt platform i)+mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr+mkFloatVal env f = Lit (convFloating env (LitFloat  f))+mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr+mkDoubleVal env d = Lit (convFloating env (LitDouble d))++matchPrimOpId :: PrimOp -> Id -> RuleM ()+matchPrimOpId op id = do+  op' <- liftMaybe $ isPrimOpId_maybe id+  guard $ op == op'++{-+************************************************************************+*                                                                      *+\subsection{Special rules for seq, tagToEnum, dataToTag}+*                                                                      *+************************************************************************++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 but it works.++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++We used to make this check in the type inference engine, but it's quite+ugly to do so, because the delayed constraint solving means that we don't+really know what's going on until the end. It's very much a corner case+because we don't expect the user to call tagToEnum# at all; we merely+generate calls in derived instances of Enum.  So we compromise: a+rewrite rule rewrites a bad instance of tagToEnum# to an error call,+and emits a warning.++We also do something similar if we can see that the argument of tagToEnum is out+of bounds, e.g. `tagToEnum# 99# :: Bool`.+Replacing this with an error expression is better for two reasons:+* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`+* Should we actually end up executing the relevant code at runtime the user will+  see a meaningful error message, instead of a segfault or incorrect result.+See #25976.+-}++tagToEnumRule :: RuleM CoreExpr+-- If     data T a = A | B | C+-- then   tagToEnum# (T ty) 2# -->  B ty+tagToEnumRule = do+  [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs+  case splitTyConApp_maybe ty of+    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do+      let tag = fromInteger i+          correct_tag dc = (dataConTagZ dc) == tag+      Just dataCons <- pure $ tyConDataCons_maybe tycon+      case filter correct_tag dataCons of+        (dc:rest) -> do+          massert (null rest)+          pure $ mkTyApps (Var (dataConWorkId dc)) tc_args+        -- Literal is out of range, e.g. tagToEnum @Bool #4+        [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"++    -- See Note [tagToEnum#]+    _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $+         return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type"++------------------------------+dataToTagRule :: RuleM CoreExpr+-- Used for both dataToTagSmall# and dataToTagLarge#.+-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,+-- particularly wrinkle DTW5.+dataToTagRule = a `mplus` b+  where+    -- dataToTag (tagToEnum x)   ==>   x+    a = do+      [Type _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      guard $ tag_to_enum `hasKey` tagToEnumKey+      guard $ ty1 `eqType` ty2+      return tag++    -- dataToTag (K e1 e2)  ==>   tag-of K+    -- This also works (via exprIsConApp_maybe) for+    --   dataToTag x+    -- where x's unfolding is a constructor application+    b = do+      platform <- getPlatform+      [_lev, _ty, val_arg] <- getArgs+      in_scope <- getInScopeEnv+      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg+      massert (not (isNewTyCon (dataConTyCon dc)))+      return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc)))+++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++-- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)+-- That is, if the two types are equal, it's not unsafe!++unsafeEqualityProofRule :: RuleM CoreExpr+unsafeEqualityProofRule+  = do { [Type rep, Type t1, Type t2] <- getArgs+       ; guard (t1 `eqType` t2)+       ; fn <- getFunction+       ; let (_, ue) = splitForAllTyCoVars (idType fn)+             tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality+             dc      = tyConSingleDataCon tc  -- data con: UnsafeRefl+             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).+             --               UnsafeEquality r a a+       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }+++{- *********************************************************************+*                                                                      *+             Rules for spark#+*                                                                      *+********************************************************************* -}++-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = do -- reduce on HNF+  [Type _ty_a, Type _ty_s, a, s] <- getArgs+  guard $ exprIsHNF a+  return $ mkCoreUnboxedTuple [s, a]+    -- XXX perhaps we shouldn't do this, because a spark eliminated by+    -- this rule won't be counted as a dud at runtime?++{-+************************************************************************+*                                                                      *+\subsection{Built in rules}+*                                                                      *+************************************************************************++Note [Scoping for Builtin rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling a (base-package) module that defines one of the+functions mentioned in the RHS of a built-in rule, there's a danger+that we'll see++        f = ...(eq String x)....++        ....and lower down...++        eqString = ...++Then a rewrite would give++        f = ...(eqString x)...+        ....and lower down...+        eqString = ...++and lo, eqString is not in scope.  This only really matters when we+get to code generation.  But the occurrence analyser does a GlomBinds+step when necessary, that does a new SCC analysis on the whole set of+bindings (see occurAnalysePgm), which sorts out the dependency, so all+is fine.+-}++builtinRules :: [CoreRule]+-- Rules for non-primops that can't be expressed using a RULE pragma+builtinRules+  = [BuiltinRule { ru_name = fsLit "CStringFoldrLit",+                   ru_fn = unpackCStringFoldrName,+                   ru_nargs = 4, ru_try = match_cstring_foldr_lit_C },+     BuiltinRule { ru_name = fsLit "CStringFoldrLitUtf8",+                   ru_fn = unpackCStringFoldrUtf8Name,+                   ru_nargs = 4, ru_try = match_cstring_foldr_lit_utf8 },+     BuiltinRule { ru_name = fsLit "CStringAppendLit",+                   ru_fn = unpackCStringAppendName,+                   ru_nargs = 2, ru_try = match_cstring_append_lit_C },+     BuiltinRule { ru_name = fsLit "CStringAppendLitUtf8",+                   ru_fn = unpackCStringAppendUtf8Name,+                   ru_nargs = 2, ru_try = match_cstring_append_lit_utf8 },+     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,+                   ru_nargs = 2, ru_try = match_eq_string },+     BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,+                   ru_nargs = 1, ru_try = match_cstring_length },+     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },++     mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,++     mkBasicRule divIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 div)+        , leftZero+        , do+          [arg, Lit (LitNumber LitNumInt d)] <- getArgs+          Just n <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (primOpId IntSraOp) `App` arg `App` mkIntVal platform n+        ],++     mkBasicRule modIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 mod)+        , leftZero+        , do+          [arg, Lit (LitNumber LitNumInt d)] <- getArgs+          Just _ <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (primOpId IntAndOp)+            `App` arg `App` mkIntVal platform (d - 1)+        ]+     ]+ ++ builtinBignumRules+{-# NOINLINE builtinRules #-}+-- there is no benefit to inlining these yet, despite this, GHC produces+-- unfoldings for this regardless since the floated list entries look small.++builtinBignumRules :: [CoreRule]+builtinBignumRules =+  [ -- conversions+    lit_to_integer "Word# -> Integer"   integerFromWordName+  , lit_to_integer "Int64# -> Integer"  integerFromInt64Name+  , lit_to_integer "Word64# -> Integer" integerFromWord64Name+  , lit_to_integer "Natural -> Integer" integerFromNaturalName++  , integer_to_lit "Integer -> Word# (wrap)"   integerToWordName   mkWordLitWrap+  , integer_to_lit "Integer -> Int# (wrap)"    integerToIntName    mkIntLitWrap+  , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)+  , integer_to_lit "Integer -> Int64# (wrap)"  integerToInt64Name  (\_ -> mkInt64LitInt64 . fromInteger)+  , integer_to_lit "Integer -> Float#"         integerToFloatName  (\_ -> mkFloatLitFloat . fromInteger)+  , integer_to_lit "Integer -> Double#"        integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)++  , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True+  , integer_to_natural "Integer -> Natural (wrap)"  integerToNaturalName      False False+  , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False++  , natural_to_word "Natural -> Word# (wrap)"  naturalToWordName++    -- comparisons (return an unlifted Int#)+  , bignum_bin_pred "bigNatEq#"  bignatEqName (==)++    -- comparisons (return an Ordering)+  , bignum_compare "bignatCompare"      bignatCompareName+  , bignum_compare "bignatCompareWord#" bignatCompareWordName++    -- binary operations+  , integer_binop "integerAdd" integerAddName (+)+  , integer_binop "integerSub" integerSubName (-)+  , integer_binop "integerMul" integerMulName (*)+  , integer_binop "integerGcd" integerGcdName gcd+  , integer_binop "integerLcm" integerLcmName lcm+  , integer_binop "integerAnd" integerAndName (.&.)+  , integer_binop "integerOr"  integerOrName  (.|.)+  , integer_binop "integerXor" integerXorName xor++  , natural_binop "naturalAdd" naturalAddName (+)+  , natural_binop "naturalMul" naturalMulName (*)+  , natural_binop "naturalGcd" naturalGcdName gcd+  , natural_binop "naturalLcm" naturalLcmName lcm+  , natural_binop "naturalAnd" naturalAndName (.&.)+  , natural_binop "naturalOr"  naturalOrName  (.|.)+  , natural_binop "naturalXor" naturalXorName xor++    -- Natural subtraction: it's a binop but it can fail because of underflow so+    -- we have several primitives to handle here.+  , natural_sub "naturalSubUnsafe" naturalSubUnsafeName+  , natural_sub "naturalSubThrow"  naturalSubThrowName+  , mkRule "naturalSub" naturalSubName 2 $ do+        [a0,a1] <- getArgs+        x <- isNaturalLiteral a0+        y <- isNaturalLiteral a1+        -- return an unboxed sum: (# (# #) | Natural #)+        let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v+        platform <- getPlatform+        if x < y+            then ret 1 unboxedUnitExpr+            else ret 2 $ mkNaturalExpr platform (x - y)++    -- unary operations+  , bignum_unop "integerNegate"     integerNegateName     mkIntegerExpr negate+  , bignum_unop "integerAbs"        integerAbsName        mkIntegerExpr abs+  , bignum_unop "integerComplement" integerComplementName mkIntegerExpr complement++  , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap+  , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap++    -- Bits.bit+  , bignum_bit "integerBit" integerBitName mkIntegerExpr+  , bignum_bit "naturalBit" naturalBitName mkNaturalExpr++    -- Bits.testBit+  , bignum_testbit "integerTestBit" integerTestBitName+  , bignum_testbit "naturalTestBit" naturalTestBitName++    -- Bits.shift+  , bignum_shift "integerShiftL" integerShiftLName shiftL mkIntegerExpr+  , bignum_shift "integerShiftR" integerShiftRName shiftR mkIntegerExpr+  , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkNaturalExpr+  , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkNaturalExpr++    -- division+  , divop_one  "integerQuot"    integerQuotName    quot    mkIntegerExpr+  , divop_one  "integerRem"     integerRemName     rem     mkIntegerExpr+  , divop_one  "integerDiv"     integerDivName     div     mkIntegerExpr+  , divop_one  "integerMod"     integerModName     mod     mkIntegerExpr+  , divop_both "integerDivMod"  integerDivModName  divMod  mkIntegerExpr+  , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr++  , divop_one  "naturalQuot"    naturalQuotName    quot    mkNaturalExpr+  , divop_one  "naturalRem"     naturalRemName     rem     mkNaturalExpr+  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr++    -- conversions from Rational for Float/Double literals+  , rational_to "rationalToFloat"  rationalToFloatName  mkFloatExpr+  , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr++    -- conversions from Integer for Float/Double literals+  , integer_encode_float "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat+  , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble+  ]+  where+    mkRule str name nargs f = BuiltinRule+      { ru_name = fsLit str+      , ru_fn = name+      , ru_nargs = nargs+      , ru_try = runRuleM $ do+          env <- getRuleOpts+          guard (roBignumRules env)+          f+      }++    integer_to_lit str name convert = mkRule str name 1 $ do+      [a0] <- getArgs+      platform <- getPlatform+      -- we only match on Big Integer literals. Small literals+      -- are matched by the "Int# -> Integer -> *" rules+      x <- isBigIntegerLiteral a0+      pure (convert platform x)++    natural_to_word str name = mkRule str name 1 $ do+      [a0] <- getArgs+      n <- isNaturalLiteral a0+      platform <- getPlatform+      pure (Lit (mkLitWordWrap platform n))++    integer_to_natural str name thrw clamp = mkRule str name 1 $ do+      [a0] <- getArgs+      x <- isIntegerLiteral a0+      platform <- getPlatform+      if | x >= 0    -> pure $ mkNaturalExpr platform x+         | thrw      -> mzero+         | clamp     -> pure $ mkNaturalExpr platform 0       -- clamp to 0+         | otherwise -> pure $ mkNaturalExpr platform (abs x) -- negate/wrap++    lit_to_integer str name = mkRule str name 1 $ do+      [a0] <- getArgs+      platform <- getPlatform+      i <- isBignumLiteral a0+      -- convert any numeric literal into an Integer literal+      pure (mkIntegerExpr platform i)++    integer_binop str name op = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isIntegerLiteral a0+      y <- isIntegerLiteral a1+      platform <- getPlatform+      pure (mkIntegerExpr platform (x `op` y))++    natural_binop str name op = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNaturalLiteral a0+      y <- isNaturalLiteral a1+      platform <- getPlatform+      pure (mkNaturalExpr platform (x `op` y))++    natural_sub str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNaturalLiteral a0+      y <- isNaturalLiteral a1+      guard (x >= y)+      platform <- getPlatform+      pure (mkNaturalExpr platform (x - y))++    bignum_bin_pred str name op = mkRule str name 2 $ do+      platform <- getPlatform+      [a0,a1] <- getArgs+      x <- isBignumLiteral a0+      y <- isBignumLiteral a1+      pure $ if x `op` y+              then trueValInt platform+              else falseValInt platform++    bignum_compare str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isBignumLiteral a0+      y <- isBignumLiteral a1+      pure $ case x `compare` y of+              LT -> ltVal+              EQ -> eqVal+              GT -> gtVal++    bignum_unop str name mk_lit op = mkRule str name 1 $ do+      [a0] <- getArgs+      x <- isBignumLiteral a0+      platform <- getPlatform+      pure $ mk_lit platform (op x)++    bignum_popcount str name mk_lit = mkRule str name 1 $ do+      platform <- getPlatform+      -- We use a host Int to compute the popCount. If we compile on a 32-bit+      -- host for a 64-bit target, the result may be different than if computed+      -- by the target. So we disable this rule if sizes don't match.+      guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word))+      [a0] <- getArgs+      x <- isBignumLiteral a0+      pure $ Lit (mk_lit platform (fromIntegral (popCount x)))++    bignum_bit str name mk_lit = mkRule str name 1 $ do+      [a0] <- getArgs+      platform <- getPlatform+      n <- isNumberLiteral a0+      -- Make sure n is positive and small enough to yield a decently+      -- small number. Attempting to construct the Integer for+      --    (integerBit 9223372036854775807#)+      -- would be a bad idea (#14959)+      guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform))+      -- it's safe to convert a target Int value into a host Int value+      -- to perform the "bit" operation because n is very small (<= 64).+      pure $ mk_lit platform (bit (fromIntegral n))++    bignum_testbit str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      platform <- getPlatform+      x <- isBignumLiteral a0+      n <- isNumberLiteral a1+      -- ensure that we can store 'n' in a host Int+      guard (n >= 0 && n <= fromIntegral (maxBound :: Int))+      pure $ if testBit x (fromIntegral n)+              then trueValInt platform+              else falseValInt platform++    bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isBignumLiteral a0+      n <- isNumberLiteral a1+      -- See Note [Guarding against silly shifts]+      -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.+      -- We can get huge shifts in inaccessible code (#15673)+      guard (n <= 4)+      platform <- getPlatform+      pure $ mk_lit platform (x `shift_op` fromIntegral n)++    divop_one str name divop mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      n <- isBignumLiteral a0+      d <- isBignumLiteral a1+      guard (d /= 0)+      platform <- getPlatform+      pure $ mk_lit platform (n `divop` d)++    divop_both str name divop mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      n <- isBignumLiteral a0+      d <- isBignumLiteral a1+      guard (d /= 0)+      let (r,s) = n `divop` d+      platform <- getPlatform+      pure $ mkCoreUnboxedTuple [mk_lit platform r, mk_lit platform s]++    integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule+    integer_encode_float str name mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isIntegerLiteral a0+      y <- isNumberLiteral a1+      -- check that y (a target Int) is in the host Int range+      guard (y <= fromIntegral (maxBound :: Int))+      pure (mk_lit $ encodeFloat x (fromInteger y))++    rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule+    rational_to str name mk_lit = mkRule str name 2 $ do+      -- This turns `rationalToFloat n d` where `n` and `d` are literals into+      -- a literal Float (and similarly for Double).+      [a0,a1] <- getArgs+      n <- isIntegerLiteral a0+      d <- isIntegerLiteral a1+      -- it's important to not match d == 0, because that may represent a+      -- literal "0/0" or similar, and we can't produce a literal value for+      -- NaN or +-Inf+      guard (d /= 0)+      pure $ mk_lit (fromRational (n % d))+++---------------------------------------------------+-- The rules are:+--      unpackAppendCString*# "foo"# (unpackCString*# "baz"#)+--      =  unpackCString*# "foobaz"#+--+--      unpackAppendCString*# "foo"# (unpackAppendCString*# "baz"# e)+--      =  unpackAppendCString*# "foobaz"# e+--++-- CString version+match_cstring_append_lit_C :: RuleFun+match_cstring_append_lit_C = match_cstring_append_lit unpackCStringAppendIdKey unpackCStringIdKey++-- CStringUTF8 version+match_cstring_append_lit_utf8 :: RuleFun+match_cstring_append_lit_utf8 = match_cstring_append_lit unpackCStringAppendUtf8IdKey unpackCStringUtf8IdKey++{-# INLINE match_cstring_append_lit #-}+match_cstring_append_lit :: Unique -> Unique -> RuleFun+match_cstring_append_lit append_key unpack_key _ env _ [lit1, e2]+  | Just (LitString s1) <- exprIsLiteral_maybe env lit1+  , (strTicks, Var unpk `App` lit2) <- stripStrTopTicks env e2+  , unpk `hasKey` unpack_key+  , Just (LitString s2) <- exprIsLiteral_maybe env lit2+  = Just $ mkTicks strTicks+         $ Var unpk `App` Lit (LitString (s1 `BS.append` s2))++  | Just (LitString s1) <- exprIsLiteral_maybe env lit1+  , (strTicks, Var appnd `App` lit2 `App` e) <- stripStrTopTicks env e2+  , appnd `hasKey` append_key+  , Just (LitString s2) <- exprIsLiteral_maybe env lit2+  = Just $ mkTicks strTicks+         $ Var appnd `App` Lit (LitString (s1 `BS.append` s2)) `App` e++match_cstring_append_lit _ _ _ _ _ _ = Nothing++---------------------------------------------------+-- The rule is this:+--      unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)+--      =  unpackFoldrCString*# "foobaz"# c n+--+-- See also Note [String literals in GHC] in CString.hs++-- CString version+match_cstring_foldr_lit_C :: RuleFun+match_cstring_foldr_lit_C = match_cstring_foldr_lit unpackCStringFoldrIdKey++-- CStringUTF8 version+match_cstring_foldr_lit_utf8 :: RuleFun+match_cstring_foldr_lit_utf8 = match_cstring_foldr_lit unpackCStringFoldrUtf8IdKey++{-# INLINE match_cstring_foldr_lit #-}+match_cstring_foldr_lit :: Unique -> RuleFun+match_cstring_foldr_lit foldVariant _ env _+        [ Type ty1+        , lit1+        , c1+        , e2+        ]+  | (strTicks, Var unpk `App` Type ty2+                        `App` lit2+                        `App` c2+                        `App` n) <- stripStrTopTicks env e2+  , unpk `hasKey` foldVariant+  , Just (LitString s1) <- exprIsLiteral_maybe env lit1+  , Just (LitString s2) <- exprIsLiteral_maybe env lit2+  , eqCoreExpr c1 c2+  , (c1Ticks, c1') <- stripStrTopTicks env c1+  , c2Ticks <- stripStrTopTicksT c2+  = assert (ty1 `eqType` ty2) $+    Just $ mkTicks strTicks+         $ Var unpk `App` Type ty1+                    `App` Lit (LitString (s1 `BS.append` s2))+                    `App` mkTicks (c1Ticks ++ c2Ticks) c1'+                    `App` n++match_cstring_foldr_lit _ _ _ _ _ = Nothing+++-- N.B. Ensure that we strip off any ticks (e.g. source notes) from the+-- argument, lest this may fail to fire when building with -g3. See #16740.+--+-- Also, look into variable's unfolding just in case the expression we look for+-- is in a top-level thunk.+stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)+stripStrTopTicks (ISE _ id_unf) e = case e of+  Var v+    | Just rhs <- expandUnfolding_maybe (id_unf v)+    -> stripTicksTop tickishFloatable rhs+  _ -> stripTicksTop tickishFloatable e++stripStrTopTicksT :: CoreExpr -> [CoreTickish]+stripStrTopTicksT e = stripTicksTopT tickishFloatable e++---------------------------------------------------+-- The rule is this:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2+-- Also  matches unpackCStringUtf8#++match_eq_string :: RuleFun+match_eq_string _ env _ [e1, e2]+  | (ticks1, Var unpk1 `App` lit1) <- stripStrTopTicks env e1+  , (ticks2, Var unpk2 `App` lit2) <- stripStrTopTicks env e2+  , unpk_key1 <- getUnique unpk1+  , unpk_key2 <- getUnique unpk2+  , unpk_key1 == unpk_key2+  -- For now we insist the literals have to agree in their encoding+  -- to keep the rule simple. But we could check if the decoded strings+  -- compare equal in here as well.+  , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]+  , Just (LitString s1) <- exprIsLiteral_maybe env lit1+  , Just (LitString s2) <- exprIsLiteral_maybe env lit2+  = Just $ mkTicks (ticks1 ++ ticks2)+         $ (if s1 == s2 then trueValBool else falseValBool)++match_eq_string _ _ _ _ = Nothing++-----------------------------------------------------------------------+-- Illustration of this rule:+--+-- cstringLength# "foobar"# --> 6+-- cstringLength# "fizz\NULzz"# --> 4+--+-- Nota bene: Addr# literals are suffixed by a NUL byte when they are+-- compiled to read-only data sections. That's why cstringLength# is+-- well defined on Addr# literals that do not explicitly have an embedded+-- NUL byte.+--+-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly+-- helpful when using OverloadedStrings to create a ByteString since the+-- function computing the length of such ByteStrings can often be constant+-- folded.+match_cstring_length :: RuleFun+match_cstring_length rule_env env _ [lit1]+  | Just (LitString str) <- exprIsLiteral_maybe env lit1+    -- If elemIndex returns Just, it has the index of the first embedded NUL+    -- in the string. If no NUL bytes are present (the common case) then use+    -- full length of the byte string.+  = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)+     in Just (Lit (mkLitInt (roPlatform rule_env) (fromIntegral len)))+match_cstring_length _ _ _ _ = Nothing++{- Note [inlineId magic]+~~~~~~~~~~~~~~~~~~~~~~~~+The call 'inline f' arranges that 'f' is inlined, regardless of+its size. More precisely, the call 'inline f' rewrites to the+right-hand side of 'f's definition. This allows the programmer to+control inlining from a particular call site rather than the+definition site of the function.++The moving parts are simple:++* A very simple definition in the library base:GHC.Magic+     {-# NOINLINE[0] inline #-}+     inline :: a -> a+     inline x = x+  So in phase 0, 'inline' will be inlined, so its use imposes+  no overhead.++* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes+  (inline f) inline, implemented by match_inline.+  The rule for the 'inline' function is this:+     inline f_ty (f a b c) = <f's unfolding> a b c+  (if f has an unfolding, EVEN if it's a loop breaker)++  Additionally the rule looks through ticks/casts as well (#24808):+      inline f_ty (f a b c |> co) = <f's unfolding> a b c |> co+      inline f_ty <tick> ( f a b c ) = <tick> <f's unfolding> a b c++  It's important to allow the argument to 'inline' to have args itself+  (a) because its more forgiving to allow the programmer to write+      either  inline f a b c+      or      inline (f a b c)+  (b) because a polymorphic f wll get a type argument that the+      programmer can't avoid, so the call may look like+        inline (map @Int @Bool) g xs++  Also, don't forget about 'inline's type argument!+-}++match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_inline (Type _ : e : _) = go e+  -- Maybe Monad ahead:+  where+    go (Var f)      = -- Ignore the IdUnfoldingFun here!+                      (maybeUnfoldingTemplate (realIdUnfolding f))+    go (App f a)    = do { f' <- go f; pure $ App f' a }+    -- inline (f |> co)+    go (Cast e co)  = do { app <- go e; pure (Cast app co) }+    -- inline (<tick> f)+    go (Tick t e)   = do { app <- go e; pure (Tick t app) }+    go _            = Nothing++match_inline _ = Nothing++--------------------------------------------------------+-- Note [Constant folding through nested expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC has some support for constant folding through nested expressions (i.e.+-- when constants are not only arguments of the considered App node but to one+-- of its own argument (an App node too), see examples below).+--+-- For performance reason, this optimization is only enabled with -O1 and above.+-- As with all optimizations, it can also be independently enabled with its own+-- command-line flag too: -fnum-constant-folding (grep Opt_NumConstantFolding).+--+-- We use rewrites rules to perform constant folding. It means that we don't+-- have a global view of the expression we are trying to optimise. As a+-- consequence we only perform local (small-step) transformations that either:+--    1) reduce the number of operations+--    2) rearrange the expression to increase the odds that other rules will+--    match+--+-- We don't try to handle more complex expression optimisation cases that would+-- require a global view. For example, rewriting expressions to increase+-- sharing (e.g., Horner's method); optimisations that require local+-- transformations increasing the number of operations; rearrangements to+-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).+--+-- We already have rules to perform constant folding on expressions with the+-- following shape (where a and/or b are literals):+--+--          D)    op+--                /\+--               /  \+--              /    \+--             a      b+--+-- To support nested expressions, we match three other shapes of expression+-- trees:+--+-- A)   op1          B)       op1       C)       op1+--      /\                    /\                 /\+--     /  \                  /  \               /  \+--    /    \                /    \             /    \+--   a     op2            op2     c          op2    op3+--          /\            /\                 /\      /\+--         /  \          /  \               /  \    /  \+--        b    c        a    b             a    b  c    d+--+--+-- R1) +/- simplification:+--    ops = + or -, two literals (not siblings)+--+--    Examples:+--       A: 5 + (10-x)  ==> 15-x+--       B: (10+x) + 5  ==> 15+x+--       C: (5+a)-(5-b) ==> 0+(a+b)+--+-- R2) *, `and`, `or`  simplification+--    ops = *, `and`, `or` two literals (not siblings)+--+--    Examples:+--       A: 5 * (10*x)  ==> 50*x+--       B: (10*x) * 5  ==> 50*x+--       C: (5*a)*(5*b) ==> 25*(a*b)+--+-- R3) * distribution over +/-+--    op1 = *, op2 = + or -, two literals (not siblings)+--+--    This transformation doesn't reduce the number of operations but switches+--    the outer and the inner operations so that the outer is (+) or (-) instead+--    of (*). It increases the odds that other rules will match after this one.+--+--    Examples:+--       A: 5 * (10-x)  ==> 50 - (5*x)+--       B: (10+x) * 5  ==> 50 + (5*x)+--       C: Not supported as it would increase the number of operations:+--          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b+--+-- R4) Simple factorization+--+--    op1 = + or -, op2/op3 = *,+--    one literal for each innermost * operation (except in the D case),+--    the two other terms are equals+--+--    Examples:+--       A: x - (10*x)  ==> (-9)*x+--       B: (10*x) + x  ==> 11*x+--       C: (5*x)-(x*3) ==> 2*x+--       D: x+x         ==> 2*x+--+-- R5) +/- propagation+--+--    ops = + or -, one literal+--+--    This transformation doesn't reduce the number of operations but propagates+--    the constant to the outer level. It increases the odds that other rules+--    will match after this one.+--+--    Examples:+--       A: x - (10-y)  ==> (x+y) - 10+--       B: (10+x) - y  ==> 10 + (x-y)+--       C: N/A (caught by the A and B cases)+--+--------------------------------------------------------++-- Rules to perform constant folding into nested expressions+--+--See Note [Constant folding through nested expressions]++addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+addFoldingRules op num_ops = do+   massert (op == numAdd num_ops)+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for + is handled here+      (addFoldingRules' platform arg1 arg2 num_ops+       <|> addFoldingRules' platform arg2 arg1 num_ops)++subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+subFoldingRules op num_ops = do+   massert (op == numSub num_ops)+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe (subFoldingRules' platform arg1 arg2 num_ops)++mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+mulFoldingRules op num_ops = do+   massert (op == numMul num_ops)+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for * is handled here+      (mulFoldingRules' platform arg1 arg2 num_ops+       <|> mulFoldingRules' platform arg2 arg1 num_ops)++andFoldingRules :: NumOps -> RuleM CoreExpr+andFoldingRules num_ops = do+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for `and` is handled here+      (andFoldingRules' platform arg1 arg2 num_ops+       <|> andFoldingRules' platform arg2 arg1 num_ops)++orFoldingRules :: NumOps -> RuleM CoreExpr+orFoldingRules num_ops = do+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for `or` is handled here+      (orFoldingRules' platform arg1 arg2 num_ops+       <|> orFoldingRules' platform arg2 arg1 num_ops)++quotFoldingRules :: NumOps -> RuleM CoreExpr+quotFoldingRules num_ops = do+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe (quotFoldingRules' platform arg1 arg2 num_ops)++addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of++      -- x + (-y) ==> x-y+      (x, is_neg num_ops -> Just y)+         -> Just (x `sub` y)++      -- R1) +/- simplification++      -- l1 + (l2 + x) ==> (l1+l2) + x+      (L l1, is_lit_add num_ops -> Just (l2,x))+         -> Just (mkL (l1+l2) `add` x)++      -- l1 + (l2 - x) ==> (l1+l2) - x+      (L l1, is_sub num_ops -> Just (L l2,x))+         -> Just (mkL (l1+l2) `sub` x)++      -- l1 + (x - l2) ==> (l1-l2) + x+      (L l1, is_sub num_ops -> Just (x,L l2))+         -> Just (mkL (l1-l2) `add` x)++      -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1+l2) `add` (x `add` y))++      -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1+l2) `add` (x `sub` y))++      -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1-l2) `add` (x `add` y))++      -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1+l2) `sub` (x `add` y))++      -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1-l2) `add` (y `sub` x))++      -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (0-l1-l2) `add` (x `add` y))++      -- R4) Simple factorization++      -- x + x ==> 2 * x+      _ | Just l1 <- is_expr_mul num_ops arg1 arg2+        -> Just (mkL (l1+1) `mul` arg1)++      -- (l1 * x) + x ==> (l1+1) * x+      _ | Just l1 <- is_expr_mul num_ops arg2 arg1+        -> Just (mkL (l1+1) `mul` arg2)++      -- (l1 * x) + (l2 * x) ==> (l1+l2) * x+      (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+         -> Just (mkL (l1+l2) `mul` x)++      -- R5) +/- propagation: these transformations push literals outwards+      -- with the hope that other rules can then be applied.++      -- In the following rules, x can't be a literal otherwise another+      -- rule would have combined it with the other literal in arg2. So we+      -- don't have to check this to avoid loops here.++      -- x + (l1 + y) ==> l1 + (x + y)+      (_, is_lit_add num_ops -> Just (l1,y))+         -> Just (mkL l1 `add` (arg1 `add` y))++      -- x + (l1 - y) ==> l1 + (x - y)+      (_, is_sub num_ops -> Just (L l1,y))+         -> Just (mkL l1 `add` (arg1 `sub` y))++      -- x + (y - l1) ==> (x + y) - l1+      (_, is_sub num_ops -> Just (y,L l1))+         -> Just ((arg1 `add` y) `sub` mkL l1)++      _ -> Nothing++   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+      -- x - (-y) ==> x+y+      (x, is_neg num_ops -> Just y)+         -> Just (x `add` y)++      -- R1) +/- simplification++      -- l1 - (l2 + x) ==> (l1-l2) - x+      (L l1, is_lit_add num_ops -> Just (l2,x))+         -> Just (mkL (l1-l2) `sub` x)++      -- l1 - (l2 - x) ==> (l1-l2) + x+      (L l1, is_sub num_ops -> Just (L l2,x))+         -> Just (mkL (l1-l2) `add` x)++      -- l1 - (x - l2) ==> (l1+l2) - x+      (L l1, is_sub num_ops -> Just (x, L l2))+         -> Just (mkL (l1+l2) `sub` x)++      -- (l1 + x) - l2 ==> (l1-l2) + x+      (is_lit_add num_ops -> Just (l1,x), L l2)+         -> Just (mkL (l1-l2) `add` x)++      -- (l1 - x) - l2 ==> (l1-l2) - x+      (is_sub num_ops -> Just (L l1,x), L l2)+         -> Just (mkL (l1-l2) `sub` x)++      -- (x - l1) - l2 ==> x - (l1+l2)+      (is_sub num_ops -> Just (x,L l1), L l2)+         -> Just (x `sub` mkL (l1+l2))+++      -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1-l2) `add` (x `sub` y))++      -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1-l2) `add` (x `add` y))++      -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1+l2) `add` (x `sub` y))++      -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1-l2) `sub` (x `add` y))++      -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)+      (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (0-l1-l2) `add` (x `sub` y))++      -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1-l2) `add` (y `sub` x))++      -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1+l2) `sub` (x `add` y))++      -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (0-l1-l2) `add` (x `add` y))++      -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l2-l1) `add` (x `sub` y))++       -- R4) Simple factorization++      -- x - (l1 * x) ==> (1-l1) * x+      _ | Just l1 <- is_expr_mul num_ops arg1 arg2+        -> Just (mkL (1-l1) `mul` arg1)++      -- (l1 * x) - x ==> (l1-1) * x+      _ | Just l1 <- is_expr_mul num_ops arg2 arg1+        -> Just (mkL (l1-1) `mul` arg2)++      -- (l1 * x) - (l2 * x) ==> (l1-l2) * x+      (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+         -> Just (mkL (l1-l2) `mul` x)++      -- R5) +/- propagation: these transformations push literals outwards+      -- with the hope that other rules can then be applied.++      -- In the following rules, x can't be a literal otherwise another+      -- rule would have combined it with the other literal in arg2. So we+      -- don't have to check this to avoid loops here.++      -- x - (l1 + y) ==> (x - y) - l1+      (_, is_lit_add num_ops -> Just (l1,y))+         -> Just ((arg1 `sub` y) `sub` mkL l1)++      -- (l1 + x) - y ==> l1 + (x - y)+      (is_lit_add num_ops -> Just (l1,x), _)+         -> Just (mkL l1 `add` (x `sub` arg2))++      -- x - (l1 - y) ==> (x + y) - l1+      (_, is_sub num_ops -> Just (L l1,y))+         -> Just ((arg1 `add` y) `sub` mkL l1)++      -- x - (y - l1) ==> l1 + (x - y)+      (_, is_sub num_ops -> Just (y,L l1))+         -> Just (mkL l1 `add` (arg1 `sub` y))++      -- (l1 - x) - y ==> l1 - (x + y)+      (is_sub num_ops -> Just (L l1,x), _)+         -> Just (mkL l1 `sub` (x `add` arg2))++      -- (x - l1) - y ==> (x - y) - l1+      (is_sub num_ops -> Just (x,L l1), _)+         -> Just ((x `sub` arg2) `sub` mkL l1)++      _ -> Nothing+   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+   -- (-x) * (-y) ==> x*y+   (is_neg num_ops -> Just x, is_neg num_ops -> Just y)+      -> Just (x `mul` y)++   -- l1 * (-x) ==> (-l1) * x+   (L l1, is_neg num_ops -> Just x)+      -> Just (mkL (-l1) `mul` x)++   -- l1 * (l2 * x) ==> (l1*l2) * x+   (L l1, is_lit_mul num_ops -> Just (l2,x))+      -> Just (mkL (l1*l2) `mul` x)++   -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)+   (L l1, is_lit_add num_ops -> Just (l2,x))+      -> Just (mkL (l1*l2) `add` (arg1 `mul` x))++   -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)+   (L l1, is_sub num_ops -> Just (L l2,x))+      -> Just (mkL (l1*l2) `sub` (arg1 `mul` x))++   -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)+   (L l1, is_sub num_ops -> Just (x, L l2))+      -> Just ((arg1 `mul` x) `sub` mkL (l1*l2))++   -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)+   (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y))+      -> Just (mkL (l1*l2) `mul` (x `mul` y))++   _ -> Nothing+   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+    -- R2) * `or` `and` simplifications+    -- l1 and (l2 and x) ==> (l1 and l2) and x+    (L l1, is_lit_and num_ops -> Just (l2, x))+       -> Just (mkL (l1 .&. l2) `and` x)++    -- l1 and (l2 or x) ==> (l1 and l2) or (l1 and x)+    -- does not decrease operations++    -- (l1 and x) and (l2 and y) ==> (l1 and l2) and (x and y)+    (is_lit_and num_ops -> Just (l1, x), is_lit_and num_ops -> Just (l2, y))+       -> Just (mkL (l1 .&. l2) `and` (x `and` y))++    -- (l1 and x) and (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)+    -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)+    -- increase operation numbers++    -- x and (y or ... or x or ... or z) ==> x+    (x, is_or_list num_ops -> Just xs)+      | any (cheapEqExpr x) xs+      -> Just x++    _ -> Nothing+    where+      mkL = Lit . mkNumLiteral platform num_ops+      and x y = BinOpApp x (fromJust (numAnd num_ops)) y++orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+    -- R2) *  `or` `and` simplifications+    -- l1 or (l2 or x) ==> (l1 or l2) or x+    (L l1, is_lit_or num_ops -> Just (l2, x))+       -> Just (mkL (l1 .|. l2) `or` x)++    -- l1 or (l2 and x) ==> (l1 or l2) and (l1 and x)+    -- does not decrease operations++    -- (l1 or x) or (l2 or y) ==> (l1 or l2) or (x or y)+    (is_lit_or num_ops -> Just (l1, x), is_lit_or num_ops -> Just (l2, y))+       -> Just (mkL (l1 .|. l2) `or` (x `or` y))++    -- (l1 and x) or (l2 or y) ==> (l1 and l2 and x) or (l1 and x and y)+    -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)+    -- increase operation numbers++    -- x or (y and ... and x and ... and z) ==> x+    (x, is_and_list num_ops -> Just xs)+      | any (cheapEqExpr x) xs+      -> Just x++    _ -> Nothing+    where+      mkL = Lit . mkNumLiteral platform num_ops+      or x y = BinOpApp x (fromJust (numOr num_ops)) y++quotFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+quotFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of++  -- (x / l1) / l2+  -- l1 and l2 /= 0+  -- l1*l2 doesn't overflow+  -- ==> x / (l1 * l2)+  (is_div num_ops -> Just (x, L l1), L l2)+    | l1 /= 0+    , l2 /= 0+    -- check that the result of the multiplication is in range+    , Just l <- mkNumLiteralMaybe platform num_ops (l1 * l2)+    -> Just (div x (Lit l))+      -- NB: we could directly return 0 or (-1) in case of overflow,+      -- but we would need to know+      --  (1) if we're dealing with a quot or a div operation+      --  (2) if it's an underflow or an overflow.+      -- Left as future work for now.++  _ -> Nothing+  where+    div x y = BinOpApp x (fromJust (numDiv num_ops)) y++is_binop :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_binop op e = case e of+ BinOpApp x op' y | op == op' -> Just (x,y)+ _                            -> Nothing++is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr)+is_op op e = case e of+ App (OpVal op') x | op == op' -> Just x+ _                             -> Nothing++is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg)+is_add num_ops e = is_binop (numAdd num_ops) e+is_sub num_ops e = is_binop (numSub num_ops) e+is_mul num_ops e = is_binop (numMul num_ops) e+is_and num_ops e = numAnd num_ops >>= \op -> is_binop op e+is_or  num_ops e = numOr  num_ops >>= \op -> is_binop op e+is_div num_ops e = numDiv num_ops >>= \op -> is_binop op e++is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)+is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e++-- Return a list of operands for a given operation.+-- E.e. is_and_list (a and ... and z) => [a,...,z] for any nesting of the and+-- operation+is_list :: (CoreExpr -> Maybe (CoreArg,CoreArg)) -> CoreExpr -> Maybe [CoreArg]+is_list f e_org = case f e_org of -- do we have the operator at all?+  Just (a,b) -> Just (go [a,b])+  Nothing    -> Nothing+  where+    go = \case+      []     -> []+      (e:es) -> case f e of+        -- we can't split any more: add to the result list+        Nothing    -> e : go es+        Just (a,b) -> go (a:b:es)++is_and_list, is_or_list :: NumOps -> CoreExpr -> Maybe [CoreArg]+is_and_list ops = is_list (is_and ops)+is_or_list  ops = is_list (is_or  ops)++-- match operation with a literal (handles commutativity)+is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_add num_ops e = is_lit' is_add num_ops e+is_lit_mul num_ops e = is_lit' is_mul num_ops e+is_lit_and num_ops e = is_lit' is_and num_ops e+is_lit_or  num_ops e = is_lit' is_or  num_ops e++is_lit' :: (NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)) -> NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit' f num_ops e = case f num_ops e of+  Just (L l, x  ) -> Just (l,x)+  Just (x  , L l) -> Just (l,x)+  _               -> Nothing++-- match given "x": return 1+-- match "lit * x": return lit value (handles commutativity)+is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer+is_expr_mul num_ops x e = if+   | x `cheapEqExpr` e+   -> Just 1+   | Just (k,x') <- is_lit_mul num_ops e+   , x `cheapEqExpr` x'+   -> return k+   | otherwise+   -> Nothing+++-- | Match the application of a binary primop+pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr+pattern BinOpApp x op y = OpVal op `App` x `App` y++-- | Match a primop+pattern OpVal:: PrimOp  -> Arg CoreBndr+pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where+   OpVal op = Var (primOpId op)++-- | Match a literal+pattern L :: Integer -> Arg CoreBndr+pattern L i <- Lit (LitNumber _ i)++-- | Explicit "type-class"-like dictionary for numeric primops+data NumOps = NumOps+   { numAdd     :: !PrimOp         -- ^ Add two numbers+   , numSub     :: !PrimOp         -- ^ Sub two numbers+   , numMul     :: !PrimOp         -- ^ Multiply two numbers+   , numDiv     :: !(Maybe PrimOp) -- ^ Divide two numbers+   , numAnd     :: !(Maybe PrimOp) -- ^ And two numbers+   , numOr      :: !(Maybe PrimOp) -- ^ Or two numbers+   , numNeg     :: !(Maybe PrimOp) -- ^ Negate a number+   , numLitType :: !LitNumType     -- ^ Literal type+   }++-- | Create a numeric literal+mkNumLiteral :: Platform -> NumOps -> Integer -> Literal+mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i++-- | Create a numeric literal if it is in range+mkNumLiteralMaybe :: Platform -> NumOps -> Integer -> Maybe Literal+mkNumLiteralMaybe platform ops i = mkLitNumberMaybe platform (numLitType ops) i++int8Ops :: NumOps+int8Ops = NumOps+   { numAdd     = Int8AddOp+   , numSub     = Int8SubOp+   , numMul     = Int8MulOp+   , numDiv     = Just Int8QuotOp+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int8NegOp+   , numLitType = LitNumInt8+   }++word8Ops :: NumOps+word8Ops = NumOps+   { numAdd     = Word8AddOp+   , numSub     = Word8SubOp+   , numMul     = Word8MulOp+   , numDiv     = Just Word8QuotOp+   , numAnd     = Just Word8AndOp+   , numOr      = Just Word8OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord8+   }++int16Ops :: NumOps+int16Ops = NumOps+   { numAdd     = Int16AddOp+   , numSub     = Int16SubOp+   , numMul     = Int16MulOp+   , numDiv     = Just Int16QuotOp+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int16NegOp+   , numLitType = LitNumInt16+   }++word16Ops :: NumOps+word16Ops = NumOps+   { numAdd     = Word16AddOp+   , numSub     = Word16SubOp+   , numMul     = Word16MulOp+   , numDiv     = Just Word16QuotOp+   , numAnd     = Just Word16AndOp+   , numOr      = Just Word16OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord16+   }++int32Ops :: NumOps+int32Ops = NumOps+   { numAdd     = Int32AddOp+   , numSub     = Int32SubOp+   , numMul     = Int32MulOp+   , numDiv     = Just Int32QuotOp+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int32NegOp+   , numLitType = LitNumInt32+   }++word32Ops :: NumOps+word32Ops = NumOps+   { numAdd     = Word32AddOp+   , numSub     = Word32SubOp+   , numMul     = Word32MulOp+   , numDiv     = Just Word32QuotOp+   , numAnd     = Just Word32AndOp+   , numOr      = Just Word32OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord32+   }++int64Ops :: NumOps+int64Ops = NumOps+   { numAdd     = Int64AddOp+   , numSub     = Int64SubOp+   , numMul     = Int64MulOp+   , numDiv     = Just Int64QuotOp+   , numAnd     = Nothing+   , numOr      = Nothing+   , numNeg     = Just Int64NegOp+   , numLitType = LitNumInt64+   }++word64Ops :: NumOps+word64Ops = NumOps+   { numAdd     = Word64AddOp+   , numSub     = Word64SubOp+   , numMul     = Word64MulOp+   , numDiv     = Just Word64QuotOp+   , numAnd     = Just Word64AndOp+   , numOr      = Just Word64OrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord64+   }++intOps :: NumOps+intOps = NumOps+   { numAdd     = IntAddOp+   , numSub     = IntSubOp+   , numMul     = IntMulOp+   , numDiv     = Just IntQuotOp+   , numAnd     = Just IntAndOp+   , numOr      = Just IntOrOp+   , numNeg     = Just IntNegOp+   , numLitType = LitNumInt+   }++wordOps :: NumOps+wordOps = NumOps+   { numAdd     = WordAddOp+   , numSub     = WordSubOp+   , numMul     = WordMulOp+   , numDiv     = Just WordQuotOp+   , numAnd     = Just WordAndOp+   , numOr      = Just WordOrOp+   , numNeg     = Nothing+   , numLitType = LitNumWord+   }++--------------------------------------------------------+-- Constant folding through case-expressions+--+-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils+--------------------------------------------------------++-- | Match the scrutinee of a case and potentially return a new scrutinee and a+-- function to apply to each literal alternative.+caseRules :: Platform+          -> CoreExpr                       -- Scrutinee+          -> Maybe ( CoreExpr               -- New scrutinee+                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern+                                            --   Nothing <=> Unreachable+                                            -- See Note [Unreachable caseRules alternatives]+                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee+                                            -- from the new case-binder+-- e.g  case e of b {+--         ...;+--         con bs -> rhs;+--         ... }+--  ==>+--      case e' of b' {+--         ...;+--         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;+--         ... }++caseRules platform (App (App (Var f) v) (Lit l))   -- v `op` x#+  | Just op <- isPrimOpId_maybe f+  , LitNumber _ x <- l+  , Just adjust_lit <- adjustDyadicRight op x+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Var v)) (Lit l)))++caseRules platform (App (App (Var f) (Lit l)) v)   -- x# `op` v+  | Just op <- isPrimOpId_maybe f+  , LitNumber _ x <- l+  , Just adjust_lit <- adjustDyadicLeft x op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Lit l)) (Var v)))+++caseRules platform (App (Var f) v              )   -- op v+  | Just op <- isPrimOpId_maybe f+  , Just adjust_lit <- adjustUnary op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> App (Var f) (Var v))++-- See Note [caseRules for tagToEnum]+caseRules platform (App (App (Var f) type_arg) v)+  | Just TagToEnumOp <- isPrimOpId_maybe f+  = Just (v, tx_con_tte platform+           , \v -> (App (App (Var f) type_arg) (Var v)))++-- See Note [caseRules for dataToTag]+caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x+  | Just op <- isPrimOpId_maybe f+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case splitTyConApp_maybe ty of+      Just (tc, _) | isValidDTT2TyCon tc+        -> Just (v, tx_con_dtt tc+                , \v' -> Var f `App` Type lev `App` Type ty `App` Var v')+      _ -> pprTraceUserWarning warnMsg Nothing+  where+    warnMsg = vcat $ map text+      [ "Found dataToTag primop applied to a non-ADT type. This could"+      , "be a future bug in GHC, or it may be caused by an unsupported"+      , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#."+      , "In either case, the GHC developers would like to know about it!"+      , "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug"+      ]++caseRules _ _ = Nothing+++-- | Case rules+--+-- It's important that occurrence info are present, hence the use of In* types.+caseRules2+   :: InExpr  -- ^ Scutinee+   -> InId    -- ^ Case-binder+   -> [InAlt] -- ^ Alternatives in standard (increasing) order+   -> Maybe (InExpr, InId, [InAlt])+caseRules2 scrut bndr alts++  -- case quotRem# x y of+  --    (# q, _ #) -> body+  -- ====>+  --  case quot# x y of+  --    q -> body+  --+  -- case quotRem# x y of+  --    (# _, r #) -> body+  -- ====>+  --  case rem# x y of+  --    r -> body+  | BinOpApp x op y <- scrut+  , Just (quot,rem) <- is_any_quot_rem op+  , [Alt (DataAlt _) [q,r] body] <- alts+  , isDeadBinder bndr+  , dead_q <- isDeadBinder q+  , dead_r <- isDeadBinder r+  , dead_q || dead_r+  = if+      | dead_q    -> Just $ (BinOpApp x rem  y, r, [Alt DEFAULT [] body])+      | dead_r    -> Just $ (BinOpApp x quot y, q, [Alt DEFAULT [] body])+      | otherwise -> Nothing++  | otherwise+  = Nothing+++-- | If the given primop is a quotRem, return the corresponding (quot,rem).+is_any_quot_rem :: PrimOp -> Maybe (PrimOp, PrimOp)+is_any_quot_rem = \case+  IntQuotRemOp    -> Just (IntQuotOp ,  IntRemOp)+  Int8QuotRemOp   -> Just (Int8QuotOp,  Int8RemOp)+  Int16QuotRemOp  -> Just (Int16QuotOp, Int16RemOp)+  Int32QuotRemOp  -> Just (Int32QuotOp, Int32RemOp)+  -- Int64QuotRemOp doesn't exist (yet)++  WordQuotRemOp   -> Just (WordQuotOp,   WordRemOp)+  Word8QuotRemOp  -> Just (Word8QuotOp,  Word8RemOp)+  Word16QuotRemOp -> Just (Word16QuotOp, Word16RemOp)+  Word32QuotRemOp -> Just (Word32QuotOp, Word32RemOp)+  -- Word64QuotRemOp doesn't exist (yet)++  _ -> Nothing+++tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon+tx_lit_con _        _      DEFAULT    = Just DEFAULT+tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)+tx_lit_con _        _      alt        = pprPanic "caseRules" (ppr alt)+   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the+   -- literal alternatives remain in Word/Int target ranges+   -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).++adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)+-- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x+adjustDyadicRight op lit+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> y+lit      )+         IntSubOp  -> Just (\y -> y+lit      )+         WordXorOp -> Just (\y -> y `xor` lit)+         IntXorOp  -> Just (\y -> y `xor` lit)+         _         -> Nothing++adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)+-- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x+adjustDyadicLeft lit op+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> lit-y      )+         IntSubOp  -> Just (\y -> lit-y      )+         WordXorOp -> Just (\y -> y `xor` lit)+         IntXorOp  -> Just (\y -> y `xor` lit)+         _         -> Nothing+++adjustUnary :: PrimOp -> Maybe (Integer -> Integer)+-- Given (op x) return a function 'f' s.t.  f (op x) = x+adjustUnary op+  = case op of+         WordNotOp -> Just (\y -> complement y)+         IntNotOp  -> Just (\y -> complement y)+         IntNegOp  -> Just (\y -> negate y    )+         _         -> Nothing++tx_con_tte :: Platform -> AltCon -> Maybe AltCon+tx_con_tte _        DEFAULT         = Just DEFAULT+tx_con_tte _        alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)+tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]+  = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc++tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon+tx_con_dtt _  DEFAULT = Just DEFAULT+tx_con_dtt tc (LitAlt (LitNumber LitNumInt i))+   | tag >= 0+   , tag < n_data_cons+   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)+   | otherwise+   = Nothing+   where+     tag         = fromInteger i :: ConTagZ+     n_data_cons = tyConFamilySize tc+     data_cons   = tyConDataCons tc++tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt)+++{- Note [caseRules for tagToEnum]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to transform+   case tagToEnum# x of+     False -> e1+     True  -> e2+into+   case x of+     0# -> e1+     1# -> e2++See #8317.   This rule eliminates a lot of boilerplate. For+  if (x>y) then e2 else e1+we generate+  case tagToEnum# (x ># y) of+    False -> e1+    True  -> e2+and it is nice to then get rid of the tagToEnum#.++Beware (#14768): avoid the temptation to map constructor 0 to+DEFAULT, in the hope of getting this+  case (x ># y) of+    DEFAULT -> e1+    1#      -> e2+That fails utterly in the case of+   data Colour = Red | Green | Blue+   case tagToEnum x of+      DEFAULT -> e1+      Red     -> e2++We don't want to get this!+   case x of+      DEFAULT -> e1+      DEFAULT -> e2++Instead, when possible, we turn one branch into DEFAULT in+GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases]+in that module.++Note [caseRules for dataToTag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [DataToTag overview] in GHC.Tc.Instance.Class.++We want to transform+  case dataToTagSmall# x of+    DEFAULT -> e1+    1# -> e2+into+  case x of+    DEFAULT -> e1+    (:) _ _ -> e2++(Note the need for some wildcard binders in the 'cons' case.)++This transformation often enables further optimisation via+case-flattening and case-of-known-constructor and can be very+important for code using derived Eq instances.++We can apply this transformation only when we can easily get the+constructors from the type at which dataToTagSmall# is used.  And we+cannot apply this transformation at "type data"-related types without+breaking invariant I1 from Note [Type data declarations] in+GHC.Rename.Module.  That leaves exactly the types satisfying condition+DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class.++All of the above applies identically for `dataToTagLarge#`.  And+thanks to wrinkle DTW5, there is no need to worry about large-tag+arguments for `dataToTagSmall#`; those cause undefined behavior anyway.+++Note [Unreachable caseRules alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Take care if we see something like+  case dataToTag x of+    DEFAULT -> e1+    -1# -> e2+    100 -> e3+because there isn't a data constructor with tag -1 or 100. In this case the+out-of-range alternative is dead code -- we know the range of tags for x.++Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating+an alternative that is unreachable.++You may wonder how this can happen: check out #15436.+-}
+ GHC/Core/Opt/ConstantFold.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Core.Opt.ConstantFold where++import GHC.Prelude+import GHC.Core+import GHC.Builtin.PrimOps+import GHC.Types.Name++primOpRules ::  Name -> PrimOp -> Maybe CoreRule
+ GHC/Core/Opt/CprAnal.hs view
@@ -0,0 +1,1315 @@+{-# LANGUAGE MultiWayIf #-}++-- | 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+import GHC.Core.FamInstEnv+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Utils+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.Seq+import GHC.Core.TyCon+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.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+    cpr_ty'+      | cpr_ty == topCprType                    = topCprType -- cheap case first+      | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors]+      | otherwise                               = cpr_ty++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+    ids = filter isId bndrs+    env_alt+      | DataAlt dc <- con+      , CprType arity cpr <- scrut_ty+      , arity == 0 -- See Note [Dead code may contain type confusions]+      = 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 ids sigs)+      | otherwise+      = extendSigEnvAllSame env ids topCprSig+    (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+-- ^ A /very/ simple termination analysis.+exprTerminates e+  | exprIsHNF e            = Terminates+  | exprOkForSpeculation e = Terminates+  | otherwise              = MightDiverge+  -- Annoyingly, we have to check both for HNF and ok-for-spec.+  --   * `I# (x# *# 2#)` is ok-for-spec, but not in HNF. Still worth CPR'ing!+  --   * `lvl` is an HNF if its unfolding is evaluated+  --     (perhaps `lvl = I# 0#` at top-level). But, tiresomely, it is never+  --     ok-for-spec due to Note [exprOkForSpeculation and evaluated variables].++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]+  | Just rhs <- dataConWrapUnfolding_maybe 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)]   -- Info about /value/ arguments+                        -> 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]+  = -- pprTraceWith "cprTransformDataConWork" (\r -> ppr con <+> ppr wkr_arity <+> ppr args <+> ppr r) $+    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++isRecNewTyConApp :: AnalEnv -> Type -> Bool+-- See Note [CPR for recursive newtype constructors]+isRecNewTyConApp env ty+  --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined+  | Just (tc, tc_args) <- splitTyConApp_maybe ty =+      if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args+         -> isRecNewTyConApp env rhs+         | Just dc <- newTyConDataCon_maybe tc+         -> ae_rec_dc env dc == DefinitelyRecursive+         | otherwise+         -> False+  | otherwise = False++--+-- * 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)++    -- If fixed-point iteration does not yield a result we use this instead+    -- See Note [Safe abortion in the fixed-point iteration]+    abort :: (AnalEnv, [(Id,CoreExpr)])+    abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_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')+      | n == 10        = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort+      | 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 [Dead code may contain type confusions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In T23862, we have a nested case match that looks like this++  data CheckSingleton (check :: Bool) where+    Checked :: CheckSingleton True+    Unchecked :: CheckSingleton False+  data family Result (check :: Bool) a+  data instance Result True a = CheckedResult a+  newtype instance Result True a = UncheckedResult a++  case m () of Checked co1 ->+    case m () of Unchecked co2 ->+      case ((\_ -> True)+             |> .. UncheckedResult ..+             |> sym co2+             |> co1) :: Result True (Bool -> Bool) of+        CheckedResult f -> CheckedResult (f True)++Clearly, the innermost case is dead code, because the `Checked` and `Unchecked`+cases are apart.+However, both constructors introduce mutually contradictory coercions `co1` and+`co2` along which GHC generates a type confusion:++  1. (\_ -> True) :: Bool -> Bool+  2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool)+  3. |> ... sym co1 ... :: Result check (Bool -> Bool)+  4. |> ... co2 ... :: Result True (Bool -> Bool)++Note that we started with a function, injected into `Result` via a newtype+instance and then match on it with a datatype instance.++We have to handle this case gracefully in `cprAnalAlt`, where for the innermost+case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that+abstracts the function `(\_ -> True)` with arity 1.+In this case, don't pretend we know anything about the fields of `CheckedResult`!++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+  = -- pprTrace "cprAnalBind" (ppr id <+> ppr sig <+> ppr sig')+    (id `setIdCprSig` sig',       rhs', env')+  where+    (rhs_ty, rhs')  = cprAnal env rhs+    -- possibly trim thunk CPR info+    rhs_ty'+      -- See Note [CPR for thunks]+      | rhs_ty == topCprType = topCprType -- cheap case first+      | 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.isRecDataType+  }++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 give recursive data constructors or casts representing recursive newtype constructors+    the CPR property (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.+Specifically:++* For data constructors, in `cprTransformDataConWork` we check for a recursive+  data constructor by calling `ae_rec_dc env`, which is just a memoised version+  of `isRecDataCon`.  See Note [Detecting recursive data constructors]+* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype+  by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`.+  See Note [CPR for recursive newtype constructors]++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.+ D. If `ty = f a`, then look into `f` and `a`+ E. If `ty = ty' |> co`, then look into `ty'`++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, literals or coercion types because we are+     ultimately looking for value-level recursion.+     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 for recursive newtype constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A newtype constructor is considered recursive iff the data constructor of the+equivalent datatype definition is recursive.+See Note [CPR for recursive data constructors].+Detection is a bit complicated by the fact that newtype constructor applications+reflect as Casts in Core:++  newtype List a = C (Maybe (a, List a))+  xs = C (Just (0, C Nothing))+  ==> {desugar to Core}+  xs = Just (0, Nothing |> sym N:List) |> sym N:List++So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than+in `cprTransformDataConWork` as for data constructors.++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.++-}
+ GHC/Core/Opt/DmdAnal.hs view
@@ -0,0 +1,2751 @@+{-+(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.Types.Demand   -- All of it++import GHC.Core+import GHC.Core.DataCon+import GHC.Core.Utils+import GHC.Core.TyCon+import GHC.Core.Type+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.Multiplicity ( scaledThing )+import GHC.Core.FamInstEnv+import GHC.Core.Opt.Arity ( typeArity )+import GHC.Core.Opt.WorkWrap.Utils++import GHC.Builtin.Names+import GHC.Builtin.PrimOps+import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )++import GHC.Types.Unique.Set+import GHC.Types.Unique.MemoFun+import GHC.Types.RepType+import GHC.Types.ForeignCall ( isSafeForeignCall )+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable++import Data.List        ( mapAccumL )++{-+************************************************************************+*                                                                      *+\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 laziness (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 (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'++    cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]+    cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')++    keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv+    -- See Note [Absence analysis for stable unfoldings and RULES]+    -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in+    -- orphan RULES+    keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids))++    is_root :: Id -> Bool+    is_root id = isExportedId id || elemVarSet id rule_fvs++    rule_fvs :: IdSet+    rule_fvs = rulesRhsFreeIds rules++demandRoot :: AnalEnv -> Id -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoot env id = fst (dmdAnalStar env topDmd (Var id))++demandRoots :: AnalEnv -> [Id] -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)++demandRootSet :: AnalEnv -> IdSet -> DmdEnv+demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)+  -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative++-- | 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_rhs     id rhs anal_body+  _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind   anal_body+  where+    env_rhs = enterDFun bind env++-- | 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 (addInScopeAnalEnv env id)+    -- See Note [Bringing a new variable into scope]+    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 `plusDmdType` demandRootSet env 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', weak_fv, id1, rhs1) <-+        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs+    -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only)+  Rec pairs+    | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' weak_fv pairs' Rec+  where+    do_rest env' weak_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                          = addWeakFVs body_ty weak_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+  | definitelyUnliftedType (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+            -> (DmdEnv, 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]+  = (multDmdEnv n' (discardArgDmds 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 (noArgsDmdType (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` 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 (addInScopeAnalEnv env var) dmd body+        -- See Note [Bringing a new variable into scope]+    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 (addInScopeAnalEnv env var) body_dmd body+        -- See Note [Bringing a new variable into scope]+        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+        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+        -- See Note [Bringing a new variable into scope]+        WithDmdType rhs_ty rhs'           = dmdAnal rhs_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` discardArgDmds 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)+        | let tc = dataConTyCon dc+        , assertPpr (not (isNewTyCon tc)) (ppr dc) True  -- DataAlt is never newtype+        , Nothing <- tyConSingleDataCon_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               = scrut_ty `plusDmdType` discardArgDmds alt_ty2++    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 <- fn+  , Just op    <- isPrimOpId_maybe f+  , op /= RaiseIOOp+  = False -- 2. in the Note+  | Var f <- fn+  , f `hasKey` seqHashKey+  = False -- 3. in the Note+  | Var f <- fn+  , Just fcall <- isFCallId_maybe f+  , not (isSafeForeignCall fcall)+  = False -- 4. in the Note+  | otherwise+  = True  -- _. in the Note+  where+    (fn, _) = collectArgs e++-- | 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)+  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+    -- See Note [Bringing a new variable into scope]+  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_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 the PrimOp-like `seq#`, cf. Note [seq# magic].+  4. 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. `seq#` used to be a primop that did not throw a precise exception.+     We keep it that way for back-compat.+     See the implementation bits of Note [seq# magic] in GHC.Types.Id.Make.+  4. 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. `seq#` used to be a PrimOp and we want to stay backwards compatible.+  4. 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.++You might think that we should check for side-effects rather than just for+precise exceptions. Right you are! See Note [Side-effects and strictness]+for why we unfortunately do not.++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 [DmdSig: demand signatures, and demand-sig arity] 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]+  | Just rhs <- dataConWrapUnfolding_maybe 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 `floatifyDmd`: 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 (floatifyDmd (C_11 :* sd))+        | 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]) $+    noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))++{- *********************************************************************+*                                                                      *+                      Binding right-hand sides+*                                                                      *+********************************************************************* -}++-- | An environment in which all demands are weak according to 'isWeakDmd'.+-- See Note [Lazy and unleashable free variables].+type WeakDmds = VarEnv Demand++-- | @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, WeakDmds, 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_sd id rhs+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $+    (final_env, weak_fvs, final_id, final_rhs)+  where+    ww_arity = workWrapArity id rhs+      -- See Note [Worker/wrapper arity and join points] point (1)++    body_sd | isJoinId id = let_sd+            | otherwise   = topSubDmd+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in GHC.Core+      --     ww_arity matches the join arity of the join point++    adjusted_body_sd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_sd+      -- See Note [Unboxed demand on function bodies returning small products]++    rhs_sd = mkCalledOnceDmds ww_arity adjusted_body_sd++    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs+    DmdType rhs_env rhs_dmds = rhs_dmd_ty+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity+                                                      rhs_dmds (de_div rhs_env) rhs'++    dmd_sig_arity = ww_arity + strictCallArity body_sd+    sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)+          -- strictCallArity is > 0 only for join points+          -- See Note [mkDmdSigForArity]++    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_env1 = case rec_flag of+                Recursive    -> reuseEnv rhs_env+                NonRecursive -> rhs_env++    -- See Note [Absence analysis for stable unfoldings and RULES]+    rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)++    -- See Note [Lazy and unleashable free variables]+    !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2++splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)+splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)+  where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs++-- | 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] <- canUnboxTyCon tc   -- tc is not a newtype+      , 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: see `body_sd` in`dmdAnalRhsSig`.  When analysing+a join point, we can analyse its body (after stripping off the join binders,+here just 'y') with the demand from the entire join-binding (written `let_sd`+here).++Another win for join points!  #13543.++BUT see Note [Worker/wrapper arity and join points].++Note we may analyse the rhs of a join point with a demand that is either+bigger than, or smaller than, the number of lambdas syntactically visible.+* More lambdas than call demands:+       join j x = \p q r -> blah in ...+  in a context with demand Top.++* More call demands than lambdas:+       (join j x = h in ..(j 2)..(j 3)) a b c++Note [Worker/wrapper arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    (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 we will analyse j's body, namely+   \y. error "urk"+with demand C(C(1,L)).  See `rhs_sd` in `dmdAnalRhsSig`.  That will produce+a demand signature of <A><A>b: and indeed `j` diverges when given two arguments.++BUT we do /not/ want to worker/wrapper `j` with two arguments.  Suppose we have+     join j2 :: Int -> Int -> blah+          j2 x = rhs+     in ...(j2 3)...(j2 4)...++where j2's join-arity is 1, so calls to `j` will all have /one/ argument.+Suppose the entire expression is in a called context (like `j` above) and `j2`+gets the demand signature <1!P(L)><1!P(L)>, that is, strict in both arguments.++we worker/wrapper'd `j2` with two args we'd get+     join $wj2 x# y# = let x = I# x#; y = I# y# in rhs+          j2 x = \y. case x of I# x# -> case y of I# y# -> $wj2 x# y#+     in ...(j2 3)...(j2 4)...+But now `$wj2`is no longer a join point. Boo.++Instead if we w/w at all, we want to do so only with /one/ argument:+     join $wj2 x# = let x = I# x# in rhs+          j2 x = case x of I# x# -> $wj2 x#+     in ...(j2 3)...(j2 4)...+Now all is fine.  BUT in `finaliseArgBoxities` we should trim y's boxity,+to reflect the fact tta we aren't going to unbox `y` at all.++Conclusion:++(1) The "worker/wrapper arity" of an Id is+    * For non-join-points: idArity+    * The join points: the join arity (Id part only of course)+    This is the number of args we will use in worker/wrapper.+    See `ww_arity` in `dmdAnalRhsSig`, and the function `workWrapArity`.++(2) A join point's demand-signature arity may exceed the Id's worker/wrapper+    arity.  See the `arity_ok` assertion in `mkWwBodies`.++(3) In `finaliseArgBoxities`, do trimBoxity on any argument demands beyond+    the worker/wrapper arity.++(4) In WorkWrap.splitFun, make sure we split based on the worker/wrapper+    arity (re)-computed by workWrapArity.++Note [The demand for the RHS of a binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_sd` in+which to analyse `rhs`.++The demand we use is:++* Ordinary bindings: a call-demand of depth (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.  E.g. for+      f = g+  we want to use a threshold arity based on g, not 0!++  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: a call-demand of depth (value-binder subset of JoinArity),+  wrapped around the incoming demand for the entire expression; see+  Note [Demand analysis for join points]++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 [DmdSig: demand signatures, and demand-sig arity].++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 [mkDmdSigForArity]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = if expensive x+         then \y. blah1+         else \y. blah2+We will analyse the body with demand C(1L), reflecting the single visible+argument x.  But dmdAnal will return a DmdType looking like+    DmdType fvs [x-dmd, y-dmd]+because it has seen two lambdas, \x and \y. Since the length of the argument+demands in a DmdSig gives the "threshold" for applying the signature+(see Note [DmdSig: demand signatures, and demand-sig arity] in GHC.Types.Demand)+we must trim that DmdType to just+    DmdSig (DmdTypte fvs [x-dmd])+when making that DmdType into the DmdSig for f.  This trimming is the job of+`mkDmdSigForArity`.++Alternative.  An alternative would be be to ensure that if+    (dmd_ty, e') = dmdAnal env subdmd e+then the length dmds in dmd_ty is always less than (or maybe equal to?) the+call-depth of subdmd.  To do that we'd need to adjust the Lam case of dmdAnal.+Probably not hard, but a job for another day; see discussion on !12873, #23113,+and #21392.++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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Among others, tickets #18638 and #23208 show that it's really important to treat+stable unfoldings as demanded. 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, treat every free variable as a+/demand root/, that is: Analyse it as if it was a variable occurring in a+'topDmd' context. This is done in `demandRoot` (which we also use for exported+top-level ids). Do the same for Ids free in the RHS of any RULES for f.++Wrinkles:++  (W1) 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.++  (W2) You might wonder why we don't simply take the free vars of the+    unfolding/RULE and map them to topDmd. The reason is that any of the free vars+    might have demand signatures themselves that in turn demand transitive free+    variables and that we hence need to unleash! This came up in #23208.+    Consider++       err :: Int -> b+       err = error "really important message"++       sg :: Int -> Int+       sg _ = case err of {}  -- Str=<1B>b {err:->S}++       g :: a -> a  -- g is exported+       g x = x+       {-# RULES "g" g @Int = sg #-}++    Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur+    in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`+    because it occurs in the RULEs of `g` (which is exported), we better unleash+    the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'+    for `sg`, failing to unleash the signature and hence observed an absent+    error instead of the `really important message`.++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 /actually/+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 [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+                    -> [Demand] -> Divergence+                    -> CoreExpr -> ([Demand], CoreExpr)+-- POSTCONDITION:+-- If:    (dmds', rhs') = finaliseArgBoxitities ... dmds .. rhs+-- Then:+--     dmds' is the same as dmds (including length), except for boxity info+--     rhs'  is the same as rhs, except for dmd info on lambda binders+-- NB: For join points, length dmds might be greater than ww_arity+finaliseArgBoxities env fn ww_arity arg_dmds div rhs++  -- Check for an OPAQUE function: see Note [OPAQUE pragma]+  -- In that case, trim off all boxity info from argument demands+  -- and demand info on lambda binders+  -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+  | isOpaquePragma (idInlinePragma fn)+  , let trimmed_arg_dmds = map trimBoxity arg_dmds+  = (trimmed_arg_dmds, set_lam_dmds trimmed_arg_dmds rhs)++  -- Check that we have enough visible binders to match the+  -- ww arity; if not, we won't do worker/wrapper+  -- This happens if we have simply  {f = g} or a PAP {f = h 13}+  -- we simply want to give f the same demand signature as g+  -- How can such bindings arise?  Perhaps from {-# NOLINE[2] f #-},+  -- or if the call to `f` is currently not-applied (map f xs).+  -- It's a bit of a corner case.  Anyway for now we pass on the+  -- unadulterated demands from the RHS, without any boxity trimming.+  | ww_arity > count isId bndrs+  = (arg_dmds, rhs)++  -- The normal case+  | otherwise+  = -- pprTrace "finaliseArgBoxities" (+    -- vcat [text "function:" <+> ppr fn+    --        , text "max" <+> ppr max_wkr_args+    --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))+    --        , text "dmds after: " <+>  ppr arg_dmds' ]) $+    (arg_dmds', set_lam_dmds arg_dmds' rhs)+    -- set_lam_dmds: 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+       -- NB: in the interesting code path, count isId bndrs >= ww_arity++    arg_triples :: [(Type, StrictnessMark, Demand)]+    arg_triples = take ww_arity $+                  [ (idType bndr, NotMarkedStrict, get_dmd bndr)+                  | bndr <- bndrs, isRuntimeVar bndr ]++    arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds)+                -- If ww_arity < length arg_dmds, the leftover ones+                -- will not be w/w'd, so trimBoxity them+                -- See Note [Worker/wrapper arity and join points] point (3)++    -- 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, ww_arg_dmds) = go_args (MkB max_wkr_args remaining_budget) arg_triples+    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]++    get_dmd :: Id -> Demand+    get_dmd bndr+      | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],+      | otherwise = dmd                --     case (B)+      where+        dmd = idDemandInfo bndr++    -- 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)++    set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr+    -- Attach the demands to the outer lambdas of this expression+    set_lam_dmds (dmd:dmds) (Lam v e)+      | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e)+      | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e)+    set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co+       -- This case happens for an OPAQUE function, which may look like+       --     f = (\x y. blah) |> co+       -- We give it strictness but no boxity (#22502)+    set_lam_dmds _ e = e+       -- In the OPAQUE case, the list of demands at this point might be+       -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997).++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, WeakDmds, [(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, WeakDmds, [(Id,CoreExpr)])+    abort = (env, weak_fv', zapped_pairs)+      where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs)+            -- Note [Lazy and unleashable free variables]+            weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs'+            weak_fv'     = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_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, WeakDmds, [(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, weak_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+        (weak_fv, pairs') = step first_round pairs+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])+    step first_round pairs = (weak_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)++        !((_,!weak_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, weak_fv) (id,rhs)+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $+            ((env', weak_fv'), (id', rhs'))+          where+            !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            !weak_fv'                    = plusVarEnv_C plusDmd weak_fv weak_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+*                                                                      *+********************************************************************* -}++noArgsDmdType :: DmdEnv -> DmdType+noArgsDmdType dmd_env = DmdType dmd_env []++coercionDmdEnv :: Coercion -> DmdEnv+coercionDmdEnv co = coercionsDmdEnv [co]++coercionsDmdEnv :: [Coercion] -> DmdEnv+coercionsDmdEnv cos+  = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos+  -- The VarSet from coVarsOfCos is really a VarEnv Var++addVarDmd :: DmdType -> Var -> Demand -> DmdType+addVarDmd (DmdType fv ds) var dmd+  = DmdType (addVarDmdEnv fv var dmd) ds++addWeakFVs :: DmdType -> WeakDmds -> DmdType+addWeakFVs dmd_ty weak_fvs+  = dmd_ty `plusDmdType` mkTermDmdEnv weak_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 weak_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.++setBndrsDemandInfo :: HasDebugCallStack => [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 "weak_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 "weak_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)+         }++-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun+-- binding. Part of the mechanism that detects+-- Note [Do not strictify a DFun's parameter dictionaries].+enterDFun :: CoreBind -> AnalEnv -> AnalEnv+enterDFun bind env+  | any isDFunId (bindersOf bind)+  = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } }+  | otherwise+  = env++emptySigEnv :: SigEnv+emptySigEnv = emptyVarEnv++-- | Extend an environment with the strictness sigs attached to the Ids+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++addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }++addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }++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 dictionary parameters strict]+      -- and Note [Do not strictify a DFun's parameter dictionaries]+      | dmd_strict_dicts (ae_opts env)+      = strictifyDictDmd id_ty dmd+      | otherwise+      = dmd++    fam_envs = ae_fam_envs env++{- Note [Bringing a new variable into scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = blah+   g = ...(\f. ...f...)...++In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,+not the top-level `f` (which will be in `ae_sigs`).  So it's very important+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.+Otherwise chaos results (#22718).++Note [Making dictionary parameters strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?++* Generally CBV is more efficient.++* A datatype dictionary is always non-bottom and never takes 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.++See #17758 for more background and perf numbers.++Wrinkles:++* 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!++* Strictifying DFuns risks destroying the invariant that DFuns never take much+  work to compute, so we don't do it.+  See Note [Do not strictify a DFun's parameter dictionaries] for details.++* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do+  so; see Note [Do not unbox class dictionaries].++The implementation is extremely simple: just make the strictness+analyser strictify the demand on a dictionary binder in+'findBndrDmd' if the binder does not belong to a DFun.++Note [Do not strictify a DFun's parameter dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker can tie recursive knots involving (non-recursive) DFuns, so+we must not strictify a DFun's parameter dictionaries (#22549).+T22549 has an example involving undecidable instances that <<loop>>s when we+strictify the DFun of, e.g., `$fEqSeqT`:++  Main.$fEqSeqT+    = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) ->+        GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad)+                                     ($c/= @m @a $dEq $dMonad)++  Rec {+    $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity+    $dEq_b = ... $dEq_a ... <another strict context due to DFun>+  }++If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a+giant, <<loop>>ing thunk.++To prevent that, we never strictify dictionary params when inside a DFun.+That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun.++See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather+similar example in #20836. We may never speculate *arguments* of (recursive)+DFun calls, likewise we should not mark *formal parameters* of recursive DFuns+as strict.++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.++-}
+ GHC/Core/Opt/Exitify.hs view
@@ -0,0 +1,503 @@+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.Builtin.Uniques+import GHC.Core+import GHC.Core.Utils+import GHC.Core.FVs+import GHC.Core.Type++import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Basic( JoinPointHood(..) )++import GHC.Utils.Monad.State.Strict+import GHC.Utils.Misc( mapSnd )++import GHC.Data.FastString++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+        , JoinPoint join_arity <- idJoinPointHood 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.++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.++-}
+ GHC/Core/Opt/FloatIn.hs view
@@ -0,0 +1,867 @@+{-+(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 )+import GHC.Types.Id         ( idType, isJoinId, idJoinPointHood )+import GHC.Types.Tickish+import GHC.Types.Var+import GHC.Types.Var.Set++import GHC.Utils.Misc+import GHC.Utils.Panic.Plain++import GHC.Utils.Outputable++import Data.List        ( mapAccumL )++{-+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  = DVarSet+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 normal dependency order+                                     --    (outermost binder first)+type RevFloatInBinds = [FloatInBind] -- In reverse dependency order+                                     --    (innermost binder first)++instance Outputable FloatInBind where+  ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs+                                                , text "fvs =" <+> ppr fvs ])++fiExpr :: Platform+       -> RevFloatInBinds   -- 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 $+    Cast (fiExpr platform e_drop expr) co+  where+    (drop_here, [e_drop])+      = sepBindsByDropPoint platform False to_drop+          (freeVarsOfAnn co_ann) [freeVarsOf expr]++{-+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 $+    mkTicks ticks $+    mkApps (fiExpr platform fun_drop ann_fun)+           (zipWithEqual (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_fvs = freeVarsOf ann_fun++    (drop_here, fun_drop : arg_drops)+       = sepBindsByDropPoint platform False to_drop+                             here_fvs (fun_fvs : arg_fvs)++         -- 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++    (here_fvs, arg_fvs) = mapAccumL add_arg here_fvs0 ann_args+    here_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 :: FreeVarSet -> CoreExprWithFVs -> (FreeVarSet,FreeVarSet)+    -- We can't float into some arguments, so put them into the here_fvs+    add_arg here_fvs (arg_fvs, arg)+      | noFloatIntoArg arg = (here_fvs `unionDVarSet` arg_fvs, emptyDVarSet)+      | otherwise          = (here_fvs, arg_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).++Floating in can /enhance/ join points.  Consider this (#3458)+    f2 x = let g :: Int -> Int+               g y = if y==0 then y+x else g (y-1)+           in case g x of+                0 -> True+                _ -> False++Here `g` is not a join point. But if we float inwards it becomes one!  We+float in; the occurrence analyser identifies `g` as a join point; the Simplifier+retains that property, so we get+    f2 x = case (joinrec+                    g y = if y==0 then y+x else g (y-1)+                 in jump g x) of+              0 -> True+              _ -> False++Now that outer case gets pushed into the RHS of the joinrec, giving+    f2 x = joinrec g y = if y==0+                         then case y+x of { 0 -> True; _ -> False }+                         else jump g (y-1)+           in jump g x+Nice!++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.++Note [Shadowing and name capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+    let x = y+1 in+    case p of+       (y:ys) -> ...x...+       [] -> blah+It is obviously bogus for FloatIn to transform to+    case p of+       (y:ys) -> ...(let x = y+1 in x)...+       [] -> blah+because the y is captured.  This doesn't happen much, because shadowing is+rare (see Note [Shadowing in Core]), but it did happen in #22662.++One solution would be to clone as we go.  But a simpler one is this:++  at a binding site (like that for (y:ys) above), abandon float-in for+  any floating bindings that mention the binders (y, ys in this case)++We achieve that by calling sepBindsByDropPoint with the binders in+the "used-here" set:++* In fiExpr (AnnLam ...).  For the body there is no need to delete+  the lambda-binders from the body_fvs, because any bindings that+  mention these binders will be dropped here anyway.++* In fiExpr (AnnCase ...). Remember to include the case_bndr in the+  binders.  Again, no need to delete the alt binders from the rhs+  free vars, because any bindings mentioning them will be dropped+  here unconditionally.+-}++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+  = wrapFloats drop_here $+    mkLams bndrs (fiExpr platform body_drop body)++  where+    (bndrs, body) = collectAnnBndrs lam+    body_fvs      = freeVarsOf body++    -- Why sepBindsByDropPoint? Because of potential capture+    -- See Note [Shadowing and name capture]+    (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop+                                  (mkDVarSet bndrs) [body_fvs]++{-+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.++In particular, we want to be able to transform++  case indexIntArray# arr i of vi {+    __DEFAULT -> case <# j n of _ {+      __DEFAULT -> False+      1# -> case indexIntArray# arr j of vj {+        __DEFAULT -> ... vi ... vj ...+      }+    }+  }++by floating in `indexIntArray# arr i` to produce++  case <# j n of _ {+    __DEFAULT -> False+    1# -> case indexIntArray# arr i of vi {+      __DEFAULT -> case indexIntArray# arr j of vj {+        __DEFAULT -> ... vi ... vj ...+      }+    }+  }++...which skips the `indexIntArray# arr i` call entirely in the out-of-bounds branch.++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 [Transformations affected by primop effects] in GHC.Builtin.PrimOps+  which explains:+   - We can float in or discard CanFail primops, but we can't float them out.+   - We don't want to discard a synchronous exception or side effect+     so we don't float those at all. Hence exprOkToDiscard.+   - 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 (CanFail), 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+  , exprOkToDiscard (deAnnotate scrut)+      -- See Note [Floating primops]+  = wrapFloats shared_binds $+    fiExpr platform (case_float : rhs_binds) rhs+  where+    case_float = FB all_bndrs scrut_fvs+                    (FloatCase scrut' case_bndr con alt_bndrs)+    scrut'     = fiExpr platform scrut_binds scrut+    rhs_fvs    = freeVarsOf rhs    -- No need to delete alt_bndrs+    scrut_fvs  = freeVarsOf scrut  -- See Note [Shadowing and name capture]+    all_bndrs  = mkDVarSet alt_bndrs `extendDVarSet` case_bndr++    (shared_binds, [scrut_binds, rhs_binds])+       = sepBindsByDropPoint platform False to_drop+                     all_bndrs [scrut_fvs, rhs_fvs]++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 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 to_drop+             all_alt_bndrs [scrut_fvs, all_alt_fvs]+             -- all_alt_bndrs: see Note [Shadowing and name capture]++        -- Float into the alts with the is_case flag set+    (drop_here2, alts_drops_s)+       = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs++    scrut_fvs = freeVarsOf scrut++    all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts+    ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs++    alts_fvs :: [DVarSet]+    alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts]+               -- No need to delete binders+               -- See Note [Shadowing and name capture]++    all_alt_fvs :: DVarSet+    all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs++    fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)++------------------+fiBind :: Platform+       -> RevFloatInBinds    -- Binds we're trying to drop+                             -- as far "inwards" as possible+       -> CoreBindWithFVs    -- Input binding+       -> DVarSet            -- Free in scope of binding+       -> ( RevFloatInBinds  -- Land these before+          , FloatInBind      -- The binding itself+          , RevFloatInBinds) -- Land these after++fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs+  = ( 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, [rhs_binds, body_binds])+        = sepBindsByDropPoint platform False to_drop+                      extra_fvs [rhs_fvs, body_fvs2]++        -- 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+  = ( 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, body_binds:rhss_binds)+        = sepBindsByDropPoint platform False to_drop+                       extra_fvs (body_fvs:rhss_fvs)++    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 :: [RevFloatInBinds]   -- 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 pairs to_drops ]++------------------+fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs platform to_drop bndr rhs+  | JoinPoint join_arity <- idJoinPointHood 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++  | definitelyUnliftedType (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 :: RevFloatInBinds -> SDoc+-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]++sepBindsByDropPoint+    :: Platform+    -> Bool                  -- True <=> is case expression+    -> RevFloatInBinds       -- Candidate floaters+    -> FreeVarSet            -- here_fvs: if these vars are free in a binding,+                             --   don't float that binding inside any drop point+    -> [FreeVarSet]          -- fork_fvs: one set of FVs per drop point+    -> ( RevFloatInBinds     -- Bindings which must not be floated inside+       , [RevFloatInBinds] ) -- Corresponds 1-1 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.+--+-- The here_fvs argument is used for two things:+-- * Avoid shadowing bugs: see Note [Shadowing and name capture]+-- * Drop some of the bindings at the top, e.g. of an application++type DropBox = (FreeVarSet, FloatInBinds)++dropBoxFloats :: DropBox -> RevFloatInBinds+dropBoxFloats (_, floats) = reverse floats++usedInDropBox :: DIdSet -> DropBox -> Bool+usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs++initDropBox :: DVarSet -> DropBox+initDropBox fvs = (fvs, [])++sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs+  | null floaters  -- Shortcut common case+  = ([], [[] | _ <- fork_fvs])++  | otherwise+  = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)+  where+    n_alts = length fork_fvs++    go :: RevFloatInBinds -> DropBox -> [DropBox]+       -> (RevFloatInBinds, [RevFloatInBinds])+        -- The *first* one in the pair is the drop_here set++    go [] here_box fork_boxes+        = (dropBoxFloats here_box, map dropBoxFloats fork_boxes)++    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes+        | drop_here = go binds (insert here_box) fork_boxes+        | otherwise = go binds here_box          new_fork_boxes+        where+          -- "here" means the group of bindings dropped at the top of the fork++          used_here     = bndrs `usedInDropBox` here_box+          used_in_flags = case fork_boxes of+                            []  -> []+                            [_] -> [True]  -- Push all bindings into a single branch+                                           -- No need to look at its free vars+                            _   -> map (bndrs `usedInDropBox`) fork_boxes+               -- Short-cut for the singleton case;+               -- used for lambdas and singleton cases++          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_alts > 1 && n_used_alts == n_alts)+                             -- Used in all, muliple branches, don't push+                          || (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_fork_boxes = zipWithEqual 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+++{- 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 :: RevFloatInBinds -> FreeVarSet+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds++fbFVs :: FloatInBind -> DVarSet+fbFVs (FB _ fvs _) = fvs++wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr+-- Remember RevFloatInBinds 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
+ GHC/Core/Opt/FloatOut.hs view
@@ -0,0 +1,681 @@+{-+(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, idJoinPointHood )+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.+++************************************************************************+*                                                                      *+\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 (floatExpr  e) of { (fse, floats_e, e') ->+    case (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             = 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 (floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | not (tickishCounts tickish) || tickishCanSplit tickish+  = case (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 (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 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 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+  | JoinPoint join_arity <- idJoinPointHood 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+  = 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 others)+  = FlS (a + lengthBag tops)+        (b + 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+                      !MajorEnv                 -- Other levels+     -- See Note [Representation of FloatBinds]++instance Outputable FloatBinds where+  ppr (FB fbs defs)+      = text "FB" <+> (braces $ vcat+           [ text "tops ="     <+> ppr fbs+           , text "non-tops =" <+> ppr defs ])++flattenTopFloats :: FloatBinds -> Bag CoreBind+flattenTopFloats (FB tops defs)+  = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $+    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 M.empty++unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds+unitCaseFloat (Level major minor) e b con bs+  = FB 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) b+  | isTopLvl lvl = FB (unitBag b) M.empty+  | otherwise    = FB emptyBag (M.singleton major (M.singleton minor floats))+  where+    floats = unitBag (FloatLet b)++plusFloats :: FloatBinds -> FloatBinds -> FloatBinds+plusFloats (FB t1 l1) (FB t2 l2)+  = FB (t1 `unionBags` t2) (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) (FB tops defns)+  = (FB tops (outer_maj `plusMajor` M.singleton major outer_min),+     here_min `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++wrapTick :: CoreTickish -> FloatBinds -> FloatBinds+wrapTick t (FB tops defns)+  = FB (mapBag wrap_bind tops)+       (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.
+ GHC/Core/Opt/LiberateCase.hs view
@@ -0,0 +1,460 @@+{-+(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.Core.Opt.Simplify.Inline+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 ...) .. }+        }
+ GHC/Core/Opt/Monad.hs view
@@ -0,0 +1,404 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++-}+++{-# LANGUAGE DeriveFunctor #-}++module GHC.Core.Opt.Monad (+    -- * Types used in core-to-core passes+    FloatOutSwitches(..),++    -- * The monad+    CoreM, runCoreM,++    mapDynFlagsCoreM, dropSimplCount,++    -- ** Reading from the monad+    getHscEnv, getModule,+    initRuleEnv, getExternalRuleBase,+    getDynFlags, getPackageFamInstEnv,+    getInteractiveContext,+    getUniqTag,+    getNamePprCtx, getSrcSpanM,++    -- ** Writing to the monad+    addSimplCount,++    -- ** Lifting into the monad+    liftIO, liftIOWithCount,++    -- ** Dealing with annotations+    getAnnotations, getFirstAnnotations,++    -- ** Screen output+    putMsg, putMsgS, errorMsg, msg,+    fatalErrorMsg, fatalErrorMsgS,+    debugTraceMsg, debugTraceMsgS,+  ) where++import GHC.Prelude hiding ( read )++import GHC.Driver.DynFlags+import GHC.Driver.Env++import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )+import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount )++import GHC.Types.Annotations+import GHC.Types.Unique.Supply+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Error++import GHC.Utils.Error ( errorDiagnostic )+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Logger+import GHC.Utils.Monad++import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )+import qualified GHC.Data.IOEnv  as IOEnv++import GHC.Runtime.Context ( InteractiveContext )++import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.External++import Data.Bifunctor ( bimap )+import Data.Dynamic+import Data.Maybe (listToMaybe)+import Data.Word+import Control.Monad+import Control.Applicative ( Alternative(..) )++data FloatOutSwitches = FloatOutSwitches+  { floatOutLambdas   :: Maybe Int  -- ^ Just n <=> float lambdas to top level, if+                                    -- doing so will abstract over n or fewer+                                    -- value variables+                                    -- Nothing <=> float all lambdas to top level,+                                    --             regardless of how many free variables+                                    -- Just 0 is the vanilla case: float a lambda+                                    --    iff it has no free vars++  , floatOutConstants :: Bool       -- ^ True <=> float constants to top level,+                                    --            even if they do not escape a lambda++  , floatOutOverSatApps :: Bool     -- ^ True <=> float out over-saturated applications+                                    --            based on arity information.+                                    -- See Note [Floating over-saturated applications]+                                    -- in GHC.Core.Opt.SetLevels+  , floatToTopLevelOnly :: Bool     -- ^ Allow floating to the top level only.++  , floatJoinsToTop :: Bool         -- ^ Float join points to top level if possible+                                    -- See Note [Floating join point bindings]+                                    --     in GHC.Core.Opt.SetLevels+  }+instance Outputable FloatOutSwitches where+    ppr = pprFloatOutSwitches++pprFloatOutSwitches :: FloatOutSwitches -> SDoc+pprFloatOutSwitches sw+  = text "FOS" <+> (braces $+     sep $ punctuate comma $+     [ text "Lam ="    <+> ppr (floatOutLambdas sw)+     , text "Consts =" <+> ppr (floatOutConstants sw)+     , text "JoinsToTop =" <+> ppr (floatJoinsToTop sw)+     , text "OverSatApps ="   <+> ppr (floatOutOverSatApps sw) ])++{-+************************************************************************+*                                                                      *+             Monad and carried data structure definitions+*                                                                      *+************************************************************************+-}++data CoreReader = CoreReader {+        cr_hsc_env             :: HscEnv,+        cr_rule_base           :: RuleBase,  -- Home package table rules+        cr_module              :: Module,+        cr_name_ppr_ctx        :: NamePprCtx,+        cr_loc                 :: SrcSpan,   -- Use this for log/error messages so they+                                             -- are at least tagged with the right source file+        cr_uniq_tag            :: !Char      -- Tag for creating unique values+}++-- Note: CoreWriter used to be defined with data, rather than newtype.  If it+-- is defined that way again, the cw_simpl_count field, at least, must be+-- strict to avoid a space leak (#7702).+newtype CoreWriter = CoreWriter {+        cw_simpl_count :: SimplCount+}++emptyWriter :: Bool -- ^ -ddump-simpl-stats+            -> CoreWriter+emptyWriter dump_simpl_stats = CoreWriter {+        cw_simpl_count = zeroSimplCount dump_simpl_stats+    }++plusWriter :: CoreWriter -> CoreWriter -> CoreWriter+plusWriter w1 w2 = CoreWriter {+        cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2)+    }++type CoreIOEnv = IOEnv CoreReader++-- | The monad used by Core-to-Core passes to register simplification statistics.+--  Also used to have common state (in the form of UniqueSupply) for generating Uniques.+newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }+    deriving (Functor)++instance Monad CoreM where+    mx >>= f = CoreM $ do+            (x, w1) <- unCoreM mx+            (y, w2) <- unCoreM (f x)+            let w = w1 `plusWriter` w2+            return $ seq w (y, w)+            -- forcing w before building the tuple avoids a space leak+            -- (#7702)++instance Applicative CoreM where+    pure x = CoreM $ nop x+    (<*>) = ap+    m *> k = m >>= \_ -> k++instance Alternative CoreM where+    empty   = CoreM Control.Applicative.empty+    m <|> n = CoreM (unCoreM m <|> unCoreM n)++instance MonadPlus CoreM++instance MonadUnique CoreM where+    getUniqueSupplyM = do+        tag <- read cr_uniq_tag+        liftIO $! mkSplitUniqSupply tag++    getUniqueM = do+        tag <- read cr_uniq_tag+        liftIO $! uniqFromTag tag++runCoreM :: HscEnv+         -> RuleBase+         -> Char -- ^ Mask+         -> Module+         -> NamePprCtx+         -> SrcSpan+         -> CoreM a+         -> IO (a, SimplCount)+runCoreM hsc_env rule_base tag mod name_ppr_ctx loc m+  = liftM extract $ runIOEnv reader $ unCoreM m+  where+    reader = CoreReader {+            cr_hsc_env = hsc_env,+            cr_rule_base = rule_base,+            cr_module = mod,+            cr_name_ppr_ctx = name_ppr_ctx,+            cr_loc = loc,+            cr_uniq_tag = tag+        }++    extract :: (a, CoreWriter) -> (a, SimplCount)+    extract (value, writer) = (value, cw_simpl_count writer)++{-+************************************************************************+*                                                                      *+             Core combinators, not exported+*                                                                      *+************************************************************************+-}++nop :: a -> CoreIOEnv (a, CoreWriter)+nop x = do+    logger <- hsc_logger . cr_hsc_env <$> getEnv+    return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats)++read :: (CoreReader -> a) -> CoreM a+read f = CoreM $ getEnv >>= (\r -> nop (f r))++write :: CoreWriter -> CoreM ()+write w = CoreM $ return ((), w)++-- \subsection{Lifting IO into the monad}++-- | Lift an 'IOEnv' operation into 'CoreM'+liftIOEnv :: CoreIOEnv a -> CoreM a+liftIOEnv mx = CoreM (mx >>= (\x -> nop x))++instance MonadIO CoreM where+    liftIO = liftIOEnv . IOEnv.liftIO++-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount'+liftIOWithCount :: IO (SimplCount, a) -> CoreM a+liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x)++{-+************************************************************************+*                                                                      *+             Reader, writer and state accessors+*                                                                      *+************************************************************************+-}++getHscEnv :: CoreM HscEnv+getHscEnv = read cr_hsc_env++getHomeRuleBase :: CoreM RuleBase+getHomeRuleBase = read cr_rule_base++initRuleEnv :: ModGuts -> CoreM RuleEnv+initRuleEnv guts+  = do { hpt_rules <- getHomeRuleBase+       ; eps_rules <- getExternalRuleBase+       ; return (mkRuleEnv guts eps_rules hpt_rules) }++getExternalRuleBase :: CoreM RuleBase+getExternalRuleBase = eps_rule_base <$> get_eps++getNamePprCtx :: CoreM NamePprCtx+getNamePprCtx = read cr_name_ppr_ctx++getSrcSpanM :: CoreM SrcSpan+getSrcSpanM = read cr_loc++addSimplCount :: SimplCount -> CoreM ()+addSimplCount count = write (CoreWriter { cw_simpl_count = count })++getUniqTag :: CoreM Char+getUniqTag = read cr_uniq_tag++-- Convenience accessors for useful fields of HscEnv++-- | Adjust the dyn flags passed to the argument action+mapDynFlagsCoreM :: (DynFlags -> DynFlags) -> CoreM a -> CoreM a+mapDynFlagsCoreM f m = CoreM $ do+  !e <- getEnv+  let !e' = e { cr_hsc_env = hscUpdateFlags f $ cr_hsc_env e }+  liftIO $ runIOEnv e' $! unCoreM m++-- | Drop the single count of the argument action so it doesn't effect+-- the total.+dropSimplCount :: CoreM a -> CoreM a+dropSimplCount m = CoreM $ do+  (a, _) <- unCoreM m+  unCoreM $ pure a++instance HasDynFlags CoreM where+    getDynFlags = fmap hsc_dflags getHscEnv++instance HasLogger CoreM where+    getLogger = fmap hsc_logger getHscEnv++instance HasModule CoreM where+    getModule = read cr_module++getInteractiveContext :: CoreM InteractiveContext+getInteractiveContext = hsc_IC <$> getHscEnv++getPackageFamInstEnv :: CoreM PackageFamInstEnv+getPackageFamInstEnv = eps_fam_inst_env <$> get_eps++get_eps :: CoreM ExternalPackageState+get_eps = do+    hsc_env <- getHscEnv+    liftIO $ hscEPS hsc_env++{-+************************************************************************+*                                                                      *+             Dealing with annotations+*                                                                      *+************************************************************************+-}++-- | Get all annotations of a given type. This happens lazily, that is+-- no deserialization will take place until the [a] is actually demanded and+-- the [a] can also be empty (the UniqFM is not filtered).+--+-- This should be done once at the start of a Core-to-Core pass that uses+-- annotations.+--+-- See Note [Annotations]+getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])+getAnnotations deserialize guts = do+     hsc_env <- getHscEnv+     ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts)+     return (deserializeAnns deserialize ann_env)++-- | Get at most one annotation of a given type per annotatable item.+getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv a, NameEnv a)+getFirstAnnotations deserialize guts+  = bimap mod name <$> getAnnotations deserialize guts+  where+    mod = mapMaybeModuleEnv (const listToMaybe)+    name = mapMaybeNameEnv listToMaybe++{-+Note [Annotations]+~~~~~~~~~~~~~~~~~~+A Core-to-Core pass that wants to make use of annotations calls+getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with+annotations of a specific type. This produces all annotations from interface+files read so far. However, annotations from interface files read during the+pass will not be visible until getAnnotations is called again. This is similar+to how rules work and probably isn't too bad.++The current implementation could be optimised a bit: when looking up+annotations for a thing from the HomePackageTable, we could search directly in+the module where the thing is defined rather than building one UniqFM which+contains all annotations we know of. This would work because annotations can+only be given to things defined in the same module. However, since we would+only want to deserialise every annotation once, we would have to build a cache+for every module in the HTP. In the end, it's probably not worth it as long as+we aren't using annotations heavily.++************************************************************************+*                                                                      *+                Direct screen output+*                                                                      *+************************************************************************+-}++msg :: MessageClass -> SDoc -> CoreM ()+msg msg_class doc = do+    logger <- getLogger+    loc    <- getSrcSpanM+    name_ppr_ctx <- getNamePprCtx+    let sty = case msg_class of+                MCDiagnostic _ _ _ -> err_sty+                MCDump             -> dump_sty+                _                  -> user_sty+        err_sty  = mkErrStyle name_ppr_ctx+        user_sty = mkUserStyle name_ppr_ctx AllTheWay+        dump_sty = mkDumpStyle name_ppr_ctx+    liftIO $ logMsg logger msg_class loc (withPprStyle sty doc)++-- | Output a String message to the screen+putMsgS :: String -> CoreM ()+putMsgS = putMsg . text++-- | Output a message to the screen+putMsg :: SDoc -> CoreM ()+putMsg = msg MCInfo++-- | Output an error to the screen. Does not cause the compiler to die.+errorMsg :: SDoc -> CoreM ()+errorMsg doc = msg errorDiagnostic doc++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsgS :: String -> CoreM ()+fatalErrorMsgS = fatalErrorMsg . text++-- | Output a fatal error to the screen. Does not cause the compiler to die.+fatalErrorMsg :: SDoc -> CoreM ()+fatalErrorMsg = msg MCFatal++-- | Output a string debugging message at verbosity level of @-v@ or higher+debugTraceMsgS :: String -> CoreM ()+debugTraceMsgS = debugTraceMsg . text++-- | Outputs a debugging message at verbosity level of @-v@ or higher+debugTraceMsg :: SDoc -> CoreM ()+debugTraceMsg = msg MCDump
+ GHC/Core/Opt/OccurAnal.hs view
@@ -0,0 +1,4075 @@+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}++{-# OPTIONS_GHC -fmax-worker-args=12 #-}+-- The -fmax-worker-args=12 is there because the main functions+-- are strict in the OccEnv, and it turned out that with the default settting+-- some functions would unbox the OccEnv ad some would not, depending on how+-- many /other/ arguments the function has.  Inconsistent unboxing is very+-- bad for performance, so I increased the limit to allow it to unbox+-- consistently.++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++module GHC.Core.Opt.OccurAnal (+    occurAnalysePgm,+    occurAnalyseExpr,+    zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap+  ) where++import GHC.Prelude hiding ( head, init, last, tail )++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          mkCastMCo, mkTicks )+import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )++import GHC.Data.Maybe( orElse )+import GHC.Data.Graph.Directed ( SCC(..), Node(..)+                               , stronglyConnCompFromEdgedVerticesUniq+                               , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig )++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Builtin.Names( runRWKey )+import GHC.Unit.Module( Module )++import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty (..))++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++-- | Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr :: CoreExpr -> CoreExpr+occurAnalyseExpr expr = expr'+  where+    WUD _ expr' = occAnal initOccEnv expr++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]           -- Local rules for imported Ids+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    WUD final_usage occ_anald_binds = go binds init_env+    WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- imp_rule_edges maps a top-level local binder 'f' to the+    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,+    -- where 'f' appears on the LHS+    --   e.g.  RULE foldr f = blah+    --         imp_rule_edges contains f :-> fvs(blah)+    -- We treat such RULES as extra rules for 'f'+    -- See Note [Preventing loops due to imported functions rules]+    imp_rule_edges :: ImpRuleEdges+    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv+                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $+                             exprsFreeIds args `delVarSetList` bndrs+                           | Rule { ru_act = act, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs } <- imp_rules+                                   -- Not BuiltinRules; see Note [Plugin rules]+                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]++    go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]+    go []           _   = WUD initial_uds []+    go (bind:binds) env = occAnalBind env TopLevel+                           imp_rule_edges bind (go binds) (++)++{- *********************************************************************+*                                                                      *+                IMP-RULES+         Local rules for imported functions+*                                                                      *+********************************************************************* -}++type ImpRuleEdges = IdEnv [(Activation, VarSet)]+    -- Mapping from a local Id 'f' to info about its IMP-RULES,+    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS+    -- We record (a) its Activation and (b) the RHS free vars+    -- See Note [IMP-RULES: local rules for imported functions]++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]+lookupImpRules imp_rule_edges bndr+  = case lookupVarEnv imp_rule_edges bndr of+      Nothing -> []+      Just vs -> vs++impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails+-- Variable mentioned in RHS of an IMP-RULE for the bndr,+-- whether active or not+impRulesScopeUsage imp_rules_info+  = foldr add emptyDetails imp_rules_info+  where+    add (_,vs) usage = addManyOccs usage vs++impRulesActiveFvs :: (Activation -> Bool) -> VarSet+                  -> [(Activation,VarSet)] -> VarSet+impRulesActiveFvs is_active bndr_set vs+  = foldr add emptyVarSet vs `intersectVarSet` bndr_set+  where+    add (act,vs) acc | is_active act = vs `unionVarSet` acc+                     | otherwise     = acc++{- Note [IMP-RULES: local rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We quite often have+  * A /local/ rule+  * for an /imported/ function+like this:+  foo x = blah+  {-# RULE "map/foo" forall xs. map foo xs = xs #-}+We call them IMP-RULES.  They are important in practice, and occur a+lot in the libraries.++IMP-RULES are held in mg_rules of ModGuts, and passed in to+occurAnalysePgm.++Main Invariant:++* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS+  just like a RULE for f.++Note [IMP-RULES: unavoidable loops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [IMP-RULES: unavoidable+loops].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+  g_spec = .....(B.g Int).....+  RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might not be+as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'+because it mentions 'filterFB' on the LHS.  This is the Main Invariant+in Note [IMP-RULES: local rules for imported functions].++So, during loop-breaker analysis:++- for each active RULE for a local function 'f' we add an edge between+  'f' and the local FVs of the rule RHS++- for each active RULE for an *imported* function we add dependency+  edges between the *local* FVS of the rule LHS and the *local* FVS of+  the rule RHS.++Even with this extra hack we aren't always going to get things+right. For example, it might be that the rule LHS mentions an imported+Id, and another module has a RULE that can rewrite that imported Id to+one of our local Ids.++Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to+something at the bottom:++        foo = ...(B.f @Int)...+        $sf = blah+        RULE:  B.f @Int = $sf++Applying this rule makes foo refer to $sf, although foo doesn't appear to+depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the+dependency might be more indirect. For example, foo might mention C.t+rather than B.f, where C.t eventually inlines to B.f.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.f in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++This is a legitimate situation where the need for glomming doesn't+point to any problems. However, when GHC is compiled with -DDEBUG, we+produce a warning addressed to the GHC developers just in case we+require glomming due to an out-of-order reference that is caused by+some earlier transformation stage misbehaving.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.  We+avoid infinite inlinings by choosing loop breakers, and ensuring that+a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Note [Forming Rec groups]+   Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.+   Wrap the details in a LetrecNode, ready for SCC analysis.+   All this is done by makeNode.++   The edges of this graph are the "scope edges".++2. Do SCC-analysis on these Nodes:+   - Each CyclicSCC will become a new Rec+   - Each AcyclicSCC will become a new NonRec++   The key property is that every free variable of a binding is+   accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each AcyclicSCC, just make a NonRec binding.++4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++   To do so, form the loop-breaker graph, do SCC analysis. For each+   CyclicSCC we choose a loop breaker, delete all edges to that node,+   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]+   for the details+++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+The key point about the "Forming Rec groups" step is that it /preserves+scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if+we start with+  Rec { f = ...h...+      ; g = ...f...+      ; h = ...f... }+we can split into SCCs+  Rec { f = ...h...+      ; h = ..f... }+  NonRec { g = ...f... }++We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g+uses f", no matter how indirectly.  We do a SCC analysis with an edge+f -> g if "f mentions g". That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f, whether active or inactive+       Note [Rules are extra RHSs]+  c) or the LHS or a rule for f, whether active or inactive+       Note [Rule dependency info]+  d) the RHS of an /active/ local IMP-RULE+       Note [IMP-RULES: local rules for imported functions]++(b) and (c) apply regardless of the activation of the RULE, because even if+the rule is inactive its free variables must be bound.  But (d) doesn't need+to worry about this because IMP-RULES are always notionally at the bottom+of the file.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    So in Example [eftInt], eftInt and eftIntFB will be put in the+    same Rec, even though their 'main' RHSs are both non-recursive.++    We must also include inactive rules, so that their free vars+    remain in scope.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++Note [TailUsageDetails when forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is+computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`.+That is because the binding might still become a *non-recursive join point* in+the AcyclicSCC case of dependency analysis!+Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get+a regular, adjusted UsageDetails.+See Note [Join points and unfoldings/rules] for more details on the contract.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to a stable unfolding+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.+Hence the transitive rule_fv_env stuff described in+Note [Rules and loop breakers].++Note [Occurrence analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two somewhat artificial programs (#22404)++  Program (P1)                      Program (P2)+  ------------------------------    -------------------------------------+  let v = <small thunk> in          let v = <small thunk> in+                                    join j = case v of (a,b) -> a+  in case x of                      in case x of+        A -> case v of (a,b) -> a         A -> j+        B -> case v of (a,b) -> a         B -> j+        C -> case v of (a,b) -> b         C -> case v of (a,b) -> b+        D -> []                           D -> []++In (P1), `v` gets allocated, as a thunk, every time this code is executed.  But+notice that `v` occurs at most once in any case branch; the occurrence analyser+spots this and returns a OneOcc{ occ_n_br = 3 } for `v`.  Then the code in+GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three+use sites, and discards the let-binding.  That way, we avoid allocating `v` in+the A,B,C branches (though we still compute it of course), and branch D+doesn't involve <small thunk> at all.  This sometimes makes a Really Big+Difference.++In (P2) we have shared the common RHS of A, B, in a join point `j`.  We would+like to inline `v` in just the same way as in (P1).  But the usual strategy+for let bindings is conservative and uses `andUDs` to combine usage from j's+RHS to its body; as if `j` was called on every code path (once, albeit).  In+the case of (P2), we'll get ManyOccs for `v`.  Important optimisation lost!++Solving this problem makes the Simplifier less fragile.  For example,+the Simplifier might inline `j`, and convert (P2) into (P1)... or it might+not, depending in a perhaps-fragile way on the size of the join point.+I was motivated to implement this feature of the occurrence analyser+when trying to make optimisation join points simpler and more robust+(see e.g. #23627).++The occurrence analyser therefore has clever code that behaves just as+if you inlined `j` at all its call sites.  Here is a tricky variant+to keep in mind:++  Program (P3)+  -------------------------------+    join j = case v of (a,b) -> a+    in case f v of+          A -> j+          B -> j+          C -> []++If you mentally inline `j` you'll see that `v` is used twice on the path+through A, so it should have ManyOcc.  Bear this case in mind!++* We treat /non-recursive/ join points specially. Recursive join points are+  treated like any other letrec, as before.  Moreover, we only give this special+  treatment to /pre-existing/ non-recursive join points, not the ones that we+  discover for the first time in this sweep of the occurrence analyser.++* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps+  each in-scope non-recursive join point, such as `j` above, to+  a "zeroed form" of its RHS's usage details. The "zeroed form"+    * deletes ManyOccs+    * maps a OneOcc to OneOcc{ occ_n_br = 0 }+  In our example, occ_join_points will be extended with+      [j :-> [v :-> OneOcc{occ_n_br=0}]]+  See addJoinPoint.++* At an occurrence of a join point, we do everything as normal, but add in the+  UsageDetails from the occ_join_points.  See mkOneOcc.++* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use+  `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from+  the body.++Here are the consequences++* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed+  form, the occ_n_br field of a OneOcc binder still counts the number of+  /actual lexical occurrences/ of the variable.  In Program P2, for example,+  `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3.+  There are two lexical occurrences of `v`!+  (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.)++* In the tricky (P3) we'll get an `andUDs` of+    * OneOcc{occ_n_br=0} from the occurrences of `j`)+    * OneOcc{occ_n_br=1} from the (f v)+  These are `andUDs` together in `addOccInfo`, and hence+  `v` gets ManyOccs, just as it should.  Clever!++There are a couple of tricky wrinkles++(W1) Consider this example which shadows `j`:+          join j = rhs in+          in case x of { K j -> ..j..; ... }+     Clearly when we come to the pattern `K j` we must drop the `j`+     entry in occ_join_points.++     This is done by `drop_shadowed_joins` in `addInScope`.++(W2) Consider this example which shadows `v`:+          join j = ...v...+          in case x of { K v -> ..j..; ... }++     We can't make j's occurrences in the K alternative give rise to an+     occurrence of `v` (via occ_join_points), because it'll just be deleted by+     the `K v` pattern.  Yikes.  This is rare because shadowing is rare, but+     it definitely can happen.  Solution: when bringing `v` into scope at+     the `K v` pattern, chuck out of occ_join_points any elements whose+     UsageDetails mentions `v`.  Instead, just `andUDs` all that usage in+     right here.++     This requires work in two places.+     * In `preprocess_env`, we detect if the newly-bound variables intersect+       the free vars of occ_join_points.  (These free vars are conveniently+       simply the domain of the OccInfoEnv for that join point.) If so,+       we zap the entire occ_join_points.+     * In `postprcess_uds`, we add the chucked-out join points to the+       returned UsageDetails, with `andUDs`.++(W3) Consider this example, which shadows `j`, but this time in an argument+              join j = rhs+              in f (case x of { K j -> ...; ... })+     We can zap the entire occ_join_points when looking at the argument,+     because `j` can't posibly occur -- it's a join point!  And the smaller+     occ_join_points is, the better.  Smaller to look up in mkOneOcc, and+     more important, less looking-up when checking (W2).++     This is done in setNonTailCtxt.  It's important /not/ to do this for+     join-point RHS's because of course `j` can occur there!++     NB: this is just about efficiency: it is always safe /not/ to zap the+     occ_join_points.++(W4) What if the join point binding has a stable unfolding, or RULES?+     They are just alternative right-hand sides, and at each call site we+     will use only one of them. So again, we can use `orUDs` to combine+     usage info from all these alternatives RHSs.++Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3).++Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Join arity prediction based on joinRhsArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, the join arity from tail occurrences of a join point (O) may be+higher or lower than the manifest join arity of the join body (M). E.g.,++  -- M > O:+  let f x y = x + y              -- M = 2+  in if b then f 1 else f 2      -- O = 1+  ==> { Contify for join arity 1 }+  join f x = \y -> x + y+  in if b then jump f 1 else jump f 2++  -- M < O+  let f = id                     -- M = 0+  in if ... then f 12 else f 13  -- O = 1+  ==> { Contify for join arity 1, eta-expand f }+  join f x = id x+  in if b then jump f 12 else jump f 13++But for *recursive* let, it is crucial that both arities match up, consider++  letrec f x y = if ... then f x else True+  in f 42++Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump+would not happen in a tail context! Contification is invalid here.+So indeed it is crucial to demand that M=O.++(Side note: Actually, we could be more specific: Let O1 be the join arity of+occurrences from the letrec RHS and O2 the join arity from the let body. Then+we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later.+M=O is the specific case where we don't want to eta-expand. Neither the join+points paper nor GHC does this at the moment.)++We can capitalise on this observation and conclude that *if* f could become a+joinrec (without eta-expansion), it will have join arity M.+Now, M is just the result of 'joinRhsArity', a rather simple, local analysis.+It is also the join arity inside the 'TailUsageDetails' returned by+'occAnalLamTail', so we can predict join arity without doing any fixed-point+iteration or really doing any deep traversal of let body or RHS at all.+We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'.++All this is quite apparent if you look at the contification transformation in+Fig. 5 of "Compiling without Continuations" (which does not account for+eta-expansion at all, mind you). The letrec case looks like this++  letrec f = /\as.\xs. L[us] in L'[es]+    ... and a bunch of conditions establishing that f only occurs+        in app heads of join arity (len as + len xs) inside us and es ...++The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However,+for non-recursive functions, this is the definition of contification from the+paper:++  let f = /\as.\xs.u in L[es]     ... conditions ...++Note that u could be a lambda itself, as we have seen. No relationship between M+and O to exploit here.++Note [Join points and unfoldings/rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let j2 y = blah+   let j x = j2 (x+x)+       {-# INLINE [2] j #-}+   in case e of { A -> j 1; B -> ...; C -> j 2 }++Before j is inlined, we'll have occurrences of j2 in+both j's RHS and in its stable unfolding.  We want to discover+j2 as a join point. So 'occAnalUnfolding' returns an unadjusted+'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the+unfolding to the actual join arity using the same 'adjustTailArity' as for+the RHS, see Note [Adjusting right-hand sides].++Same with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+  let k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 y = j y #-}+      k x y = x + 2 * y+  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }++We identify k as a join point, and we want j to be a join point too.+Without the RULE it would be, and we don't want the RULE to mess it+up.  So provided the join-point arity of k matches the args of the+rule we can allow the tail-call info from the RHS of the rule to+propagate.++* Note that the join arity of the RHS and that of the unfolding or RULE might+  mismatch:++    let j x y = j2 (x+x)+        {-# INLINE[2] j = \x. g #-}+        {-# RULE forall x y z. j x y z = h 17 #-}+    in j 1 2++  So it is crucial that we adjust each TailUsageDetails individually+  with the actual join arity 2 here before we combine with `andUDs`.+  Here, that means losing tail call info on `g` and `h`.++* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for+  RHS, unfolding and RULE combined. Clearly, if they don't agree on their join+  arity, we have to do some adjusting. We choose to adjust to the join arity+  of the RHS, because that is likely the join arity that the join point will+  have; see Note [Join arity prediction based on joinRhsArity].++  If the guess is correct, then tail calls in the RHS are preserved; a necessary+  condition for the whole binding becoming a joinrec.+  The guess can only be incorrect in the 'AcyclicSCC' case when the binding+  becomes a non-recursive join point with a different join arity. But then the+  eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will+  be with a different join arity and destroy unsound tail call info with+  'markNonTail'.++* Wrinkle for RULES.  Suppose the example was a bit different:+      let j :: Int -> Int+          j y = 2 * y+          k :: Int -> Int -> Int+          {-# RULES "SPEC k 0" k 0 = j #-}+          k x y = x + 2 * y+      in ...+  If we eta-expanded the rule all would be well, but as it stands the+  one arg of the rule don't match the join-point arity of 2.++  Conceivably we could notice that a potential join point would have+  an "undersaturated" rule and account for it. This would mean we+  could make something that's been specialised a join point, for+  instance. But local bindings are rarely specialised, and being+  overly cautious about rules only costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++  This appears to be very rare in practice. TODO Perhaps we should gather+  statistics to be sure.++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllNonTail' *unless* the binding is for a join point, and+     the TailUsageDetails from the RHS has the right join arity; e.g.+        join j x y = case ... of+                       A -> j2 p+                       B -> j2 q+        in j a b+     Here we want the tail calls to j2 to be tail calls of the whole expression+  b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must+return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage'+once join-point-hood has been decided and eventual one-shot annotations have+been added through 'markNonRecJoinOneShots'.++It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed+perform a similar sequence of steps. Thus, here is an interleaving of events+of both functions, serving as a specification:++  1. Call 'occAnalLamTail' to find usage information for the RHS.+     Recursive case:     'makeNode'+     Non-recursive case: 'occAnalNonRecBind'+  2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`.+      Same whether recursive or not.)+  3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+     Cyclic  Recursive case:  'mkLoopBreakerNodes'+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`+     Non-recursive case:      'occAnalNonRecBind'+  4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g.,+     FloatOut sees one-shot annotations on lambdas+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`  calls 'adjustNonRecRhs'+     Non-recursive case:      'occAnalNonRecBind'        calls 'adjustNonRecRhs'+  5. Call 'adjustTailUsage' accordingly.+     Cyclic Recursive case:   'tagRecBinders'+     Acyclic Recursive case:  'adjustNonRecRhs'+     Non-recursive case:      'adjustNonRecRhs'+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind+  :: OccEnv+  -> TopLevelFlag+  -> ImpRuleEdges+  -> CoreBind+  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+  -> ([CoreBind] -> r -> r)          -- How to combine the scope with new binds+  -> WithUsageDetails r              -- Of the whole let(rec)++occAnalBind env lvl ire (Rec pairs) thing_inside combine+  = addInScopeList env (map fst pairs) $ \env ->+    let WUD body_uds body'  = thing_inside env+        WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds+    in WUD bind_uds (combine binds' body')++occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine+  | isTyVar bndr      -- A type let; we don't gather usage info+  = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside+    in WUD body_uds (combine [NonRec bndr rhs] res)++  -- /Existing/ non-recursive join points+  -- See Note [Occurrence analysis for join points]+  | mb_join@(JoinPoint {}) <- idJoinPointHood bndr+  = -- Analyse the RHS and /then/ the body+    let -- Analyse the rhs first, generating rhs_uds+        !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs+        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of+                                           -- Note [Occurrence analysis for join points]++        -- Now analyse the body, adding the join point+        -- into the environment with addJoinPoint+        !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env ->+                                      thing_inside (addJoinPoint env bndr' rhs_uds)+    in+    if isDeadOcc occ     -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else WUD (rhs_uds `orUDs` body_uds)    -- Note `orUDs`+             (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']+                      body)++  -- The normal case, including newly-discovered join points+  -- Analyse the body and /then/ the RHS+  | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside+  = if isDeadOcc occ   -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else let+        -- Get the join info from the *new* decision; NB: bndr is not already a JoinId+        -- See Note [Join points and unfoldings/rules]+        -- => join arity O of Note [Join arity prediction based on joinRhsArity]+        (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr++        !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs+    in WUD (foldr andUDs body_uds rhs_uds_s)      -- Note `andUDs`+           (combine [NonRec final_bndr rhs'] body)++-----------------+occAnalNonRecBody :: OccEnv -> Id+                  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+                  -> (WithUsageDetails (OccInfo, r))+occAnalNonRecBody env bndr thing_inside+  = addInScopeOne env bndr $ \env ->+    let !(WUD inner_uds res) = thing_inside env+        !occ = lookupLetOccInfo inner_uds bndr+    in WUD inner_uds (occ, res)++-----------------+occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges+                -> JoinPointHood -> Id -> CoreExpr+                 -> (NonEmpty UsageDetails, Id, CoreExpr)+occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs+  | null rules, null imp_rule_infos+  =  -- Fast path for common case of no rules. This is only worth+     -- 0.1% perf on average, but it's also only a line or two of code+    ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs )+  | otherwise+  = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )+  where+    --------- Right hand side ---------+    -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have+    --    join j = Just (f x) in ...+    -- we do not want to float the (f x) to+    --    let y = f x in join j = Just y in ...+    -- That's that OccRhs would do; but there's no point because+    -- j will never be scrutinised.+    rhs_env  = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs+    rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf++    -- See Note [Join arity prediction based on joinRhsArity]+    -- Match join arity O from mb_join_arity with manifest join arity M as+    -- returned by of occAnalLamTail. It's totally OK for them to mismatch;+    -- hence adjust the UDs from the RHS+    WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $+                                occAnalLamTail rhs_env rhs+    final_bndr_with_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'+                                 `setIdUnfolding` unf1+    final_bndr_no_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdUnfolding` unf1++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = idUnfolding bndr+    WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity mb_join unf_tuds++    --------- Rules ---------+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    -- and Note [Join points and unfoldings/rules]+    rules        = idCoreRules bndr+    rules_w_uds  = map (occAnalRule rhs_env) rules+    rules'       = map fstOf3 rules_w_uds+    imp_rule_infos = lookupImpRules imp_rule_edges bndr+    imp_rule_uds   = [impRulesScopeUsage imp_rule_infos]+         -- imp_rule_uds: consider+         --     h = ...+         --     g = ...+         --     RULE map g = h+         -- Then we want to ensure that h is in scope everywhere+         -- that g is (since the RULE might turn g into h), so+         -- we make g mention h.++    adj_rule_uds :: [UsageDetails]+    adj_rule_uds = imp_rule_uds +++                   [ l `andUDs` adjustTailArity mb_join r+                   | (_,l,r) <- rules_w_uds ]++mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl+-- Precondition: Id is not a join point+mkNonRecRhsCtxt lvl bndr unf+  | certainly_inline = OccVanilla -- See Note [Cascading inlines]+  | otherwise        = OccRhs+  where+    certainly_inline -- See Note [Cascading inlines]+      = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind+        -- has set the OccInfo for this binder before calling occAnalNonRecRhs+        case idOccInfo bndr of+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }+            -> active && not stable_unf && not top_bottoming+          _ -> False++    active     = isAlwaysActive (idInlineActivation bndr)+    stable_unf = isStableUnfolding unf+    top_bottoming = isTopLevel lvl && isDeadEndId bndr++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> WithUsageDetails [CoreBind]+-- For a recursive group, we+--      * occ-analyse all the RHSs+--      * compute strongly-connected components+--      * feed those components to occAnalRec+-- See Note [Recursive bindings: the grand plan]+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs+  where+    sccs :: [SCC NodeDetails]+    sccs = stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs++    bndrs    = map fst pairs+    bndr_set = mkVarSet bndrs++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC NodeDetails+           -> WithUsageDetails [CoreBind]+           -> WithUsageDetails [CoreBind]++-- The NonRec case is just like a Let (NonRec ...) above+occAnalRec !_ lvl+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))+           (WUD body_uds binds)+  | isDeadOcc occ  -- Check for dead code: see Note [Dead code]+  = WUD body_uds binds+  | otherwise+  = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr+        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds+    in WUD (body_uds `andUDs` rhs_uds')+           (NonRec bndr' rhs' : binds)+  where+    occ = lookupLetOccInfo body_uds bndr++-- The Rec case is the interesting one+-- See Note [Recursive bindings: the grand plan]+-- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)+  | not (any needed details_s)+  = -- Check for dead code: see Note [Dead code]+    -- NB: Only look at body_uds, ignoring uses in the SCC+    WUD body_uds binds++  | otherwise+  = WUD final_uds (Rec pairs : binds)+  where+    all_simple = all nd_simple details_s++    needed :: NodeDetails -> Bool+    needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env+    body_env = ud_env body_uds++    ------------------------------+    -- Make the nodes for the loop-breaker analysis+    -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LoopBreakerNode]+    WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak_fvs details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []+          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []+          -- In the common case when all are "simple" (no rules at all)+          -- the loop_breaker_nodes will include all the scope edges+          -- so a SCC computation would yield a single CyclicSCC result;+          -- and reOrderNodes deals with exactly that case.+          -- Saves a SCC analysis in a common case+++{- *********************************************************************+*                                                                      *+                Loop breaking+*                                                                      *+********************************************************************* -}++{- Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does+loop-breaking on each CyclicSCC of the original program:++* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC++* loopBreakNodes: Do SCC analysis on it++* reOrderNodes: For each CyclicSCC, pick a loop breaker+    * Delete edges to that loop breaker+    * Do another SCC analysis on that reduced SCC+    * Repeat++To form the loop-breaker graph, we construct a new set of Nodes, the+"loop-breaker nodes", with the same details but different edges, the+"loop-breaker edges".  The loop-breaker nodes have both more and fewer+dependencies than the scope edges:++  More edges:+     If f calls g, and g has an active rule that mentions h then+     we add an edge from f -> h.  See Note [Rules and loop breakers].++  Fewer edges: we only include dependencies+     * only on /active/ rules,+     * on rule /RHSs/ (not LHSs)++The scope edges, by contrast, must be much more inclusive.++The nd_simple flag tracks the common case when a binding has no RULES+at all, in which case the loop-breaker edges will be identical to the+scope edges.++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note [inl_fvs]+~~~~~~~~~~~~~~+Note that the loop-breaker graph includes edges for occurrences in+/both/ the RHS /and/ the stable unfolding.  Consider this, which actually+occurred when compiling BooleanFormula.hs in GHC:++  Rec { lvl1 = go+      ; lvl2[StableUnf = go] = lvl1+      ; go = ...go...lvl2... }++From the point of view of infinite inlining, we need only these edges:+   lvl1 :-> go+   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining+   go   :-> go, lvl2++But the danger is that, lacking any edge to lvl1, we'll put it at the+end thus+  Rec { lvl2[ StableUnf = go] = lvl1+      ; go[LoopBreaker] = ...go...lvl2... }+      ; lvl1[Occ=Once]  = go }++And now the Simplifer will try to use PreInlineUnconditionally on lvl1+(which occurs just once), but because it is last we won't actually+substitute in lvl2.  Sigh.++To avoid this possibility, we include edges from lvl2 to /both/ its+stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in+makeNode.  Maybe we could be more clever, but it's very much a corner+case.++Note [Weak loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is a last nasty wrinkle.  Suppose we have++    Rec { f = f_rhs+          RULE f [] = g++          h = h_rhs+          g = h+          ...more... }++Remember that we simplify the RULES before any RHS (see Note+[Rules are visible in their own rec group] above).++So we must *not* postInlineUnconditionally 'g', even though+its RHS turns out to be trivial.  (I'm assuming that 'g' is+not chosen as a loop breaker.)  Why not?  Because then we+drop the binding for 'g', which leaves it out of scope in the+RULE!++Here's a somewhat different example of the same thing+    Rec { q = r+        ; r = ...p...+        ; p = p_rhs+          RULE p [] = q }+Here the RULE is "below" q, but we *still* can't postInlineUnconditionally+q, because the RULE for p is active throughout.  So the RHS of r+might rewrite to     r = ...q...+So q must remain in scope in the output program!++We "solve" this by:++    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+    iff q is a mentioned in the RHS of any RULE (active on not)+    in the Rec group++Note the "active or not" comment; even if a RULE is inactive, we+want its RHS free vars to stay alive (#20820)!++A normal "strong" loop breaker has IAmLoopBreaker False.  So:++                                Inline  postInlineUnconditionally+strong   IAmLoopBreaker False    no      no+weak     IAmLoopBreaker True     yes     no+         other                   yes     yes++The **sole** reason for this kind of loop breaker is so that+postInlineUnconditionally does not fire.  Ugh.++Annoyingly, since we simplify the rules *first* we'll never inline+q into p's RULE.  That trivial binding for q will hang around until+we discard the rule.  Yuk.  But it's rare.++Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we form the loop-breaker graph (Step 4 in Note [Recursive+bindings: the grand plan]), we must be careful about RULEs.++For a start, we want a loop breaker to cut every cycle, so inactive+rules play no part; we need only consider /active/ rules.+See Note [Finding rule RHS free vars]++The second point is more subtle.  A RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Opt.Simplify++Hence, if+    f's RHS (or its stable unfolding if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules]. So our plan is this:++   Take the free variables of f's RHS, and augment it with all the+   variables reachable by a transitive sequence RULES from those+   starting points.++That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.+Wrinkles:++* We only consider /active/ rules. See Note [Finding rule RHS free vars]++* We need only consider free vars that are also binders in this Rec+  group.  See also Note [Finding rule RHS free vars]++* We only consider variables free in the *RHS* of the rule, in+  contrast to the way we build the Rec group in the first place (Note+  [Rule dependency info])++* Why "transitive sequence of rules"?  Because active rules apply+  unconditionally, without checking loop-breaker-ness.+ See Note [Loop breaker dependencies].++Note [Finding rule RHS free vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this real example from Data Parallel Haskell+     tagZero :: Array Int -> Array Tag+     {-# INLINE [1] tagZeroes #-}+     tagZero xs = pmap (\x -> fromBool (x==0)) xs++     {-# RULES "tagZero" [~1] forall xs n.+         pmap fromBool <blah blah> = tagZero xs #-}+So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+However, tagZero can only be inlined in phase 1 and later, while+the RULE is only active *before* phase 1.  So there's no problem.++To make this work, we look for the RHS free vars only for+*active* rules. That's the reason for the occ_rule_act field+of the OccEnv.++Note [loopBreakNodes]+~~~~~~~~~~~~~~~~~~~~~+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++type Binding = (Id,CoreExpr)++-- See Note [loopBreakNodes]+loopBreakNodes :: Int+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LoopBreakerNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+-- See Note [loopBreakNodes]+loopBreakNodes depth weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes)+  where+    go []         = binds+    go (scc:sccs) = loop_break_scc scc (go sccs)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds+          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds+reOrderNodes depth weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                               , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth weak_fvs unchosen $+    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (snd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding+nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs})+  = (set_id_occ bndr, rhs)++mk_loop_breaker :: Id -> Id+mk_loop_breaker bndr+  = bndr `setIdOccInfo` occ'+  where+    occ'      = strongLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> Id -> Id+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs bndr+  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'+  | otherwise                  = bndr+  where+    occ'      = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool                -- True <=> Too many iterations,+                                         --          so approximate+                  -> NodeScore           -- Best score so far+                  -> [LoopBreakerNode]   -- Nodes with this score+                  -> [LoopBreakerNode]   -- Nodes with higher scores+                  -> [LoopBreakerNode]   -- Unprocessed nodes+                  -> ([LoopBreakerNode], [LoopBreakerNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = snd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakers is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.+-- The Unique key is gotten from the Id.+type LetrecNode = Node Unique NodeDetails++-- | Node details as consumed by 'occAnalRec'.+data NodeDetails+  = ND { nd_bndr :: Id          -- Binder++       , nd_rhs  :: !(WithTailUsageDetails CoreExpr)+         -- ^ RHS, already occ-analysed+         -- With TailUsageDetails from RHS, and RULES, and stable unfoldings,+         -- ignoring phase (ie assuming all are active).+         -- NB: Unadjusted TailUsageDetails, as if this Node becomes a+         -- non-recursive join point!+         -- See Note [TailUsageDetails when forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_simple :: Bool      -- True iff this binding has no local RULES+                                -- If all nodes are simple we don't need a loop-breaker+                                -- dep-anal before reconstructing.++       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                 -- in the RHS of any rule (active or not) for this bndr+                                 -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                        -- in the RHS of an active rule for this bndr+                                        -- See Note [Rules and loop breakers]+  }++instance Outputable NodeDetails where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr uds+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "simple =" <+> ppr (nd_simple nd)+                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)+             ])+            where+               WTUD uds _ = nd_rhs nd++-- | Digraph with simplified and completely occurrence analysed+-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.+type LoopBreakerNode = Node Unique SimpleNodeDetails++-- | Condensed variant of 'NodeDetails' needed during loop breaking.+data SimpleNodeDetails+  = SND { snd_bndr  :: IdWithOccInfo  -- OccInfo accurate+        , snd_rhs   :: CoreExpr       -- properly occur-analysed+        , snd_score :: NodeScore+        }++instance Outputable SimpleNodeDetails where+   ppr nd = text "SND" <> braces+             (sep [ text "bndr =" <+> ppr (snd_bndr nd)+                  , text "score =" <+> ppr (snd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode !env imp_rule_edges bndr_set (bndr, rhs)+  = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $+    DigraphNode { node_payload      = details+                , node_key          = varUnique bndr+                , node_dependencies = nonDetKeysUniqSet scope_fvs }+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+  where+    details = ND { nd_bndr            = bndr'+                 , nd_rhs             = WTUD (TUD rhs_ja unadj_scope_uds) rhs'+                 , nd_inl             = inl_fvs+                 , nd_simple          = null rules_w_uds && null imp_rule_info+                 , nd_weak_fvs        = weak_fvs+                 , nd_active_rule_fvs = active_rule_fvs }++    bndr' | noBinderSwaps env = bndr  -- See Note [Unfoldings and rules]+          | otherwise         = bndr `setIdUnfolding`      unf'+                                     `setIdSpecialisation` mkRuleInfo rules'++    -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the+    --     JoinArity rhs_ja of unadj_rhs_uds.+    unadj_inl_uds   = unadj_rhs_uds `andUDs` adj_unf_uds+    unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    scope_fvs = udFreeVars bndr_set unadj_scope_uds+    -- scope_fvs: all occurrences from this binder: RHS, unfolding,+    --            and RULES, both LHS and RHS thereof, active or inactive++    inl_fvs  = udFreeVars bndr_set unadj_inl_uds+    -- inl_fvs: vars that would become free if the function was inlined.+    -- We conservatively approximate that by the free vars from the RHS+    -- and the unfolding together.+    -- See Note [inl_fvs]+++    --------- Right hand side ---------+    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    -- and Note [TailUsageDetails when forming Rec groups]+    -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because+    --   (a) we don't yet know the final joinpointhood. It might not become a+    --       join point after all!+    --   (b) we don't even know whether it stays a recursive RHS after the SCC+    --       analysis we are about to seed! So we can't markAllInsideLam in+    --       advance, because if it ends up as a non-recursive join point we'll+    --       consider it as one-shot and don't need to markAllInsideLam.+    -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage+    -- until occAnalRec. In effect, we pretend that the RHS becomes a+    -- non-recursive join point and fix up later with adjustTailUsage.+    rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs+            -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),+            -- it's safe to zap the occ_join_points, because they can't occur in RHS.+    WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs+      -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness+                               -- here because that is what we are setting!+    WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds+      -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M+      -- of Note [Join arity prediction based on joinRhsArity]++    --------- IMP-RULES --------+    is_active     = occ_rule_act env :: Activation -> Bool+    imp_rule_info = lookupImpRules imp_rule_edges bndr+    imp_rule_uds  = impRulesScopeUsage imp_rule_info+    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info++    --------- All rules --------+    -- See Note [Join points and unfoldings/rules]+    -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M+    -- of Note [Join arity prediction based on joinRhsArity]+    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)+                  | rule <- idCoreRules bndr+                  , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ]+    rules'      = map fstOf3 rules_w_uds++    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    -------- active_rule_fvs ------------+    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds+    add_active_rule (rule, _, rhs_uds) fvs+      | is_active (ruleActivation rule)+      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs+      | otherwise+      = fvs++    -------- weak_fvs ------------+    -- See Note [Weak loop breakers]+    weak_fvs = foldr add_rule emptyVarSet rules_w_uds+    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> UsageDetails   -- for BODY of let+                   -> [NodeDetails]+                   -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date+-- See Note [Choosing loop breakers]+-- This function primarily creates the Nodes for the+-- loop-breaker SCC analysis.  More specifically:+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes !env lvl body_uds details_s+  = WUD final_uds (zipWithEqual mk_lb_node details_s bndrs')+  where+    WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s++    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs+                      , nd_rhs = WTUD _ rhs }) new_bndr+      = DigraphNode { node_payload      = simple_nd+                    , node_key          = varUnique old_bndr+                    , node_dependencies = nonDetKeysUniqSet lb_deps }+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+      where+        simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }+        score  = nodeScore env new_bndr lb_deps nd+        lb_deps = extendFvs_ rule_fv_env inl_fvs+        -- See Note [Loop breaker dependencies]++    rule_fv_env :: IdEnv IdSet+    -- Maps a variable f to the variables from this group+    --      reachable by a sequence of RULES starting with f+    -- Domain is *subset* of bound vars (others have no rule fvs)+    -- See Note [Finding rule RHS free vars]+    -- Why transClosureFV?  See Note [Loop breaker dependencies]+    rule_fv_env = transClosureFV $ mkVarEnv $+                  [ (b, rule_fvs)+                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+                  , not (isEmptyVarSet rule_fvs) ]++{- Note [Loop breaker dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop breaker dependencies of x in a recursive+group { f1 = e1; ...; fn = en } are:++- The "inline free variables" of f: the fi free in+  f's stable unfolding and RHS; see Note [inl_fvs]++- Any fi reachable from those inline free variables by a sequence+  of RULE rewrites.  Remember, rule rewriting is not affected+  by fi being a loop breaker, so we have to take the transitive+  closure in case f is the only possible loop breaker in the loop.++  Hence rule_fv_env.  We need only account for /active/ rules.+-}++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder with new occ-info+          -> VarSet    -- Loop-breaker dependencies+          -> NodeDetails+          -> NodeScore+nodeScore !env new_bndr lb_deps+          (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs })++  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- old_unf+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding old_unf+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    -- is_lb: see Note [Loop breakers, node scoring, and stability]+    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)++    old_unf = realIdUnfolding old_bndr+    can_unfold = canUnfold old_unf+    rhs        = case old_unf of+                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                     | isStableSource src+                     -> unf_rhs+                   _ -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case old_unf of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs+++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)+    is_con_app _          = False         -- We will float the y out, so treat+                                          -- the x-binding as a con-app (#20941)++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore+-}++{- *********************************************************************+*                                                                      *+                  Lambda groups+*                                                                      *+********************************************************************* -}++{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations.++So the occurrence analyser collaborates with the simplifier to treat+a /lambda-group/ specially.   A lambda-group is a contiguous run of+lambda and casts, e.g.+    Lam x (Lam y (Cast (Lam z body) co))++* Occurrence analyser: we just mark each binder in the lambda-group+  (here: x,y,z) with its occurrence info in the *body* of the+  lambda-group.  See occAnalLamTail.++* Simplifier.  The simplifier is careful when partially applying+  lambda-groups. See the call to zapLambdaBndrs in+     GHC.Core.Opt.Simplify.simplExprF1+     GHC.Core.SimpleOpt.simple_app++* Why do we take care to account for intervening casts? Answer:+  currently we don't do eta-expansion and cast-swizzling in a stable+  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).+  So we can get+    f = \x. ((\y. ...x...y...) |> co)+  Now, since the lambdas aren't together, the occurrence analyser will+  say that x is OnceInLam.  Now if we have a call+    (f e1 |> co) e2+  we'll end up with+    let x = e1 in ...x..e2...+  and it'll take an extra iteration of the Simplifier to substitute for x.++A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity+recognises except that the latter looks through (some) ticks.  Maybe a lambda+group should also look through (some) ticks?+-}++isOneShotFun :: CoreExpr -> Bool+-- The top level lambdas, ignoring casts, of the expression+-- are all one-shot.  If there aren't any lambdas at all, this is True+isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e+isOneShotFun (Cast e _) = isOneShotFun e+isOneShotFun _          = True++zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear under the \z+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: `arg_count` includes both type and value args+zapLambdaBndrs fun arg_count+  = -- If the lambda is fully applied, leave it alone; if not+    -- zap the OccInfo on the lambdas that do have arguments,+    -- so they beta-reduce to use-many Lets rather than used-once ones.+    zap arg_count fun `orElse` fun+  where+    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr+    -- Nothing => No need to change the occ-info+    -- Just e  => Had to change+    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot+            | otherwise      = Just e   -- in which case no need to zap+    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }+    zap n (Lam b e)   = do { e' <- zap (n-1) e+                           ; return (Lam (zap_bndr b) e') }+    zap _ _           = Nothing  -- More arguments than lambdas++    zap_bndr b | isTyVar b = b+               | otherwise = zapLamIdInfo b++occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr+-- ^ See Note [Occurrence analysis for lambda binders].+-- It does the following:+--   * Sets one-shot info on the lambda binder from the OccEnv, and+--     removes that one-shot info from the OccEnv+--   * Sets the OccEnv to OccVanilla when going under a value lambda+--   * Tags each lambda with its occurrence information+--   * Walks through casts+--   * Package up the analysed lambda with its manifest join arity+--+-- This function does /not/ do+--   markAllInsideLam or+--   markAllNonTail+-- The caller does that, via adjustTailUsage (mostly calls go through+-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call+-- adjustTailUsage to discharge the assumed join arity.+--+-- In effect, the analysis result is for a non-recursive join point with+-- manifest arity and adjustTailUsage does the fixup.+-- See Note [Adjusting right-hand sides]+occAnalLamTail env expr+  = let !(WUD usage expr') = occ_anal_lam_tail env expr+    in WTUD (TUD (joinRhsArity expr) usage) expr'++occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr+-- Does not markInsideLam etc for the outmost batch of lambdas+occ_anal_lam_tail env expr@(Lam {})+  = go env [] expr+  where+    go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr+    go env rev_bndrs (Lam bndr body)+      | isTyVar bndr+      = go env (bndr:rev_bndrs) body+              -- Important: Unlike a value binder, do not modify occ_encl+              -- to OccVanilla, so that with a RHS like+              --   \(@ x) -> K @x (f @x)+              -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain+              -- from inlining f. See the beginning of Note [Cascading inlines].++      | otherwise+      = let (env_one_shots', bndr')+              = case occ_one_shots env of+                  []         -> ([],  bndr)+                  (os : oss) -> (oss, updOneShotInfo bndr os)+                  -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+                  -- one-shot info might be better than what we can infer, e.g.+                  -- due to explicit use of the magic 'oneShot' function.+                  -- See Note [oneShot magic]+            env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }+         in go env' (bndr':rev_bndrs) body++    go env rev_bndrs body+      = addInScope env rev_bndrs $ \env ->+        let !(WUD usage body') = occ_anal_lam_tail env body+            wrap_lam body bndr = Lam (tagLamBinder usage bndr) body+        in WUD (usage `addLamCoVarOccs` rev_bndrs)+               (foldl' wrap_lam body' rev_bndrs)++-- For casts, keep going in the same lambda-group+-- See Note [Occurrence analysis for lambda binders]+occ_anal_lam_tail env (Cast expr co)+  = let  WUD usage expr' = occ_anal_lam_tail env expr+         -- usage1: see Note [Gather occurrences of coercion variables]+         usage1 = addManyOccs usage (coVarsOfCo co)++         -- usage2: see Note [Occ-anal and cast worker/wrapper]+         usage2 = case expr of+                    Var {} | isRhsEnv env -> markAllMany usage1+                    _ -> usage1++         -- usage3: you might think this was not necessary, because of+         -- the markAllNonTail in adjustTailUsage; but not so!  For a+         -- join point, adjustTailUsage doesn't do this; yet if there is+         -- a cast, we must!  Also: why markAllNonTail?  See+         -- GHC.Core.Lint: Note Note [Join points and casts]+         usage3 = markAllNonTail usage2++    in WUD usage3 (Cast expr' co)++occ_anal_lam_tail env expr  -- Not Lam, not Cast+  = occAnal env expr++{- Note [Occ-anal and cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   y = e; x = y |> co+If we mark y as used-once, we'll inline y into x, and the Cast+worker/wrapper transform will float it straight back out again.  See+Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.++So in this particular case we want to mark 'y' as Many.  It's very+ad-hoc, but it's also simple.  It's also what would happen if we gave+the binding for x a stable unfolding (as we usually do for wrappers, thus+      y = e+      {-# INLINE x #-}+      x = y |> co+Now y appears twice -- once in x's stable unfolding, and once in x's+RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable+unfolding, which would obviate this Note; but that seems a bit of a+heavyweight solution.)++We only need to this in occAnalLamTail, not occAnal, because the top leve+of a right hand side is handled by occAnalLamTail.+-}+++{- *********************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+********************************************************************* -}++occAnalUnfolding :: OccEnv+                 -> Unfolding+                 -> WithTailUsageDetails Unfolding+-- Occurrence-analyse a stable unfolding;+-- discard a non-stable one altogether and return empty usage details.+occAnalUnfolding !env unf+  = case unf of+      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })+        | isStableSource src ->+            let+              WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs+              unf' = unf { uf_tmpl = rhs' }+            in WTUD (TUD rhs_ja (markAllMany uds)) unf'+              -- markAllMany: see Note [Occurrences in stable unfoldings]++        | otherwise -> WTUD (TUD 0 emptyDetails) unf+              -- For non-Stable unfoldings we leave them undisturbed, but+              -- don't count their usage because the simplifier will discard them.+              -- We leave them undisturbed because nodeScore uses their size info+              -- to guide its decisions.  It's ok to leave un-substituted+              -- expressions in the tree because all the variables that were in+              -- scope remain in scope; there is no cloning etc.++      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+        -> let WUD uds args' = addInScopeList env bndrs $ \ env ->+                               occAnalList env args+           in WTUD (TUD 0 uds) (unf { df_args = args' })+              -- No need to use tagLamBinders because we+              -- never inline DFuns so the occ-info on binders doesn't matter++      unf -> WTUD (TUD 0 emptyDetails) unf++occAnalRule :: OccEnv+             -> CoreRule+             -> (CoreRule,         -- Each (non-built-in) rule+                 UsageDetails,     -- Usage details for LHS+                 TailUsageDetails) -- Usage details for RHS+occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+  = (rule', lhs_uds', TUD rhs_ja rhs_uds')+  where+    rule' = rule { ru_args = args', ru_rhs = rhs' }++    WUD lhs_uds args' = addInScopeList env bndrs $ \env ->+                        occAnalList env args++    lhs_uds' = markAllManyNonTail lhs_uds+    WUD rhs_uds rhs' = addInScopeList env bndrs $ \env ->+                       occAnal env rhs+                          -- Note [Rules are extra RHSs]+                          -- Note [Rule dependency info]+    rhs_uds' = markAllMany rhs_uds+    rhs_ja = length args -- See Note [Join points and unfoldings/rules]++occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)++{- Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f p = BIG+    {-# INLINE g #-}+    g y = not (f y)+where this is the /only/ occurrence of 'f'.  So 'g' will get a stable+unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more.  Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many".+We still leave tail call information intact, though, as to not spoil+potential join points.++Note [Unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally unfoldings and rules are already occurrence-analysed, so we+don't want to reconstruct their trees; we just want to analyse them to+find how they use their free variables.++EXCEPT if there is a binder-swap going on, in which case we do want to+produce a new tree.++So we have a fast-path that keeps the old tree if the occ_bs_env is+empty.   This just saves a bit of allocation and reconstruction; not+a big deal.++Two tricky corners:++* Dead bindings (#22761). Supose we have+    Unfolding = \x. let y = foo in x+1+  which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+  the unfolding and produce /no/ occurrences of `foo` (since `y` is+  dead).  But if we discard the occ-analysed syntax tree (which we do on+  our fast path), and use the old one, we still /have/ an occurrence of+  `foo` -- and that can lead to out-of-scope variables (#22761).++  Solution: always keep occ-analysed trees in unfoldings and rules, so they+  have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.++* One-shot binders. Consider+     {- f has Stable unfolding \p q -> blah+        Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -}+     f = \x y. blah++   Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has+          occ_one_shots = [NoOneShortInfo, OneShotLam]+   This will put OneShotLam on the \y.  And it'll put it on the \q.  But the+   noBinderSwap check will mean that we discard this new occ-anal'd unfolding+   and keep the old one, with no OneShotInfo.++   This looks a little inconsistent, but the Stable unfolding is just used for+   inlinings; OneShotInfo isn't a lot of use here.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an OccRhs for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an OccVanilla context, not OccRhs.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.  See #24582 for an example of the two getting out of sync.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]+occAnalList !_   []    = WUD emptyDetails []+occAnalList env (e:es) = let+                          (WUD uds1 e') = occAnal env e+                          (WUD uds2 es') = occAnalList env es+                         in WUD (uds1 `andUDs` uds2) (e' : es')++occAnal :: OccEnv+        -> CoreExpr+        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids++occAnal !_   expr@(Lit _)  = WUD emptyDetails expr++occAnal env expr@(Var _) = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ expr@(Type ty)+  = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr+occAnal _ expr@(Coercion co)+  = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr+        -- See Note [Gather occurrences of coercion variables]++{- Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, for two reasons:++1. So that we can sort them into the right place when doing dependency analysis.++2. So that we know when they are surely dead.++It is useful to know when they a coercion variable is surely dead,+when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.+For example (#20143):++  case unsafeEqualityProof @blah of+     UnsafeRefl cv -> ...no use of cv...++Here we can discard the case, since unsafeEqualityProof always terminates.+But only if the coercion variable 'cv' is unused.++Another example from #15696: we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...+Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...++We can only  drop the case altogether if 'cv' is unused, which is not+the case here.++Conclusion: we need accurate dead-ness info for CoVars.+We gather CoVar occurrences from:++  * The (Type ty) and (Coercion co) cases of occAnal++  * The type 'ty' of a lambda-binder (\(x:ty). blah)+    See addCoVarOccs++But it is not necessary to gather CoVars from the types of other binders.++* For let-binders, if the type mentions a CoVar, so will the RHS (since+  it has the same type)++* For case-alt binders, if the type mentions a CoVar, so will the scrutinee+  (since it has the same type)+-}++occAnal env (Tick tickish body)+  = WUD usage' (Tick tickish body')+  where+    WUD usage body' = occAnal env body++    usage'+      | tickish `tickishScopesLike` SoftScope+      = usage  -- For soft-scoped ticks (including SourceNotes) we don't want+               -- to lose join-point-hood, so we don't mess with `usage` (#24078)++      -- For a non-soft tick scope, we can inline lambdas only, so we+      -- abandon tail calls, and do markAllInsideLam too: usage_lam++      | Breakpoint _ _ ids <- tickish+      = -- Never substitute for any of the Ids in a Breakpoint+        addManyOccs usage_lam (mkVarSet ids)++      | otherwise+      = usage_lam++    usage_lam = markAllNonTail (markAllInsideLam usage)++    -- TODO There may be ways to make ticks and join points play+    -- nicer together, but right now there are problems:+    --   let j x = ... in tick<t> (j 1)+    -- Making j a join point may cause the simplifier to drop t+    -- (if the tick is put into the continuation). So we don't+    -- count j 1 as a tail call.+    -- See #14242.++occAnal env (Cast expr co)+  = let  (WUD usage expr') = occAnal env expr+         usage1 = addManyOccs usage (coVarsOfCo co)+             -- usage2: see Note [Gather occurrences of coercion variables]+         usage2 = markAllNonTail usage1+             -- usage3: calls inside expr aren't tail calls any more+    in WUD usage2 (Cast expr' co)++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++occAnal env expr@(Lam {})+  = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail+    occAnalLamTail env expr++occAnal env (Case scrut bndr ty alts)+  = let+      WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut++      WUD alts_usage (tagged_bndr, alts')+         = addInScopeOne env bndr $ \env ->+           let alt_env = addBndrSwap scrut' bndr $+                         setTailCtxt env  -- Kill off OccRhs+               WUD alts_usage alts' = do_alts alt_env alts+               tagged_bndr = tagLamBinder alts_usage bndr+           in WUD alts_usage (tagged_bndr, alts')++      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage+                    -- Alts can have tail calls, but the scrutinee can't++    in WUD total_usage (Case scrut' tagged_bndr ty alts')+  where+    do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]+    do_alts _   []         = WUD emptyDetails []+    do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts')+      where+        WUD uds1 alt'  = do_alt  env alt+        WUD uds2 alts' = do_alts env alts++    do_alt !env (Alt con bndrs rhs)+      = addInScopeList env bndrs $ \ env ->+        let WUD rhs_usage rhs' = occAnal env rhs+            tagged_bndrs = tagLamBinders rhs_usage bndrs+        in                 -- See Note [Binders in case alternatives]+        WUD rhs_usage (Alt con tagged_bndrs rhs')++occAnal env (Let bind body)+  = occAnalBind env NotTopLevel noImpRuleEdges bind+                (\env -> occAnal env body) mkLets++occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]+            -> [OneShots]  -- Very commonly empty, notably prior to dmd anal+            -> WithUsageDetails CoreExpr+-- The `fun` argument is just an accumulating parameter,+-- the base for building the application we return+occAnalArgs !env fun args !one_shots+  = go emptyDetails fun args one_shots+  where+    env_args = setNonTailCtxt encl env++    -- Make bottoming functions interesting+    -- See Note [Bottoming function calls]+    encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut+         | otherwise                               = OccVanilla++    go uds fun [] _ = WUD uds fun+    go uds fun (arg:args) one_shots+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'+      where+        !(WUD arg_uds arg') = occAnal arg_env arg+        !(arg_env, one_shots')+            | isTypeArg arg+            = (env_args, one_shots)+            | otherwise+            = case one_shots of+                []                -> (env_args, []) -- Fast path; one_shots is often empty+                (os : one_shots') -> (setOneShots os env_args, one_shots')++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Bottoming function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let x = (a,b) in+   case p of+      A -> ...(error x)..+      B -> ...(ertor x)...++postInlineUnconditionally may duplicate x's binding, but sometimes it+does so only if the use site IsInteresting.  Pushing allocation into error+branches is good, so we try to make bottoming calls look interesting, by+setting occ_encl = OccScrut for such calls.++The slightly-artificial test T21128 is a good example.  It's probably+not a huge deal.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])+           -> WithUsageDetails (Expr CoreBndr)+-- Naked variables (not applied) end up here too+occAnalApp !env (Var fun, args, ticks)+  -- Account for join arity of runRW# continuation+  -- See Note [Simplification of runRW#]+  --+  -- NB: Do not be tempted to make the next (Var fun, args, tick)+  --     equation into an 'otherwise' clause for this equation+  --     The former has a bang-pattern to occ-anal the args, and+  --     we don't want to occ-anal them twice in the runRW# case!+  --     This caused #18296+  | fun `hasKey` runRWKey+  , [t1, t2, arg]  <- args+  , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg+  = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])++occAnalApp env (Var fun_id, args, ticks)+  = WUD all_uds (mkTicks ticks app')+  where+    -- Lots of banged bindings: this is a very heavily bit of code,+    -- so it pays not to make lots of thunks here, all of which+    -- will ultimately be forced.+    !(fun', fun_id')  = lookupBndrSwap env fun_id+    !(WUD args_uds app') = occAnalArgs env fun' args one_shots++    fun_uds = mkOneOcc env fun_id' int_cxt n_args+       -- NB: fun_uds is computed for fun_id', not fun_id+       -- See (BS1) in Note [The binder-swap substitution]++    all_uds = fun_uds `andUDs` final_args_uds++    !final_args_uds = markAllNonTail                              $+                      markAllInsideLamIf (isRhsEnv env && is_exp) $+                        -- isRhsEnv: see Note [OccEncl]+                      args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    !n_val_args = valArgCount args+    !n_args     = length args+    !int_cxt    = case occ_encl env of+                   OccScrut -> IsInteresting+                   _other   | n_val_args > 0 -> IsInteresting+                            | otherwise      -> NotInteresting++    !is_exp     = isExpandableApp fun_id n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs++    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = WUD (markAllNonTail (fun_uds `andUDs` args_uds))+                     (mkTicks ticks app')+  where+    !(WUD args_uds app') = occAnalArgs env fun' args []+    !(WUD fun_uds fun')  = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexes like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some OneShotLam items+        -- onto the context stack.++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  | n_val_args > 0+  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt+        , occ_encl      = OccVanilla }+          -- OccVanilla: the function part of the application+          -- is no longer on OccRhs or OccScrut+  | otherwise+  = env+  where+    n_val_args = valArgCount args+++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C(1,C(1,L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active+           , occ_rule_act   :: Activation -> Bool  -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           -- See Note [The binder-swap substitution]+           -- If  x :-> (y, co)  is in the env,+           -- then please replace x by (y |> mco)+           -- Invariant of course: idType x = exprType (y |> mco)+           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))+              -- Domain is Global and Local Ids+              -- Range is just Local Ids+           , occ_bs_rng  :: !VarSet+               -- Vars (TyVars and Ids) free in the range of occ_bs_env++             -- Usage details of the RHS of in-scope non-recursive join points+             -- Invariant: no Id maps to an empty OccInfoEnv+             -- See Note [Occurrence analysis for join points]+           , occ_join_points :: !JoinPointInfo+    }++type JoinPointInfo = IdEnv OccInfoEnv++-----------------------------+{- Note [OccEncl]+~~~~~~~~~~~~~~~~~+OccEncl is used to control whether to inline into constructor arguments.++* OccRhs: consider+     let p = <blah> in+     let x = Just p+     in ...case p of ...++  Here `p` occurs syntactically once, but we want to mark it as InsideLam+  to stop `p` inlining.  We want to leave the x-binding as a constructor+  applied to variables, so that the Simplifier can simplify that inner `case`.++  The OccRhs just tells occAnalApp to mark occurrences in constructor args++* OccScrut: consider (case x of ...).  Here we want to give `x` OneOcc+  with "interesting context" field int_cxt = True.  The OccScrut tells+  occAnalApp (which deals with lone variables too) when to set this field+  to True.+-}++data OccEncl -- See Note [OccEncl]+  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda+  | OccScrut       -- Scrutintee of a case+  | OccVanilla     -- Everything else++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccScrut   = text "occScrut"+  ppr OccVanilla = text "occVanilla"++-- See Note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []++                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True++           , occ_join_points = emptyVarEnv+           , occ_bs_env = emptyVarEnv+           , occ_bs_rng = emptyVarSet }++noBinderSwaps :: OccEnv -> Bool+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env++setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv+setScrutCtxt !env alts+  = setNonTailCtxt encl env+  where+    encl | interesting_alts = OccScrut+         | otherwise        = OccVanilla++    interesting_alts = case alts of+                         []    -> False+                         [alt] -> not (isDefaultAlt alt)+                         _     -> True+     -- 'interesting_alts' is True if the case has at least one+     -- non-default alternative.  That in turn influences+     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!++{- Note [The OccEnv for a right hand side]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?++For a non-join point binding, x = rhs++  * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles++  * occ_join_points: zap them!++  * occ_one_shots: initialise from the idDemandInfo;+    see Note [Sources of one-shot information]++For a join point binding,  j x = rhs++  * occ_encl: Consider+       x = e+       join j = Just x+    We want to inline x into j right away, so we don't want to give the join point+    a OccRhs (#14137); we want OccVanilla.  It's not a huge deal, because the+    FloatIn pass knows to float into join point RHSs; and the simplifier does not+    float things out of join point RHSs.  But it's a simple, cheap thing to do.++  * occ_join_points: no need to zap.++  * occ_one_shots: we start with one-shot-info from the context, which indeed+    applies to the /body/ of the join point, after walking past the binders.+    So we add to the front a OneShotInfo for each value-binder of the join+    point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point+    binders caused #25096.)++    For the join point binders themselves, of a /non-recursive/ join point,+    we make the binder a OneShotLam.  Again see `extendOneShotsForJoinPoint`.++    These one-shot infos then get attached to the binder by `occAnalLamTail`.+-}++setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv+setNonTailCtxt ctxt !env+  = env { occ_encl        = ctxt+        , occ_one_shots   = []+        , occ_join_points = zapJoinPointInfo (occ_join_points env) }++setTailCtxt :: OccEnv -> OccEnv+setTailCtxt !env = env { occ_encl = OccVanilla }+    -- Preserve occ_one_shots, occ_join points+    -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):++mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv+-- See Note [The OccEnv for a right hand side]+-- For a join point:+--   - Keep occ_one_shots, occ_joinPoints from the context+--   - But push enough OneShotInfo onto occ_one_shots to account+--     for the join-point value binders+--   - Set occ_encl to OccVanilla+-- For non-join points+--   - Zap occ_one_shots and occ_join_points+--   - Set occ_encl to specified OccEncl+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })+            is_rec encl jp_hood bndr rhs+  | JoinPoint join_arity <- jp_hood+  = env { occ_encl        = OccVanilla+        , occ_one_shots   = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+        , occ_join_points = ctxt_join_points }++  | otherwise+  = env { occ_encl        = encl+        , occ_one_shots   = argOneShots (idDemandInfo bndr)+                            -- argOneShots: see Note [Sources of one-shot information]+        , occ_join_points = zapJoinPointInfo ctxt_join_points }++zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).+-- See (W3) of Note [Occurrence analysis for join points]+--+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you+-- might lose those uds, and that might mean we don't record all occurrencs, and+-- that means we duplicate a redex....  a very nasty bug (which I encountered!).+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this+-- bug before it does any damage.+#ifdef DEBUG+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info+#else+zapJoinPointInfo _       = emptyVarEnv+#endif++extendOneShotsForJoinPoint+  :: RecFlag -> JoinArity -> CoreExpr+  -> [OneShotInfo] -> [OneShotInfo]+-- Push enough OneShortInfos on the front of ctxt_one_shots+-- to account for the value lambdas of the join point+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+  = go join_arity rhs+  where+    -- For a /non-recursive/ join point we can mark all+    -- its join-lambda as one-shot; and it's a good idea to do so+    -- But not so for recursive ones+    os = case is_rec of+           NonRecursive -> OneShotLam+           Recursive    -> NoOneShotInfo++    go 0 _        = ctxt_one_shots+    go n (Lam b rhs)+      | isId b    = os : go (n-1) rhs+      | otherwise =      go (n-1) rhs+    go _ _        = []  -- Not enough lambdas.  This can legitimately happen.+                        -- e.g.    let j = case ... in j True+                        -- This will become an arity-1 join point after the+                        -- simplifier has eta-expanded it; but it may not have+                        -- enough lambdas /yet/. (Lint checks that JoinIds do+                        -- have enough lambdas.)++setOneShots :: OneShots -> OccEnv -> OccEnv+setOneShots os !env+  | null os   = env  -- Fast path for common case+  | otherwise = env { occ_one_shots = os }++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of+                                          OccRhs -> True+                                          _      -> False++addInScopeList :: OccEnv -> [Var]+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeList #-}+addInScopeList env bndrs thing_inside+ | null bndrs = thing_inside env  -- E.g. nullary constructors in a `case`+ | otherwise  = addInScope env bndrs thing_inside++addInScopeOne :: OccEnv -> Id+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeOne #-}+addInScopeOne env bndr = addInScope env [bndr]++addInScope :: OccEnv -> [Var]+           -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScope #-}+-- This function is called a lot, so we want to inline the fast path+-- so we don't have to allocate thing_inside and call it+-- The bndrs must include TyVars as well as Ids, because of+--     (BS3) in Note [Binder swap]+-- We do not assume that the bndrs are in scope order; in fact the+-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order++-- Fast path when the is no environment-munging to do+-- This is rather common: notably at top level, but nested too+addInScope env bndrs thing_inside+  | isEmptyVarEnv (occ_bs_env env)+  , isEmptyVarEnv (occ_join_points env)+  , WUD uds res <- thing_inside env+  = WUD (delBndrsFromUDs bndrs uds) res++addInScope env bndrs thing_inside+  = WUD uds' res+  where+    bndr_set           = mkVarSet bndrs+    !(env', bad_joins) = preprocess_env env bndr_set+    !(WUD uds res)     = thing_inside env'+    uds'               = postprocess_uds bndrs bad_joins uds++preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)+preprocess_env env@(OccEnv { occ_join_points = join_points+                           , occ_bs_rng = bs_rng_vars })+               bndr_set+  | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points)+  | otherwise = (drop_shadowed_swaps env,                       emptyVarEnv)+  where+    drop_shadowed_swaps :: OccEnv -> OccEnv+    -- See Note [The binder-swap substitution] (BS3)+    drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })+      | isEmptyVarEnv swap_env+      = env+      | bs_rng_vars `intersectsVarSet` bndr_set+      = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+      | otherwise+      = env { occ_bs_env = swap_env `minusUFM` bndr_fm }++    drop_shadowed_joins :: OccEnv -> OccEnv+    -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)+    drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }++    -- bad_joins is true if it would be wrong to push occ_join_points inwards+    --  (a) `bndrs` includes any of the occ_join_points+    --  (b) `bndrs` includes any variables free in the RHSs of occ_join_points+    bad_joins :: Bool+    bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points++    bndr_fm :: UniqFM Var Var+    bndr_fm = getUniqSet bndr_set++    is_bad :: Unique -> OccInfoEnv -> Bool -> Bool+    is_bad uniq join_uds rest+      = uniq `elemUniqSet_Directly` bndr_set ||+        not (bndr_fm `disjointUFM` join_uds) ||+        rest++postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails+postprocess_uds bndrs bad_joins uds+  = add_bad_joins (delBndrsFromUDs bndrs uds)+  where+    add_bad_joins :: UsageDetails -> UsageDetails+    -- Add usage info for occ_join_points that we cannot push inwards+    -- because of shadowing+    -- See Note [Occurrence analysis for join points] wrinkle (W2)+    add_bad_joins uds+       | isEmptyVarEnv bad_joins = uds+       | otherwise               = modifyUDEnv extend_with_bad_joins uds++    extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv+    extend_with_bad_joins env+       = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins++    add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv+    -- Behave like `andUDs` when adding in the bad_joins+    add_bad_join uniq join_env env+      | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env+      | otherwise                  = env++addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv+addJoinPoint env bndr rhs_uds+  | isEmptyVarEnv zeroed_form+  = env+  | otherwise+  = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }+  where+    zeroed_form = mkZeroedForm rhs_uds++mkZeroedForm :: UsageDetails -> OccInfoEnv+-- See Note [Occurrence analysis for join points] for "zeroed form"+mkZeroedForm (UD { ud_env = rhs_occs })+  = mapMaybeUFM do_one rhs_occs+  where+    do_one :: LocalOcc -> Maybe LocalOcc+    do_one (ManyOccL {})    = Nothing+    do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 })++--------------------+transClosureFV :: VarEnv VarSet -> VarEnv VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> ri[b/x] }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> ri[b |> sym co/x] }++The substitution ri[b/x] etc is done by the occurrence analyser.+See Note [The binder-swap substitution].++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead the Simplifier replaces occurrences of x with+    occurrences of b, that will mess up b's occurrence info. That in+    turn might have consequences.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [The binder-swap substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binder-swap is implemented by the occ_bs_env field of OccEnv.+There are two main pieces:++* Given    case x |> co of b { alts }+  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is+  done by addBndrSwap.++* Then, at an occurrence of a variable, we look up in the occ_bs_env+  to perform the swap. This is done by lookupBndrSwap.++Some tricky corners:++(BS1) We do the substitution before gathering occurrence info. So in+      the above example, an occurrence of x turns into an occurrence+      of b, and that's what we gather in the UsageDetails.  It's as+      if the binder-swap occurred before occurrence analysis. See+      the computation of fun_uds in occAnalApp.++(BS2) When doing a lookup in occ_bs_env, we may need to iterate,+      as you can see implemented in lookupBndrSwap.  Why?+      Consider   case x of a { 1# -> e1; DEFAULT ->+                 case x of b { 2# -> e2; DEFAULT ->+                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}+      At the first case addBndrSwap will extend occ_bs_env with+          [x :-> a]+      At the second case we occ-anal the scrutinee 'x', which looks up+        'x in occ_bs_env, returning 'a', as it should.+      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding+         occ_bs_env = [x :-> a, a :-> b]+      At the third case we'll again look up 'x' which returns 'a'.+      But we don't want to stop the lookup there, else we'll end up with+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}+      Instead, we want iterate the lookup in addBndrSwap, to give+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}+      This makes a particular difference for case-merge, which works+      only if the scrutinee is the case-binder of the immediately enclosing+      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils+      See #19581 for the bug report that showed this up.++(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,+      and we encounter:+         (i) \x. blah+             Here we want to delete the x-binding from occ_bs_env++         (ii) \b. blah+              This is harder: we really want to delete all bindings that+              have 'b' free in the range.  That is a bit tiresome to implement,+              so we compromise.  We keep occ_bs_rng, which is the set of+              free vars of rng(occc_bs_env).  If a binder shadows any of these+              variables, we discard all of occ_bs_env.  Safe, if a bit+              brutal.  NB, however: the simplifer de-shadows the code, so the+              next time around this won't happen.++      These checks are implemented in addInScope.+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+      must not replace `x` by `...a...` under /\a. ...x..., or similarly+      under a case pattern match that binds `a`.++      An alternative would be for the occurrence analyser to do cloning as+      it goes.  In principle it could do so, but it'd make it a bit more+      complicated and there is no great benefit. The simplifer uses+      cloning to get a no-shadowing situation, the care-when-shadowing+      behaviour above isn't needed for long.++(BS4) The domain of occ_bs_env can include GlobaIds.  Eg+         case M.foo of b { alts }+      We extend occ_bs_env with [M.foo :-> b].  That's fine.++(BS5) We have to apply the occ_bs_env substitution uniformly,+      including to (local) rules and unfoldings.++(BS6) For interest (only),+      see Historical Note [Care with binder-swap on dictionaries]++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Historical Note [Care with binder-swap on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is now out-dated; it has been rendered irrelevant by+Note [Unary class magic] in GHC.Core.TyCon.  I'm leaving it here in+case we are every tempted to return to newtype classes.++This (historical) Note explains why we need isDictId in scrutOkForBinderSwap.+Consider this tricky example (#21229, #21470):++  class Sing (b :: Bool) where sing :: Bool+  instance Sing 'True  where sing = True+  instance Sing 'False where sing = False++  f :: forall a. Sing a => blah++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     dSing++Now do a binder-swap on the case-expression:++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     (wild |> sym the_co)++And now substitute `False` for `wild` (since wild=False in the False branch):++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True  |> sym the_co)+        False -> f @a     (False |> sym the_co)++And now we have a problem.  The specialiser will specialise (f @a d)a (for all+vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using+Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.++The real problem is the binder-swap.  It swaps a dictionary variable $dSing+(of kind Constraint) for a term variable wild (of kind Type).  And that is+dangerous: a dictionary is a /singleton/ type whereas a general term variable is+not.  In this particular example, Bool is most certainly not a singleton type!++Conclusion:+  for a /dictionary variable/ do not perform+  the clever cast version of the binder-swap++Hence the subtle isDictId in scrutOkForBinderSwap.++Why this Note is now outdated.  Using Note [Unary class magic] in GHC.Core.TyCon+the program above becomes+  h = \ @(a :: Bool) ($dSing :: Sing a)+      case sing @a $dSing of (wild::Bool)+        True  -> f @'True $dSing+        False -> f @a     $dSing+so the issue of binder-swapping doesn't arise.++End of Historical Note.++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> ...cb... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++-}++addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv+-- See Note [The binder-swap substitution]+addBndrSwap scrut case_bndr+            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })+  | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut+  , scrut_var /= case_bndr+      -- Consider: case x of x { ... }+      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop+  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)+        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'+                       `unionVarSet` tyCoVarsOfMCo mco }++  | otherwise+  = env+  where+    case_bndr' = zapIdOccInfo case_bndr+                 -- See Note [Zap case binders in proxy bindings]++-- | See bBinderSwaOk.+data BinderSwapDecision+  = NoBinderSwap+  | DoBinderSwap OutVar MCoercion++scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision+-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then+--    v = e |> mco+-- See Note [Case of cast]+-- See Historical Note [Care with binder-swap on dictionaries]+--+-- We use this same function in SpecConstr, and Simplify.Iteration,+-- when something binder-swap-like is happening+scrutOkForBinderSwap e+  = case e of+      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks+      Var v           -> DoBinderSwap v MRefl+      Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co))+                         -- Cast: see Note [Case of cast]+      _               -> NoBinderSwap++lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)+-- See Note [The binder-swap substitution]+-- Returns an expression of the same type as Id+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr+  = case lookupVarEnv bs_env bndr of {+       Nothing           -> (Var bndr, bndr) ;+       Just (bndr1, mco) ->++    -- Why do we iterate here?+    -- See (BS2) in Note [The binder-swap substitution]+    case lookupBndrSwap env bndr1 of+      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }++{- Historical note [Proxy let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to do the binder-swap transformation by introducing+a proxy let-binding, thus;++   case x of b { pi -> ri }+      ==>+   case x of b { pi -> let x = b in ri }++But that had two problems:++1. If 'x' is an imported GlobalId, we'd end up with a GlobalId+   on the LHS of a let-binding which isn't allowed.  We worked+   around this for a while by "localising" x, but it turned+   out to be very painful #16296,++2. In CorePrep we use the occurrence analyser to do dead-code+   elimination (see Note [Dead code in CorePrep]).  But that+   occasionally led to an unlifted let-binding+       case x of b { DEFAULT -> let x::Int# = b in ... }+   which disobeys one of CorePrep's output invariants (no unlifted+   let-bindings) -- see #5433.++Doing a substitution (via occ_bs_env) is much better.++Historical Note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical Note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+++************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.++Note [LocalOcc]+~~~~~~~~~~~~~~~+LocalOcc is used purely internally, in the occurrence analyser.  It differs from+GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need+IAmDead or IAmALoopBreaker.++Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice++-}++type OccInfoEnv = IdEnv LocalOcc  -- A finite map from an expression's+                                  -- free variables to their usage++data LocalOcc  -- See Note [LocalOcc]+     = OneOccL { lo_n_br  :: {-# UNPACK #-} !BranchCount  -- Number of syntactic occurrences+               , lo_tail  :: !TailCallInfo+                   -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)+                   -- gives NoTailCallInfo+              , lo_int_cxt :: !InterestingCxt }+    | ManyOccL !TailCallInfo++instance Outputable LocalOcc where+  ppr (OneOccL { lo_n_br = n, lo_tail = tci })+    = text "OneOccL" <> braces (ppr n <> comma <> ppr tci)+  ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci)++localTailCallInfo :: LocalOcc -> TailCallInfo+localTailCallInfo (OneOccL  { lo_tail = tci }) = tci+localTailCallInfo (ManyOccL tci)               = tci++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_tail    :: !ZappedSet   -- zap tail-call info for these+       }+  -- INVARIANT: All three zapped sets are subsets of ud_env++instance Outputable UsageDetails where+  ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })+    = text "UD" <+> (braces $ fsep $ punctuate comma $+      [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq)+      | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ])+      $$ nest 2 (text "ud_z_tail" <+> ppr z_tail)+    where+      do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]+      do_one uniq occ occs = (uniq, occ) : occs++---------------------+-- | TailUsageDetails captures the result of applying 'occAnalLamTail'+--   to a function `\xyz.body`. The TailUsageDetails pairs together+--   * the number of lambdas (including type lambdas: a JoinArity)+--   * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`.+-- If the binding turns out to be a join point with the indicated join+-- arity, this unadjusted usage details is just what we need; otherwise we+-- need to discard tail calls. That's what `adjustTailUsage` does.+data TailUsageDetails = TUD !JoinArity !UsageDetails++instance Outputable TailUsageDetails where+  ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds++---------------------+data WithUsageDetails     a = WUD  !UsageDetails     !a+data WithTailUsageDetails a = WTUD !TailUsageDetails !a++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith andLocalOcc+orUDs  = combineUsageDetailsWith orLocalOcc++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc !env id int_cxt arity+  | not (isLocalId id)+  = emptyDetails++  | Just join_uds <- lookupVarEnv (occ_join_points env) id+  = -- See Note [Occurrence analysis for join points]+    assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $+       -- We only put non-empty join-points into occ_join_points+    mkSimpleDetails (extendVarEnv join_uds id occ)++  | otherwise+  = mkSimpleDetails (unitVarEnv id occ)++  where+    occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt+                  , lo_tail = AlwaysTailCalled arity }++-- Add several occurrences, assumed not to be tail calls+add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv+add_many_occ v env | isId v    = extendVarEnv env v (ManyOccL NoTailCallInfo)+                   | otherwise = env+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++addManyOccs :: UsageDetails -> VarSet -> UsageDetails+addManyOccs uds var_set+  | isEmptyVarSet var_set = uds+  | otherwise             = uds { ud_env = add_to (ud_env uds) }+  where+    add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set+    -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes++addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails+-- Add any CoVars free in the type of a lambda-binder+-- See Note [Gather occurrences of coercion variables]+addLamCoVarOccs uds bndrs+  = foldr add uds bndrs+  where+    add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)++emptyDetails :: UsageDetails+emptyDetails = mkSimpleDetails emptyVarEnv++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env++mkSimpleDetails :: OccInfoEnv -> UsageDetails+mkSimpleDetails env = UD { ud_env       = env+                         , ud_z_many    = emptyVarEnv+                         , ud_z_in_lam  = emptyVarEnv+                         , ud_z_tail    = emptyVarEnv }++modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails+modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }++delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails+-- Delete these binders from the UsageDetails+delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many+                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail })+  = UD { ud_env       = env      `delVarEnvList` bndrs+       , ud_z_many    = z_many   `delVarEnvList` bndrs+       , ud_z_in_lam  = z_in_lam `delVarEnvList` bndrs+       , ud_z_tail    = z_tail   `delVarEnvList` bndrs }++markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail+  :: UsageDetails -> UsageDetails+markAllMany      ud@(UD { ud_env = env }) = ud { ud_z_many   = env }+markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }+markAllNonTail   ud@(UD { ud_env = env }) = ud { ud_z_tail   = env }+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo++markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails++markAllInsideLamIf  True  ud = markAllInsideLam ud+markAllInsideLamIf  False ud = ud++markAllNonTailIf True  ud = markAllNonTail ud+markAllNonTailIf False ud = ud++lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo+lookupTailCallInfo uds id+  | UD { ud_z_tail = z_tail, ud_env = env } <- uds+  , not (id `elemVarEnv` z_tail)+  , Just occ <- lookupVarEnv env id+  = localTailCallInfo occ+  | otherwise+  = NoTailCallInfo++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env++restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet+restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)+                        -> UsageDetails -> UsageDetails -> UsageDetails+{-# INLINE combineUsageDetailsWith #-}+combineUsageDetailsWith plus_occ_info+    uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })+    uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })+  | isEmptyVarEnv env1 = uds2+  | isEmptyVarEnv env2 = uds1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2+       , ud_z_many    = plusVarEnv z_many1   z_many2+       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2+       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }++lookupLetOccInfo :: UsageDetails -> Id -> OccInfo+-- Don't use locally-generated occ_info for exported (visible-elsewhere)+-- things.  Instead just give noOccInfo.+-- NB: setBinderOcc will (rightly) erase any LoopBreaker info;+--     we are about to re-generate it and it shouldn't be "sticky"+lookupLetOccInfo ud id+ | isExportedId id = noOccInfo+ | otherwise       = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfo :: UsageDetails -> Id -> OccInfo+lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo+lookupOccInfoByUnique (UD { ud_env       = env+                          , ud_z_many    = z_many+                          , ud_z_in_lam  = z_in_lam+                          , ud_z_tail    = z_tail })+                  uniq+  = case lookupVarEnv_Directly env uniq of+      Nothing -> IAmDead+      Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt+                    , lo_tail = tail_info })+          | uniq `elemVarEnvByKey`z_many+          -> ManyOccs { occ_tail = mk_tail_info tail_info }+          | otherwise+          -> OneOcc { occ_in_lam  = in_lam+                    , occ_n_br    = n_br+                    , occ_int_cxt = int_cxt+                    , occ_tail    = mk_tail_info tail_info }+         where+           in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam+                  | otherwise                       = NotInsideLam++      Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info }+  where+    mk_tail_info ti+        | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo+        | otherwise                     = ti++++-------------------+-- See Note [Adjusting right-hand sides]++adjustNonRecRhs :: JoinPointHood+                -> WithTailUsageDetails CoreExpr+                -> WithUsageDetails CoreExpr+-- ^ This function concentrates shared logic between occAnalNonRecBind and the+-- AcyclicSCC case of occAnalRec.+-- It returns the adjusted rhs UsageDetails combined with the body usage+adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)+  = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs+++adjustTailUsage :: JoinPointHood+                -> WithTailUsageDetails CoreExpr    -- Rhs usage, AFTER occAnalLamTail+                -> UsageDetails+adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)+  = -- c.f. occAnal (Lam {})+    markAllInsideLamIf (not one_shot) $+    markAllNonTailIf (not exact_join) $+    uds+  where+    one_shot   = isOneShotFun rhs+    exact_join = mb_join_arity == JoinPoint rhs_ja++adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails+adjustTailArity mb_rhs_ja (TUD ja usage)+  = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails        -- Of scope+              -> [Id]                -- Binders+              -> [IdWithOccInfo]     -- Tagged binders+tagLamBinders usage binders+  = map (tagLamBinder usage) binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> IdWithOccInfo      -- Tagged binders+-- Used for lambda and case binders+-- No-op on TyVars+-- A lambda binder never has an unfolding, so no need to look for that+tagLamBinder usage bndr+  = setBinderOcc (markNonTail occ) bndr+      -- markNonTail: don't try to make an argument into a join point+  where+    occ = lookupOccInfo usage bndr++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> OccInfo                -- Of scope+                -> CoreBndr               -- Binder+                -> (IdWithOccInfo, JoinPointHood)  -- Tagged binder+-- No-op on TyVars+-- Precondition: OccInfo is not IAmDead+tagNonRecBinder lvl occ bndr+  | okForJoinPoint lvl bndr tail_call_info+  , AlwaysTailCalled ar <- tail_call_info+  = (setBinderOcc occ bndr,        JoinPoint ar)+  | otherwise+  = (setBinderOcc zapped_occ bndr, NotJoinPoint)+ where+    tail_call_info = tailCallInfo occ+    zapped_occ     = markNonTail occ++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [NodeDetails]+              -> WithUsageDetails       -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo]       -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds details_s+ = let+     bndrs = map nd_bndr details_s++     -- 1. See Note [Join arity prediction based on joinRhsArity]+     --    Determine possible join-point-hood of whole group, by testing for+     --    manifest join arity M.+     --    This (re-)asserts that makeNode had made tuds for that same arity M!+     unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s+     test_manifest_arity ND{nd_rhs = WTUD tuds rhs}+       = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds++     will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs++     mb_join_arity :: Id -> JoinPointHood+     -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]+     -- This is the source O+     mb_join_arity bndr+         -- Can't use willBeJoinId_maybe here because we haven't tagged+         -- the binder yet (the tag depends on these adjustments!)+       | will_be_joins+       , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr+       = JoinPoint arity+       | otherwise+       = assert (not will_be_joins) -- Should be AlwaysTailCalled if+         NotJoinPoint               -- we are making join points!++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds+                     -- Matching occAnalLamTail in makeNode+                 | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ]++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds = foldr andUDs body_uds rhs_udss'++     -- 4. Tag each binder with its adjusted details+     bndrs'    = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr+                 | bndr <- bndrs ]++   in+   WUD adj_uds bndrs'++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr               = bndr+  | occ_info == idOccInfo bndr = bndr+  | otherwise                  = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not, based+-- on its occurrences. This is+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're+-- assumed to be mutually recursive.+--+-- It must, however, be a final decision. If we say `True` for 'f',+-- and then subsequently decide /not/ make 'f' into a join point, then+-- the decision about another binding 'g' might be invalidated if (say)+-- 'f' tail-calls 'g'.+--+-- See Note [Invariants on join points] in "GHC.Core".+decideRecJoinPointHood :: TopLevelFlag -> UsageDetails+                       -> [CoreBndr] -> Bool+decideRecJoinPointHood lvl usage bndrs+  = all ok bndrs  -- Invariant 3: Either all are join points or none are+  where+    ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)++okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+okForJoinPoint lvl bndr tail_call_info+  | isJoinId bndr        -- A current join point should still be one!+  = warnPprTrace lost_join "Lost join point" lost_join_doc $+    True+  | valid_join+  = True+  | otherwise+  = False+  where+    valid_join | NotTopLevel <- lvl+               , AlwaysTailCalled arity <- tail_call_info++               , -- Invariant 1 as applied to LHSes of rules+                 all (ok_rule arity) (idCoreRules bndr)++                 -- Invariant 2a: stable unfoldings+                  -- See Note [Join points and INLINE pragmas]+               , ok_unfolding arity (realIdUnfolding bndr)++                 -- Invariant 4: Satisfies polymorphism rule+               , isValidJoinPointType arity (idType bndr)+               = True+               | otherwise+               = False++    lost_join | JoinPoint ja <- idJoinPointHood bndr+              = not valid_join ||+                (case tail_call_info of  -- Valid join but arity differs+                   AlwaysTailCalled ja' -> ja /= ja'+                   _                    -> False)+              | otherwise = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = args `lengthIs` join_arity+        -- Invariant 1 as applied to LHSes of rules++    -- ok_unfolding returns False if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = not (isStableSource src && join_arity > joinRhsArity rhs)+    ok_unfolding _ (DFunUnfolding {})+      = False+    ok_unfolding _ _+      = True++    lost_join_doc+      = vcat [ text "bndr:" <+> ppr bndr+             , text "tc:" <+> ppr tail_call_info+             , text "rules:" <+> ppr (idCoreRules bndr)+             , case tail_call_info of+                 AlwaysTailCalled arity ->+                    vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr))+                         , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]+                 _ -> empty ]++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+GHC.Core.  #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.++See Invariant 2a of Note [Invariants on join points] in GHC.Core+++************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markNonTail :: OccInfo -> OccInfo+markNonTail IAmDead = IAmDead+markNonTail occ     = occ { occ_tail = NoTailCallInfo }++andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2)+  where+    !tci1 = localTailCallInfo occ1+    !tci2 = localTailCallInfo occ2++orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+-- (orLocalOcc occ1 occ2) is used+-- when combining occurrence info from branches of a case+orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 })+           (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 })+  = OneOccL { lo_n_br    = nbr1 + nbr2+            , lo_int_cxt = int_cxt1 `mappend` int_cxt2+            , lo_tail    = tci1 `andTailCallInfo` tci2 }+orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2++andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo+andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)+  | arity1 == arity2 = info+andTailCallInfo _ _  = NoTailCallInfo
+ GHC/Core/Opt/Pipeline.hs view
@@ -0,0 +1,582 @@+{-+(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.DynFlags+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, initGentleSimplMode )+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, 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.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.TopLevelBinds (topLevelBindsCCMG)+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 { hpt_rule_base <- home_pkg_rules+       ; let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars+             uniq_tag = 's'++       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag 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+    unit_env       = hsc_unit_env hsc_env+    extra_vars     = interactiveInScope (hsc_IC hsc_env)+    home_pkg_rules = hugRulesBelow hsc_env (moduleUnitId mod)+                      (GWIB { gwib_mod = moduleName mod, gwib_isBoot = NotBoot })+    name_ppr_ctx   = mkNamePprCtx ptc unit_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++    simpl_phase phase name iter+      = CoreDoPasses+      $   [ maybe_strictness_before phase+          , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter+                             (initSimplMode dflags phase name) hpt_rule_base+          , maybe_rule_check phase ]++    -- Run GHC's internal simplification phase, after all rules have run.+    -- See Note [Compiler phases] in GHC.Types.Basic+    simplify name = simpl_phase FinalPhase name max_iter++    -- initial simplify: mk specialiser happy: minimum effort please+    -- See Note [Inline in InitialPhase]+    -- See Note [RULEs enabled in InitialPhase]+    simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter+                                    (initGentleSimplMode dflags) hpt_rule_base++    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]+++    demand_analyser = (CoreDoPasses (+                           dmd_cpr_ww +++                           [simplify "post-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+          , floatJoinsToTop = False+          }+        ]++    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+                , floatJoinsToTop     = False  -- Initially, don't float join points at all+                }+                -- 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 "post-call-arity"+            ],++        -- Strictness analysis+        runWhen strictness demand_analyser,++        runWhen exitification CoreDoExitify,+            -- See Note [Placement of the exitification pass]++        -- 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 full_laziness $ CoreDoFloatOutwards $ FloatOutSwitches+               { floatOutLambdas     = floatLamArgs dflags+               , floatOutConstants   = True+               , floatOutOverSatApps = True+               , floatToTopLevelOnly = False+               , floatJoinsToTop     = True },+                -- floatJoinsToTop: floating joins to the top makes a huge difference to+                -- spectral/minimax; see XXX+++        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,++        simplify "final",  -- Final tidy-up++        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 "post-liberate-case" ],+           -- Run the simplifier after LiberateCase to vastly+           -- reduce the possibility of shadowing+           -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr++        runWhen spec_constr $ CoreDoPasses+           [ CoreDoSpecConstr, simplify "post-spec-constr"],+           -- See Note [Simplify after SpecConstr]++        maybe_rule_check FinalPhase,++        runWhen late_specialise $ CoreDoPasses+           [ CoreDoSpecialising, simplify "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 "post-final-cse" ],++        ---------  End of -O2 passes --------------++        runWhen late_dmd_anal $ CoreDoPasses (+            dmd_cpr_ww ++ [simplify "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' }+  -- Important to force this now as name_ppr_ctx lives through an entire phase in+  -- the optimiser and if it's not forced then the entire previous `ModGuts` will+  -- be retained until the end of the phase. (See #24328 for more analysis)+  let !rdr_env = mg_rdr_env guts+  let name_ppr_ctx =+        mkNamePprCtx+          (initPromotionTickContext dflags)+          (hsc_unit_env hsc_env)+          rdr_env+++  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" #-}+                                 topLevelBindsCCMG 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_dmd_signatures "Demand 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
+ GHC/Core/Opt/Pipeline/Types.hs view
@@ -0,0 +1,103 @@+module GHC.Core.Opt.Pipeline.Types (+    -- * Configuration of the core-to-core passes+    CorePluginPass, CoreToDo(..),+    bindsOnlyPass, pprPassDetails,+  ) where++import GHC.Prelude++import GHC.Core ( CoreProgram )+import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches )+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )++import GHC.Types.Basic  ( CompilerPhase(..) )+import GHC.Unit.Module.ModGuts+import GHC.Utils.Outputable as Outputable++{-+************************************************************************+*                                                                      *+              The CoreToDo type and related types+          Abstraction of core-to-core passes to run.+*                                                                      *+************************************************************************+-}++-- | A description of the plugin pass itself+type CorePluginPass = ModGuts -> CoreM ModGuts++bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts+bindsOnlyPass pass guts+  = do { binds' <- pass (mg_binds guts)+       ; return (guts { mg_binds = binds' }) }++data CoreToDo           -- These are diff core-to-core passes,+                        -- which may be invoked in any order,+                        -- as many times as you like.++  = CoreDoSimplify !SimplifyOpts+  -- ^ The core-to-core simplifier.+  | CoreDoPluginPass String CorePluginPass+  | CoreDoFloatInwards+  | CoreDoFloatOutwards FloatOutSwitches+  | CoreLiberateCase+  | CoreDoPrintCore+  | CoreDoStaticArgs+  | CoreDoCallArity+  | CoreDoExitify+  | CoreDoDemand Bool  -- Bool: Do worker/wrapper afterwards?+                       -- See Note [Don't change boxity without worker/wrapper]+  | CoreDoCpr+  | CoreDoWorkerWrapper+  | CoreDoSpecialising+  | CoreDoSpecConstr+  | CoreCSE+  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules+                                           -- matching this string+  | CoreDoNothing                -- Useful when building up+  | CoreDoPasses [CoreToDo]      -- lists of these things++  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+                       --                 Core output, and hence useful to pass to endPass++  | CoreTidy+  | CorePrep+  | CoreAddCallerCcs+  | CoreAddLateCcs++instance Outputable CoreToDo where+  ppr (CoreDoSimplify _)       = text "Simplifier"+  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s+  ppr CoreDoFloatInwards       = text "Float inwards"+  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)+  ppr CoreLiberateCase         = text "Liberate case"+  ppr CoreDoStaticArgs         = text "Static argument"+  ppr CoreDoCallArity          = text "Called arity analysis"+  ppr CoreDoExitify            = text "Exitification transformation"+  ppr (CoreDoDemand True)      = text "Demand analysis (including Boxity)"+  ppr (CoreDoDemand False)     = text "Demand analysis"+  ppr CoreDoCpr                = text "Constructed Product Result analysis"+  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"+  ppr CoreDoSpecialising       = text "Specialise"+  ppr CoreDoSpecConstr         = text "SpecConstr"+  ppr CoreCSE                  = text "Common sub-expression"+  ppr CoreDesugar              = text "Desugar (before optimization)"+  ppr CoreDesugarOpt           = text "Desugar (after optimization)"+  ppr CoreTidy                 = text "Tidy Core"+  ppr CoreAddCallerCcs         = text "Add caller cost-centres"+  ppr CoreAddLateCcs           = text "Add late core cost-centres"+  ppr CorePrep                 = text "CorePrep"+  ppr CoreDoPrintCore          = text "Print core"+  ppr (CoreDoRuleCheck {})     = text "Rule check"+  ppr CoreDoNothing            = text "CoreDoNothing"+  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes++pprPassDetails :: CoreToDo -> SDoc+pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n+                                           , ppr md ]+  where+    n = so_iterations cfg+    md = so_mode cfg++pprPassDetails _ = Outputable.empty
+ GHC/Core/Opt/SetLevels.hs view
@@ -0,0 +1,1979 @@+{-# 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 sensibly.++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+   (i.e. it can now be floated out, whereas if it mentioned wild it could not).+   And it's not inconvenient because we already have a substitution.++   For example, consider:++      f x = letrec go y = case x of z { (a,b) -> ...(expensive z)... }+              in ...++   If we do the reverse binder-swap we get++      f x = letrec go y = case x of z { (a,b) -> ...(expensive x)... }+              in ...++   and now we can float out:++      f x = let t = expensive x+              in letrec go y = case x of z { (a,b) -> ...(t)... }+              in ...++   Now (expensive x) is computed once, rather than once each time around the 'go' loop.++   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(..), tOP_LEVEL,+        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+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 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++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.+-}++instance Outputable FloatSpec where+  ppr (FloatMe l) = char 'F' <> ppr l+  ppr (StayPut l) = ppr l++tOP_LEVEL :: Level+tOP_LEVEL   = Level 0 0++incMajorLvl :: Level -> Level+incMajorLvl (Level major _) = Level (major + 1) 0++incMinorLvl :: Level -> Level+incMinorLvl (Level major minor) = Level major (minor+1)++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++instance Outputable Level where+  ppr (Level maj min)+    = hcat [ char '<', int maj, char ',', int min, char '>' ]++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)+                                   NotJoinPoint+                                   (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 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.++     - exprIsHNF 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 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+  |  notWorthFloating expr abs_vars+  || not float_me+  || 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+  = -- 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 NotJoinPoint ann_expr+                  -- Treat the expr just like a right-hand side+       ; var <- newLvlVar expr1 NotJoinPoint 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 NotJoinPoint 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+               -- 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++    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.+        -- Never float trivial expressions;+        --   notably, save_work might be true of a lone evaluated variable.+    float_me = saves_work || saves_alloc || is_mk_static++    -- See Note [Saving work]+    is_hnf = exprIsHNF expr+    saves_work = escapes_value_lam        -- (a)+                 && not is_hnf            -- (b)+                 && not float_is_new_lam  -- (c)+    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)++    -- See Note [Saving allocation] and Note [Floating to the top]+    saves_alloc =  isTopLvl dest_lvl+                && floatConsts env+                && (   not strict_ctxt                     -- (a)+                    || is_hnf                              -- (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 [Saving work]+~~~~~~~~~~~~~~~~~~~~~+The key idea in let-floating is to+  * float a redex out of a (value) lambda+Doing so can save an unbounded amount of work.+But see also Note [Saving allocation].++So we definitely float an expression out if+(a) It will escape a value lambda (escapes_value_lam)+(b) The expression is not a head-normal form (exprIsHNF); see (SW1, SW2).+(c) Floating does not require wrapping it in value lambdas (float_is_new_lam).+    See (SW3) below++Wrinkles:++(SW1) Concerning (b) I experimented with using `exprIsCheap` rather than+      `exprIsHNF` but the latter seems better, according to nofib+      (`spectral/mate` got 10% worse with exprIsCheap).  It's really a bit of a+      heuristic.++(SW2) What about omitting (b), and hence floating HNFs as well?  The danger of+      doing so is that we end up floating out a HNF from a cold path (where it+      might never get allocated at all) and allocating it all the time+      regardless.  Example+          f xs = case xs of+                   [x] | x>3       -> (y,y)+                       | otherwise -> (x,y)+                   (x:xs) -> ...f xs...+      We can float (y,y) out, but in a particular call to `f` that path might+      not be taken, so allocating it before the definition of `f` is a waste.++      See !12410 for some data comparing the effect of omitting (b) altogether,+      This doesn't apply, though, if we float the thing to the top level; see+      Note [Floating to the top].  Bottom line (data from !12410): adding the+      not.exprIsHNF test to `saves_work`:+       - Decreases compiler allocations by 0.5%+       - Occasionally decreases runtime allocation (T12996 -2.5%)+       - Slightly mixed effect on nofib: (puzzle -10%, mate -5%, cichelli +5%)+         but geometric mean is -0.09%.+      Overall, a win.++(SW3) Concerning (c), 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_new_lam) in saves_work.++Note [Saving allocation]+~~~~~~~~~~~~~~~~~~~~~~~~+Even if `saves_work` is false, we we may want to float even cheap/HNF+expressions out of value lambdas, for several reasons:++* Doing so may save 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.++* It may allow SpecContr to fire on functions. Consider+        f = \x. ....(f (\y.e))....+  After floating we get+        lvl = \y.e+        f = \x. ....(f lvl)...+  Now it's easier for SpecConstr to generate a robust specialisation for f.++* It makes the function smaller, and hence more likely to inline.  This can make+  a big difference for string literals and bottoming expressions: see Note+  [Floating to the top]++Data suggests, however, that it is better /only/ to float HNFS, /if/ they can go+to top level. See (SW2) of Note [Saving work].  If the expression goes to top+level we don't pay the cost of allocating cold-path thunks described in (SW2).++Hence `isTopLvl dest_lvl` in `saves_alloc`.++Note [Floating to the top]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Even though Note [Saving allocation] suggests that we should not, in+general, float HNFs, the balance change if it goes to the top:++* We don't pay an allocation cost for the floated expression; it+  just becomes static data.++* Floating string literals is valuable -- no point in duplicating the+  at each call site!++* Floating bottoming expressions is valuable: they are always cold+  paths; we don't want to duplicate them at each call site; and they+  can be quite big, inhibiting inlining. See Note [Bottoming floats]++So we float an expression to the top if:+  (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 floating would escape a+      value lambda (NB: if the expression itself 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 don't float join points at all -- we want them to /stay/ join points.+This decision is made in `wantToFloat`.++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.++Another reason for floating join points to the top. spectral/minimax has:+    prog input = join $j y = <expensive> in+                 case (input == "doesnt happen") of+                   True  -> $j (testBoard + testBoard)+                   False -> $j testBoard+Now, iff we float $j to the top, we can /also/ float ($j (tb+tb)) and ($j tb).+Result: asymptotic improvement in perf, if `prof` is called many times.++However there are also bad consequences of floating join points to the top:++* If a continuation consumes (let $j x = Just x in case y of {...})+  we may get much less duplication of the continuation if we don't+  float $j to the top, because the contination goes into $j's RHS++* See #21392 for an example of how demand analysis can get worse if you+  float a join point to the top level.++Compromise (determined experimentally):++* Always float /recursive/ join points to the top.++* For /non-recursive/ join points, float them to the top in the second+  invocation of FloatOut, near the end of the pipeline.  This is controlled by+  the FloatOutSwitch floatJoinsToTop.++Missed opportunity+------------------+There is another benfit of floating local join points.  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.++Currently we don't do this -- a missed opportunity.++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.++    Do /not/ do this for bottoming /join-point/ bindings.   They may call other+    join points (#24768), and floating to the top would abstract over those join+    points, which we should never do.+++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+--  See Note [notWorthFloating]+notWorthFloating e abs_vars+  = go e 0+  where+    n_abs_vars = count isId abs_vars  -- See (NWF5)++    go :: CoreExpr -> Int -> Bool+    -- (go e n) return True if (e x1 .. xn) is not worth floating+    -- where `e` has n trivial value arguments x1..xn+    -- See (NWF4)+    go (Lit lit) n         = (n==0)                 -- See (NWF1b)+                              && litIsTrivial lit   -- See (NWF1a)+    go (Type {}) _         = True+    go (Tick t e) n        = not (tickishIsCode t) && go e n+    go (Cast e _) n        = n==0 || go e n     -- See (NWF3)+    go (Coercion {}) _     = True+    go (App e arg) n+       | Type {} <- arg    = go e n    -- Just types, not coercions (NWF2)+       | exprIsTrivial arg = go e (n+1)+       | otherwise         = n==0 && exprIsUnaryClassFun e+                             -- (f non-triv) is worth floating,+                             -- unless if is a unary class fun+    go (Case e b _ as) _+      -- Do not float the `case` part of trivial cases (NWF3)+      -- We'll have a look at the RHS when we get there+      | null as+      = True   -- See Note [Empty case is trivial]+      | Just {} <- isUnsafeEqualityCase e b as+      = True   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+      | otherwise+      = False++    go (Var v) n+      | isUnaryClassId v = n==1   -- (op x) is not worth floating, but (op x y) is!!+                                  --    See (NWF3)+      | n==0             = True   -- Naked variable+      | n <= n_abs_vars  = True   -- (f a b c) is not worth floating if+      | otherwise        = False  -- a,b,c are all abstracted; see (NWF5)++    go _ _ = False  -- Let etc is worth floating++{- Note [notWorthFloating]+~~~~~~~~~~~~~~~~~~~~~~~~~~+`notWorthFloating` returns True if the expression would be replaced by something+bigger than it is now.  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)!++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)++(NWF1a) 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.++(NWF1b) You might think that a literal should never be applied to a value+  (hence n=0) but actually we can get (see test T23024):+      RUBBISH @(a->b) (x::a)+  See Note [Rubbish literals] in GHC.Types.Literal.  (Mind you, we should be+  in dead code at this point!)++(NWF2) 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 [inlineBoringOk] in"GHC.Core.Unfold"),+  so we still want to float out variables applied only to+  coercion arguments.++(NWF3) Some expressions have trivial wrappers:+     - Casts (e |> co)+     - Unary-class applications:+          - Dictionary applications (MkC meth)+          - Class-op applictions    (op dict)+     - Case of empty alts+     - Unsafe-equality case+  In all these cases we say "not worth floating", and we do so /regardless/+  of the wrapped expression.  The SetLevels stuff may subsequently float the+  components of the expression.++  Example:  is it worth floating (f x |> co)?  No!  If we did we'd get+     lvl = f x |> co+     ...lvl....+  Then we'd do cast worker/wrapper and end up with.+     lvl' = f x+     ...(lvl' |> co)...+  Silly!  Better not to float it in the first place.  If we say "no" here,+  we'll subsequently say "yes" for (f x) and get+     lvl = f x+     ....(lvl |> co)...+  which is what we want.  In short: don't float trivial wrappers.++(NWF4) The only non-trivial expression that we say "not worth floating" for+  is an application+             f x y z+  where the number of value arguments is <= the number of abstracted Ids.+  This is what makes floating idempotent.  Hence counting the number of+  value arguments in `go`++(NWF5) In #24471 we had something like+     x1 = I# 1+     ...+     x1000 = I# 1000+     foo = f x1 (f x2 (f x3 ....))+  So every sub-expression in `foo` has lots and lots of free variables.  But+  none of these sub-expressions float anywhere; the entire float-out pass is a+  no-op.++  So `notWorthFloating` tries to avoid evaluating `n_abs_vars`, in cases where+  it obviously /is/ worth floating.  (In #24471 it turned out that we were+  testing `abs_vars` (a relatively complicated calculation that takes at least+  O(n-free-vars) time to compute) for every sub-expression.)++  Hence testing `n_abs_vars only` at the very end.+-}++{- *********************************************************************+*                                                                      *+                       Bindings+        This binding stuff works for top level too.+*                                                                      *+********************************************************************* -}++lvlBind :: LevelEnv+        -> CoreBindWithFVs+        -> LvlM (LevelledBind, LevelEnv)++lvlBind env (AnnNonRec bndr rhs)+  |  isTyVar bndr  -- Don't float TyVar binders (simplifier gets rid of them pronto)+  || isCoVar bndr  -- Don't float CoVars: difficult to fix up CoVar occurrences+                   --                     (see extendPolyLvlEnv)+  || not (wantToFloat env NonRecursive dest_lvl is_join is_top_bindable)+  = -- 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 NotJoinPoint 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 NotJoinPoint 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++    deann_rhs  = deAnnotate rhs+    mb_bot_str = exprBotStrictness_maybe deann_rhs+    is_bot_lam = not is_join && isJust mb_bot_str+        -- is_bot_lam: looks like (\xy. bot), maybe zero lams+        -- NB: not isBottomThunk!+        -- NB: not is_join: don't send bottoming join points to the top.+        -- See Note [Bottoming floats] point (3)++    is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty+    n_extra       = count isId abs_vars+    mb_join_arity = idJoinPointHood bndr+    is_join       = isJoinPoint mb_join_arity++lvlBind env (AnnRec pairs)+  |  not (wantToFloat env Recursive dest_lvl is_join is_top_bindable)+  = -- 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 (idJoinPointHood 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 NotJoinPoint 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 (_,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive+                                     is_bot NotJoinPoint+                                     rhs++        -- 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+    abs_vars = abstractVars dest_lvl env bind_fvs++    is_top_bindable = not (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)++wantToFloat :: LevelEnv+            -> RecFlag+            -> Level    -- This is how far it could float+            -> Bool     -- Join point+            -> Bool     -- True <=> top-level-bindadable+            -> Bool     -- True <=> Yes! Float me++wantToFloat env is_rec dest_lvl is_join is_top_bindable+  | not (profitableFloat env dest_lvl)+  = False++  | floatTopLvlOnly env && not (isTopLvl dest_lvl)+  = False++  | isTopLvl dest_lvl, not is_top_bindable+  = False    -- 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++  | is_join  -- Join points either stay put, or float to top+             -- See Note [Floating join point bindings]+  = isTopLvl dest_lvl && (isRec is_rec || floatJoinsToTop (le_switches env))++  | otherwise+  = True     -- Yes!  Float me+++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+       -> JoinPointHood+       -> 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+            -> JoinPointHood+            -> 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)     | JoinPoint 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') | JoinPoint {} <- mb_join_arity+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs+                      | otherwise+                      = lvlLamBndrs env1 dest_lvl all_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_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)+          -> Level+destLevel env fvs fvs_ty is_function is_bot+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level+                              -- See Note [Floating join point bindings]+  = tOP_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+    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++       -- 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_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. scrutOkForBinderSwap 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++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++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+      | JoinPoint join_arity <- idJoinPointHood bndr+      , not dest_is_top+      = new_bndr `asJoinId` join_arity + length abs_vars+      | otherwise+      = new_bndr++newLvlVar :: LevelledExpr        -- The RHS of the new binding+          -> JoinPointHood       -- 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 { (subst', vs') <- cloneBndrsM subst vs+             -- N.B. We are not moving the body of the case, merely its case+             -- binders.  Consequently we should *not* set le_ctxt_lvl.+             -- See Note [Setting levels when floating single-alternative cases].+       ; let 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 { let vs1  = map zap vs+       ; (subst', vs2) <- case is_rec of+                            NonRecursive -> cloneBndrsM      subst vs1+                            Recursive    -> cloneRecIdBndrsM subst vs1++       ; let 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+    -- See Note [Floatifying demand info when floating]+    -- and Note [Zapping JoinId when floating]+    zap v | isId v    = zap_join (floatifyIdDemandInfo v)+          | otherwise = v++    -- See Note [Zapping JoinId when floating]+    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 JoinId when floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we are floating a join point, it won't be one anymore, so we zap+the join point information.++Note [Floatifying demand info when floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When floating we must lazify the outer demand info on the Id+because it may be less demanded than at its original binding site.+For example:+     f :: Int -> Int+     f x = let v = 3*4 in v+x+Here v is strict and used at most once; but if we float v to top level,+that isn't true any more. Specifically, we lose track of v's cardinality info:+  * if `f` is called multiple times, then `v` is used more than once+  * if `f` is never called, then `v` is never evaluated.++But NOTE that we only need to adjust the /top-level/ cardinality info.+For example+     let x = (e1,e2)+     in ...(case x of (a,b) -> a+b)...+If we float x outwards, it may no longer be strict, but IF it is ever+evaluated THEN its components will be evaluated.  So we to lazify and+many-ify its demand-info, not discard it entirely.++Same if we have+     let f = \x y . blah+     in ...(f a b)...(f c d)...+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can+keep that `1C` called-once inner demand. It's only the outer strictness+that we kill.++Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the+fact that `v` may be used any number of times, from zero upwards.+-}
+ GHC/Core/Opt/Simplify.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE CPP #-}++module GHC.Core.Opt.Simplify+  ( SimplifyExprOpts(..), SimplifyOpts(..)+  , simplifyExpr, simplifyPgm+  ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Rules+import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )+import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )+import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )+import GHC.Core.Utils   ( mkTicks, stripTicksTop )+import GHC.Core.Lint    ( LintPassResultConfig, dumpPassResult, lintPassResult )+import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules )+import GHC.Core.Opt.Simplify.Utils  ( activeRule )+import GHC.Core.Opt.Simplify.Inline ( activeUnfolding )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.Stats ( simplCountN )+import GHC.Core.FamInstEnv++import GHC.Utils.Error  ( withTiming )+import GHC.Utils.Logger as Logger+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)++import GHC.Unit.Env ( UnitEnv, ueEPS )+import GHC.Unit.External+import GHC.Unit.Module.ModGuts++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Tickish+import GHC.Types.Unique.FM++import Control.Monad+import Data.Foldable ( for_ )++{-+************************************************************************+*                                                                      *+        Gentle simplification+*                                                                      *+************************************************************************+-}++-- | Configuration record for `simplifyExpr`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyExprOpts = SimplifyExprOpts+  { se_fam_inst :: ![FamInst]+  , se_mode :: !SimplMode+  , se_top_env_cfg :: !TopEnvConfig+  }++simplifyExpr :: Logger+             -> ExternalUnitCache+             -> SimplifyExprOpts+             -> CoreExpr+             -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+simplifyExpr logger euc opts expr+  = withTiming logger (text "Simplify [expr]") (const ()) $+    do  { eps <- eucEPS euc ;+        ; let fam_envs = ( eps_fam_inst_env eps+                         , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts+                         )+              simpl_env = mkSimplEnv (se_mode opts) fam_envs+              top_env_cfg = se_top_env_cfg opts+              read_eps_rules = eps_rule_base <$> eucEPS euc+              read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules++        ; let sz = exprSize expr++        ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $+                             simplExprGently simpl_env expr++        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats+                  "Simplifier statistics" FormatText (pprSimplCount counts)++        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"+                        FormatCore+                        (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 InitialPhase,+-- 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 [Simplify rule LHS] above.  The+-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.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}+*                                                                      *+************************************************************************+-}++-- | Configuration record for `simplifyPgm`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyOpts = SimplifyOpts+  { so_dump_core_sizes :: !Bool+  , so_iterations      :: !Int+  , so_mode            :: !SimplMode++  , so_pass_result_cfg :: !(Maybe LintPassResultConfig)+                          -- Nothing => Do not Lint+                          -- Just cfg => Lint like this++  , so_hpt_rules       :: !RuleBase+  , so_top_env_cfg     :: !TopEnvConfig+  }++simplifyPgm :: Logger+            -> UnitEnv+            -> NamePprCtx                -- For dumping+            -> SimplifyOpts+            -> ModGuts+            -> IO (SimplCount, ModGuts)  -- New bindings++simplifyPgm logger unit_env name_ppr_ctx opts+            guts@(ModGuts { mg_module = this_mod+                          , mg_binds = binds, mg_rules = local_rules+                          , mg_fam_inst_env = fam_inst_env })+  = do { (termination_msg, it_count, counts_out, guts')+            <- do_iteration 1 [] binds local_rules++        ; when (logHasDumpFlag logger Opt_D_verbose_core2core+                && logHasDumpFlag logger Opt_D_dump_simpl_stats) $+          logDumpMsg logger+                  "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+    dump_core_sizes = so_dump_core_sizes opts+    mode            = so_mode opts+    max_iterations  = so_iterations opts+    top_env_cfg     = so_top_env_cfg opts+    active_rule     = activeRule mode+    active_unf      = activeUnfolding mode+    -- Note the bang in !guts_no_binds.  If you don't force `guts_no_binds`+    -- the old bindings are retained until the end of all simplifier iterations+    !guts_no_binds = guts { mg_binds = [], mg_rules = [] }++    hpt_rule_env :: RuleEnv+    hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts)+                   -- emptyRuleBase: no EPS rules yet; we will update+                   -- them on each iteration to pick up the most up to date set++    do_iteration :: Int -- Counts iterations+                 -> [SimplCount] -- Counts from earlier iterations, reversed+                 -> CoreProgram  -- Bindings+                 -> [CoreRule]   -- Local rules for imported Ids+                 -> IO (String, Int, SimplCount, ModGuts)++    do_iteration iteration_no counts_so_far binds local_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+      = warnPprTrace (debugIsOn && (max_iterations > 2))+            "Simplifier bailing out"+            ( hang (ppr this_mod <> text ", 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 bailed out", iteration_no - 1+               , totalise counts_so_far+               , guts_no_binds { mg_binds = binds, mg_rules = local_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+                                     local_rules binds+               } ;+           Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"+                     FormatCore+                     (pprCoreBindings tagged_binds);++                -- read_eps_rules:+                -- We need to read rules from the EPS 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+                -- Hence just before attempting to match a rule we read the EPS+                -- value (via read_rule_env) and then combine it with the existing rule base.+                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.+          eps <- ueEPS unit_env ;+           let  { -- base_rule_env contains+                  --    (a) home package rules, fixed across all iterations+                  --    (b) local rules (substituted) from `local_rules` arg to do_iteration+                  -- Forcing base_rule_env to avoid unnecessary allocations.+                  -- Not doing so results in +25.6% allocations of LargeRecord.+                ; !base_rule_env = updLocalRules hpt_rule_env local_rules++                ; read_eps_rules :: IO PackageRuleBase+                ; read_eps_rules = eps_rule_base <$> ueEPS unit_env++                ; read_rule_env :: IO RuleEnv+                ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules++                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+                ; simpl_env = mkSimplEnv mode fam_envs } ;++                -- Simplify the program+           ((binds1, rules1), counts1) <-+             initSmpl logger read_rule_env top_env_cfg 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 <- simplImpRules env1 local_rules++                  ; return (getTopFloatBinds floats, rules1) } ;++                -- Stop if nothing happened; don't dump output+                -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats+           if isZeroSimplCount counts1 then+                return ( "Simplifier reached fixed point", iteration_no+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks+                       , guts_no_binds { 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 logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ;++           for_ (so_pass_result_cfg opts) $ \pass_result_cfg ->+             lintPassResult logger pass_result_cfg binds2 ;++                -- Loop+           do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           } }+      where+        -- Remember the counts_so_far are reversed+        totalise :: [SimplCount] -> SimplCount+        totalise = foldr (\c acc -> acc `plusSimplCount` c)+                         (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats)++dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules+  = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules+  where+    mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations+            | otherwise                                         = Nothing+            -- Show details if Opt_D_dump_simpl_iterations is on++    hdr = "Simplifier iteration=" ++ show iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr+                     , pprSimplCount counts+                     , text "---- End of simplifier counts for" <+> text 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+they say.  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 eliminate 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 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, [CoreTickish]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+  | isEmptyVarEnv ind_env = binds+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirection-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 RULES]+        else warnPprTrace True "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 RULES]+hasShortableIdInfo id+  =  isEmptyRuleInfo (ruleInfo info)+  && isDefaultInlinePragma (inlinePragInfo info)+  && not (isStableUnfolding (realUnfoldingInfo 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.++For the lcl_id we++* Zap the InlinePragma. 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!++* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,+  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original+  great big Stable unfolding+-}++transferIdInfo :: Id -> Id -> (Id, Id)+-- See Note [Transferring IdInfo]+transferIdInfo exported_id local_id+  = ( modifyIdInfo transfer exported_id+    , modifyIdInfo zap_info local_id )+  where+    local_info = idInfo local_id+    transfer exp_info = exp_info `setDmdSigInfo`     dmdSigInfo local_info+                                 `setCprSigInfo`     cprSigInfo local_info+                                 `setUnfoldingInfo`  realUnfoldingInfo 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++    zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma+                                 `setUnfoldingInfo`  noUnfolding
+ GHC/Core/Opt/Simplify/Env.hs view
@@ -0,0 +1,1333 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}+-}++++module GHC.Core.Opt.Simplify.Env (+        -- * The simplifier mode+        SimplMode(..), updMode, smPlatform,++        -- * Environments+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract+        seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,+        seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,+        seOptCoercionOpts, sePhase, sePlatform, sePreInline,+        seRuleOpts, seRules, seUnfoldingOpts,+        mkSimplEnv, extendIdSubst, extendCvIdSubst,+        extendTvSubst, extendCvSubst,+        zapSubstEnv, setSubstEnv, bumpCaseDepth,+        getInScope, setInScopeFromE, setInScopeFromF,+        setInScopeSet, modifyInScope, addNewInScopeIds,+        getSimplRules, enterRecGroupRHSs,+        reSimplifying,++        SimplEnvIS,  checkSimplEnvIS, pprBadSimplEnvIS,++        -- * Substitution results+        SimplSR(..), mkContEx, substId, lookupRecBndr,++        -- * Simplifying 'Id' binders+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,+        simplBinder, simplBinders,+        substTy, substTyVar, getFullSubst, getTCvSubst,+        substCo, substCoVar,++        -- * Floats+        SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,+        extendFloats, wrapFloats,+        isEmptyJoinFloats, isEmptyLetFloats,+        doFloatFromRhs, getTopFloatBinds,++        -- * LetFloats+        LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,+        addLetFlts,  mapLetFloats,++        -- * JoinFloats+        JoinFloat, JoinFloats, emptyJoinFloats,+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts+    ) where++import GHC.Prelude++import GHC.Core.Coercion.Opt ( OptCoercionOpts )+import GHC.Core.FamInstEnv ( FamInstEnv )+import GHC.Core.Opt.Arity ( ArityOpts(..) )+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Rules.Config ( RuleOpts(..) )+import GHC.Core+import GHC.Core.Utils+import GHC.Core.Subst( substExprSC )+import GHC.Core.Unfold+import GHC.Core.TyCo.Subst (emptyIdSubstEnv, mkSubst)+import GHC.Core.Multiplicity( Scaled(..), mkMultMul )+import GHC.Core.Make            ( mkWildValBinder, mkCoreLet )+import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, substCo+                                , extendTvSubst, extendCvSubst )+import qualified GHC.Core.Coercion as Coercion+import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )+import qualified GHC.Core.Type as Type++import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Id as Id+import GHC.Types.Basic+import GHC.Types.Unique.FM      ( pprUniqFM )++import GHC.Data.OrdList+import GHC.Data.Graph.UnVar++import GHC.Builtin.Types+import GHC.Platform ( Platform )++import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.List ( intersperse, mapAccumL )++{-+************************************************************************+*                                                                      *+\subsubsection{The @SimplEnv@ type}+*                                                                      *+************************************************************************+-}++{-+Note [The environments of the Simplify pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions of the Simplify pass draw their contextual data from two+environments: `SimplEnv`, which is passed to the functions as an argument, and+`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist+corresponding configuration records `SimplMode` and `TopEnvConfig` respectively.+A configuration record denotes a unary datatype bundeling the various options+and switches we provide to control the behaviour of the respective part of the+Simplify pass. The value is provided by the driver using the functions found in+the GHC.Driver.Config.Core.Opt.Simplify module.++These configuration records are part in the environment to avoid needless+copying of their values. This raises the question which data value goes in which+of the four datatypes. For each value needed by the pass we ask the following+two questions:++ * Does the value only make sense in a monadic environment?++ * Is it part of the configuration of the pass and provided by the user or is it+   it an internal value?++Examples of values that make only sense in conjunction with `SimplM` are the+logger and the values related to counting. As it does not make sense to use them+in a pure function (the logger needs IO and counting needs access to the+accumulated counts in the monad) we want these to live in `SimplTopEnv`.+Other values, like the switches controlling the behaviour of the pass (e.g.+whether to do case merging or not) are perfectly usable in a non-monadic setting.+Indeed many of those are used in guard expressions and it would be cumbersome to+query them from the monadic environment and feed them to the pure functions as+an argument. Hence we conveniently store them in the `SpecEnv` environment which+can be passed to pure functions as a whole.++Now that we know in which of the two environments a particular value lives we+turn to the second question to determine if the value is part of the+configuration record embedded in the environment or if it is stored in an own+field in the environment type. Some values like the tick factor must be provided+from outside as we can neither derive it from other values provided to us nor+does a constant value make sense. Other values like the maximal number of ticks+are computed on environment initialization and we wish not to expose the field+to the "user" or the pass -- it is an internal value. Therefore the distinction+here is between "freely set by the caller" and "internally managed by the pass".++Note that it doesn't matter for the decision procedure wheter a value is altered+throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline,+sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the+definitions of `updModeForStableUnfoldings` and `updModeForRules` in+GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the+caller of the Simplify pass needs to provide the initial values for those fields.++The decision which value goes into which datatype can be summarized by the+following table:+                                 |          Usable in a           |+                                 | pure setting | monadic setting |+    |----------------------------|--------------|-----------------|+    | Set by user                | SimplMode    | TopEnvConfig    |+    | Computed on initialization | SimplEnv     | SimplTopEnv     |++Note [Inline depth]+~~~~~~~~~~~~~~~~~~~+When we inline an /already-simplified/ unfolding, we+* Zap the substitution environment; the inlined thing is an OutExpr+* Bump the seInlineDepth in the SimplEnv+Both these tasks are done in zapSubstEnv.++The seInlineDepth tells us how deep in inlining we are.  Currently,+seInlineDepth is used for just one purpose: when we encounter a+coercion we don't apply optCoercion to it if seInlineDepth>0.+Reason: it has already been optimised once, no point in doing so again.+-}++data SimplEnv+  = SimplEnv {+     ----------- Static part of the environment -----------+     -- Static in the sense of lexically scoped,+     -- wrt the original expression++        -- See Note [The environments of the Simplify pass]+        seMode      :: !SimplMode+      , seFamEnvs   :: !(FamInstEnv, FamInstEnv)++        -- The current substitution+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr++        -- | Fast OutVarSet tracking which recursive RHSs we are analysing.+        -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.+      , seRecIds :: !UnVarSet++     ----------- 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++      , seCaseDepth   :: !Int  -- Depth of multi-branch case alternatives++      , seInlineDepth :: !Int  -- 0 initially, 1 when we inline an already-simplified+                               -- unfolding, and simplify again; and so on+                               -- See Note [Inline depth]+    }++type SimplEnvIS = SimplEnv+     -- Invariant: the substitution is empty+     -- We want this SimplEnv for its InScopeSet and flags++checkSimplEnvIS :: SimplEnvIS -> Bool+-- Check the invariant for SimplEnvIS+checkSimplEnvIS (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env++pprBadSimplEnvIS :: SimplEnvIS -> SDoc+-- Print a SimplEnv that fails checkSimplEnvIS+pprBadSimplEnvIS env = ppr (getFullSubst (seInScope env) env)++seArityOpts :: SimplEnv -> ArityOpts+seArityOpts env = sm_arity_opts (seMode env)++seCaseCase :: SimplEnv -> Bool+seCaseCase env = sm_case_case (seMode env)++seCaseFolding :: SimplEnv -> Bool+seCaseFolding env = sm_case_folding (seMode env)++seCaseMerge :: SimplEnv -> Bool+seCaseMerge env = sm_case_merge (seMode env)++seCastSwizzle :: SimplEnv -> Bool+seCastSwizzle env = sm_cast_swizzle (seMode env)++seDoEtaReduction :: SimplEnv -> Bool+seDoEtaReduction env = sm_do_eta_reduction (seMode env)++seEtaExpand :: SimplEnv -> Bool+seEtaExpand env = sm_eta_expand (seMode env)++seFloatEnable :: SimplEnv -> FloatEnable+seFloatEnable env = sm_float_enable (seMode env)++seInline :: SimplEnv -> Bool+seInline env = sm_inline (seMode env)++seNames :: SimplEnv -> [String]+seNames env = sm_names (seMode env)++seOptCoercionOpts :: SimplEnv -> OptCoercionOpts+seOptCoercionOpts env = sm_co_opt_opts (seMode env)++sePhase :: SimplEnv -> CompilerPhase+sePhase env = sm_phase (seMode env)++sePlatform :: SimplEnv -> Platform+sePlatform env = smPlatform (seMode env)++sePreInline :: SimplEnv -> Bool+sePreInline env = sm_pre_inline (seMode env)++seRuleOpts :: SimplEnv -> RuleOpts+seRuleOpts env = sm_rule_opts (seMode env)++seRules :: SimplEnv -> Bool+seRules env = sm_rules (seMode env)++seUnfoldingOpts :: SimplEnv -> UnfoldingOpts+seUnfoldingOpts env = sm_uf_opts (seMode env)++-- See Note [The environments of the Simplify pass]+data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad+  { sm_phase        :: !CompilerPhase+  , sm_names        :: ![String]      -- ^ Name(s) of the phase+  , sm_rules        :: !Bool          -- ^ Whether RULES are enabled+  , sm_inline       :: !Bool          -- ^ Whether inlining is enabled+  , sm_eta_expand   :: !Bool          -- ^ Whether eta-expansion is enabled+  , sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?+  , sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options+  , sm_case_case    :: !Bool          -- ^ Whether case-of-case is enabled+  , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled+  , sm_float_enable :: !FloatEnable   -- ^ Whether to enable floating out+  , sm_do_eta_reduction :: !Bool+  , sm_arity_opts :: !ArityOpts+  , sm_rule_opts :: !RuleOpts+  , sm_case_folding :: !Bool+  , sm_case_merge :: !Bool+  , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options+  }++instance Outputable SimplMode where+    ppr (SimplMode { sm_phase = p , sm_names = ss+                   , sm_rules = r, sm_inline = i+                   , sm_cast_swizzle = cs+                   , sm_eta_expand = eta, sm_case_case = cc })+       = text "SimplMode" <+> braces (+         sep [ text "Phase =" <+> ppr p <+>+               brackets (text (concat $ intersperse "," ss)) <> comma+             , pp_flag i   (text "inline") <> comma+             , pp_flag r   (text "rules") <> comma+             , pp_flag eta (text "eta-expand") <> comma+             , pp_flag cs (text "cast-swizzle") <> comma+             , pp_flag cc  (text "case-of-case") ])+         where+           pp_flag f s = ppUnless f (text "no") <+> s++smPlatform :: SimplMode -> Platform+smPlatform opts = roPlatform (sm_rule_opts opts)++data FloatEnable  -- Controls local let-floating+  = FloatDisabled      -- Do no local let-floating+  | FloatNestedOnly    -- Local let-floating for nested (NotTopLevel) bindings only+  | FloatEnabled       -- Do local let-floating on all bindings++{-+Note [Local floating]+~~~~~~~~~~~~~~~~~~~~~+The Simplifier can perform local let-floating: it floats let-bindings+out of the RHS of let-bindings.  See+  Let-floating: moving bindings to give faster programs (ICFP'96)+  https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/++Here's an example+   x = let y = v+1 in (y,true)++The RHS of x is a thunk.  Much better to float that y-binding out to give+   y = v+1+   x = (y,true)++Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in+the scope of the x-binding can now be simplified.++This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding,+controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs.++The `FloatEnable` data type controls where local let-floating takes place;+it allows you to specify that it should be done only for nested bindings;+or for top-level bindings as well; or not at all.++Note that all of this is quite separate from the global FloatOut pass;+see GHC.Core.Opt.FloatOut.++-}++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 }++isEmptyFloats :: SimplFloats -> Bool+-- Precondition: used only when sfJoinFloats is empty+isEmptyFloats (SimplFloats { sfLetFloats  = LetFloats fs _+                           , sfJoinFloats = js })+  = assertPpr (isNilOL js) (ppr js ) $+    isNilOL fs++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 IdSubstEnv] in GHC.Core.Subst++-- | A substitution result.+data SimplSR+  = DoneEx OutExpr JoinPointHood+       -- 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+                NotJoinPoint -> empty+                JoinPoint 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 synonyms, 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 -> (FamInstEnv, FamInstEnv) -> SimplEnv+mkSimplEnv mode fam_envs+  = SimplEnv { seMode        = mode+             , seFamEnvs     = fam_envs+             , seInScope     = init_in_scope+             , seTvSubst     = emptyVarEnv+             , seCvSubst     = emptyVarEnv+             , seIdSubst     = emptyVarEnv+             , seRecIds      = emptyUnVarSet+             , seCaseDepth   = 0+             , seInlineDepth = 0 }+        -- The top level "enclosing CC" is "SUBSUMED".++init_in_scope :: InScopeSet+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy 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,+GHC.Core.Make.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.+-}++updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv+updMode upd env+  = -- Avoid keeping env alive in case inlining fails.+    let mode = upd $! (seMode env)+    in env { seMode = mode }++bumpCaseDepth :: SimplEnv -> SimplEnv+bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }++reSimplifying :: SimplEnv -> Bool+reSimplifying (SimplEnv { seInlineDepth = n }) = n>0++---------------------+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res+  = assertPpr (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+  = assertPpr (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}++extendCvIdSubst :: SimplEnv -> Id -> OutExpr -> SimplEnv+extendCvIdSubst env bndr (Coercion co) = extendCvSubst env bndr co+extendCvIdSubst env bndr rhs           = extendIdSubst env bndr (DoneEx rhs NotJoinPoint)++---------------------+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+-- See Note [Bangs in the Simplifier]+  = let !in_scope1 = in_scope `extendInScopeSetList` vs+        !id_subst1 = id_subst `delVarEnvList` vs+    in+    env { seInScope = in_scope1,+          seIdSubst = id_subst1 }+        -- 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}++enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))+                  -> SimplM (r, SimplEnv)+enterRecGroupRHSs env bndrs k = do+  --pprTraceM "enterRecGroupRHSs" (ppr bndrs)+  (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}+  return (r, env''{seRecIds = seRecIds env})++{- 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 binding 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+-- See Note [Inline depth]+-- We call zapSubstEnv precisely when we are about to+-- simplify an already-simplified term+zapSubstEnv env@(SimplEnv { seInlineDepth = n })+  = env { seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv+        , seInlineDepth = n+1 }++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.++The `FloatFlag` contains summary information about the bindings, see the data+type declaration of `FloatFlag`++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+  NonRec x# (a /# b)    FltCareful  -- Might fail; does not satisfy let-can-float invariant+  NonRec x# (f y)       FltCareful  -- Might diverge; does not satisfy let-can-float invariant+-}++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+                -- NB: consequence: all bindings satisfy let-can-float invariant++  | 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)+                -- NB: consequence: all bindings satisfy let-can-float invariant++  | FltCareful  -- At least one binding is strict (or unlifted)+                --      and not guaranteed cheap+                -- Do not float these bindings out of a lazy let!+                -- NB: some bindings may not satisfy let-can-float++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 :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool+-- If you change this function look also at FloatIn.noFloatIntoRhs+doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+  = floatEnabled lvl fe+      && 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 && strict_bind++     -- Whether any floating is allowed by flags.+     floatEnabled :: TopLevelFlag -> FloatEnable -> Bool+     floatEnabled _ FloatDisabled = False+     floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl)+     floatEnabled _ FloatEnabled = True++{-+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++isEmptyLetFloats :: LetFloats -> Bool+isEmptyLetFloats (LetFloats fs _) = isNilOL fs++emptyJoinFloats :: JoinFloats+emptyJoinFloats = nilOL++isEmptyJoinFloats :: JoinFloats -> Bool+isEmptyJoinFloats = isNilOL++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 [Core top-level string literals] in GHC.Core.+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)+      | otherwise                = FltCareful++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' }+    -- See Note [Bangs in the Simplifier]+    !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+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats+           , sfInScope   = sfInScope floats `extendInScopeFromLF` let_floats }++extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet+extendInScopeFromLF in_scope (LetFloats binds _)+  = foldlOL extendInScopeSetBind in_scope binds++addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats+addJoinFloats floats join_floats+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats+           , sfInScope    = foldlOL extendInScopeSetBind+                                    (sfInScope floats) join_floats }++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 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 })+  = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $+    SimplFloats { sfLetFloats  = floats'+                , sfJoinFloats = jfloats'+                , sfInScope    = in_scope }+  where+    -- See Note [Bangs in the Simplifier]+    !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+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs flag+                        , sfJoinFloats = jbs }) body+  = foldrOL mk_let (wrapJoinFloats jbs body) bs+     -- Note: Always safe to put the joins on the inside+     -- since the values can't refer to them+  where+    mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant+           | otherwise          = Let       -- let-can-float invariant hold++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++{-# INLINE mapLetFloats #-}+mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats+mapLetFloats (LetFloats fs ff) fun+   = LetFloats fs1 ff+   where+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'+    app (Rec bs)     = Rec (strictMap fun bs)+    !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]++{-+************************************************************************+*                                                                      *+                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.+        --+        -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify.++refineFromInScope :: InScopeSet -> Var -> Var+refineFromInScope in_scope v+  | isLocalId v = case lookupInScope in_scope v of+                  Just v' -> v'+                  Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)+                             -- c.f #19074 for a subtle place where this went wrong+  | 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.++See also Note [Scaling join point arguments].+-}++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 env bndr+                        ; seqId id `seq` return (env', id) }++---------------+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder+simplNonRecBndr !env id+  -- See Note [Bangs in the Simplifier]+  = do  { let (!env1, id1) = substIdBndr env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders+simplRecBndrs env@(SimplEnv {}) ids+  -- See Note [Bangs in the Simplifier]+  = assert (all (not . isJoinId) ids) $+    do  { let (!env1, ids1) = mapAccumL substIdBndr env ids+        ; seqIds ids1 `seq` return env1 }++---------------+substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)+-- Might be a coercion variable+substIdBndr env bndr+  | isCoVar bndr  = substCoVarBndr env bndr+  | otherwise     = substNonCoVarIdBndr env bndr++---------------+substNonCoVarIdBndr+   :: 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 GHC.Core.Subst.substIdBndr, except that+--      the type of id_subst differs+--      all fragile info is zapped+substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)++-- Inline to make the (OutId -> OutId) function a known call.+-- This is especially important for `substNonCoVarIdBndr` which+-- passes an identity lambda.+{-# INLINE subst_id_bndr #-}+subst_id_bndr :: SimplEnv+              -> InBndr    -- Env and binder to transform+              -> (OutId -> OutId)  -- Adjust the type+              -> (SimplEnv, OutBndr)+subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })+              old_id adjust_type+  = assertPpr (not (isCoVar old_id)) (ppr old_id)+    (env { seInScope = new_in_scope,+           seIdSubst = new_subst }, new_id)+    -- It's important that both seInScope and seIdSubst are updated with+    -- the new_id, /after/ applying adjust_type. That's why adjust_type+    -- is done here.  If we did adjust_type in simplJoinBndr (the only+    -- place that gives a non-identity adjust_type) we'd have to fiddle+    -- afresh with both seInScope and seIdSubst+  where+    -- See Note [Bangs in the Simplifier]+    !id1  = uniqAway in_scope old_id+    !id2  = substIdType env id1+    !id3  = zapFragileIdInfo id2      -- Zaps rules, worker-info, unfolding+                                      -- and fragile OccInfo+    !new_id = adjust_type id3++        -- 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++    !new_in_scope = in_scope `extendInScopeSet` new_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 the in_id of a let binding to the+out_id so that its arity is visible in its RHS. Examples:++  * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)+    Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a+    hard time figuring that out when `f` only has arity 0 in its own RHS.+  * f = \x y. ....(f `seq` blah)....+    We want to drop the seq.+  * f = \x. g (\y. f y)+    You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.+    Unfortunately, it is not sound in general to eta-reduce in f's RHS.+    Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how+    we prevent 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.+-}+++{- *********************************************************************+*                                                                      *+                Join points+*                                                                      *+********************************************************************* -}++simplNonRecJoinBndr :: SimplEnv -> InBndr+                    -> Mult -> OutType+                    -> 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 id mult res_ty+  = do { let (env1, id1) = simplJoinBndr mult res_ty env id+       ; seqId id1 `seq` return (env1, id1) }++simplRecJoinBndrs :: SimplEnv -> [InBndr]+                  -> Mult -> OutType+                  -> 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 {}) ids mult res_ty+  = assert (all isJoinId ids) $+    do  { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+simplJoinBndr :: Mult -> OutType+              -> SimplEnv -> InBndr+              -> (SimplEnv, OutBndr)+simplJoinBndr mult res_ty env id+  = subst_id_bndr env id (adjustJoinPointType mult res_ty)++---------------+adjustJoinPointType :: Mult+                    -> Type     -- New result type+                    -> Id       -- Old join-point Id+                    -> Id       -- Adjusted join-point Id+-- (adjustJoinPointType mult new_res_ty join_id) does two things:+--+--   1. Set the return type of the join_id to new_res_ty+--      See Note [Return type for join points]+--+--   2. Adjust the multiplicity of arrows in join_id's type, as+--      directed by 'mult'. See Note [Scaling join point arguments]+--+-- INVARIANT: If any of the first n binders are foralls, those tyvars+-- cannot appear in the original result type. See isValidJoinPointType.+adjustJoinPointType mult new_res_ty join_id+  = assert (isJoinId join_id) $+    setIdType join_id new_join_ty+  where+    join_arity = idJoinArity join_id+    orig_ty    = idType join_id+    res_torc   = typeTypeOrConstraint new_res_ty :: TypeOrConstraint++    new_join_ty = go join_arity orig_ty :: Type++    go :: JoinArity -> Type -> Type+    go n ty+      | n == 0+      = new_res_ty++      | Just (arg_bndr, body_ty) <- splitPiTy_maybe ty+      , let body_ty' = go (n-1) body_ty+      = case arg_bndr of+          Named b                          -> mkForAllTy b body_ty'+          Anon (Scaled arg_mult arg_ty) af -> mkFunTy af' arg_mult' arg_ty body_ty'+              where+                -- Using "!": See Note [Bangs in the Simplifier]+                -- mkMultMul: see Note [Scaling join point arguments]+                !arg_mult' = arg_mult `mkMultMul` mult++                -- the new_res_ty might be ConstraintLike while the original+                -- one was TypeLike.  So we may need to adjust the FunTyFlag.+                -- (see #23952)+                !af' = mkFunTyFlag (funTyFlagArgTypeOrConstraint af) res_torc++      | otherwise+      = pprPanic "adjustJoinPointType" (ppr join_arity <+> ppr orig_ty)++{- Note [Scaling join point arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a join point which is linear in its variable, in some context E:++E[join j :: a %1 -> a+       j x = x+  in case v of+       A -> j 'x'+       B -> <blah>]++The simplifier changes to:++join j :: a %1 -> a+     j x = E[x]+in case v of+     A -> j 'x'+     B -> E[<blah>]++If E uses its argument in a nonlinear way (e.g. a case['Many]), then+this is wrong: the join point has to change its type to a -> a.+Otherwise, we'd get a linearity error.++See also Note [Return type for join points] and Note [Join points and case-of-case].+-}++{-+************************************************************************+*                                                                      *+                Impedance matching to type substitution+*                                                                      *+************************************************************************+-}++getTCvSubst :: SimplEnv -> Subst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })+  = mkSubst in_scope emptyVarEnv tv_env cv_env++getFullSubst :: InScopeSet -> SimplEnv -> Subst+getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env })+  = mk_full_subst in_scope tv_env cv_env id_env++mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst+mk_full_subst in_scope tv_env cv_env id_env+  = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env+  where+    to_expr :: SimplSR -> CoreExpr+    -- A tiresome impedence-matcher+    to_expr (DoneEx e _)           = e+    to_expr (DoneId v)             = Var v+    to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e++substTy :: HasDebugCallStack => 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+        (Subst 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+        (Subst 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)+    || no_free_vars+  = id+  | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id+                -- 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+    no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w+    subst = Subst in_scope emptyIdSubstEnv tv_env cv_env+    old_ty = idType id+    old_w  = idMult id
+ GHC/Core/Opt/Simplify/Inline.hs view
@@ -0,0 +1,751 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++This module contains inlining logic used by the simplifier.+-}++++module GHC.Core.Opt.Simplify.Inline (+        -- * Cheap and cheerful inlining checks.+        couldBeSmallEnoughToInline,+        smallEnoughToInline, activeUnfolding,++        -- * The smart inlining decisions are made by callSiteInline+        callSiteInline, CallCtxt(..),+    ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core.Opt.Simplify.Env++import GHC.Core+import GHC.Core.Unfold+import GHC.Core.FVs( exprFreeIds )++import GHC.Types.Id+import GHC.Types.Var.Env( InScopeSet, lookupInScope )+import GHC.Types.Var.Set+import GHC.Types.Basic  ( Arity, RecFlag(..), isActive )+import GHC.Utils.Logger+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Name++import Data.List (isPrefixOf)++{-+************************************************************************+*                                                                      *+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}+*                                                                      *+************************************************************************++We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that+we ``couldn't possibly use'' on the other side.  Can be overridden w/+flaggery.  Just the same as smallEnoughToInline, except that it has no+actual arguments.+-}++couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool+couldBeSmallEnoughToInline opts threshold rhs+  = case sizeExpr opts threshold [] body of+       TooBig -> False+       _      -> True+  where+    (_, body) = collectBinders rhs++----------------+smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool+smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance})+  = case guidance of+       UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts+       UnfWhen {} -> True+       UnfNever   -> False+smallEnoughToInline _ _+  = False++{-+************************************************************************+*                                                                      *+\subsection{callSiteInline}+*                                                                      *+************************************************************************++This is the key function.  It decides whether to inline a variable at a call site++callSiteInline is used at call sites, so it is a bit more generous.+It's a very important function that embodies lots of heuristics.+A non-WHNF can be inlined if it doesn't occur inside a lambda,+and occurs exactly once or+    occurs once in each branch of a case and is small++If the thing is in WHNF, there's no danger of duplicating work,+so we can inline if it occurs once, or is small++NOTE: we don't want to inline top-level functions that always diverge.+It just makes the code bigger.  Tt turns out that the convenient way to prevent+them inlining is to give them a NOINLINE pragma, which we do in+StrictAnal.addStrictnessInfoToTopId+-}++callSiteInline :: SimplEnv+               -> Logger+               -> Id                    -- The Id+               -> Bool                  -- True if there are no arguments at all (incl type args)+               -> [ArgSummary]          -- One for each value arg; True if it is interesting+               -> CallCtxt              -- True <=> continuation is interesting+               -> Maybe CoreExpr        -- Unfolding, if any+callSiteInline env logger id lone_variable arg_infos cont_info+  = case idUnfolding id of+      -- idUnfolding checks for loop-breakers, returning NoUnfolding+      -- Things with an INLINE pragma may have an unfolding *and*+      -- be a loop breaker  (maybe the knot is not yet untied)+        CoreUnfolding { uf_tmpl = unf_template+                      , uf_cache = unf_cache+                      , uf_guidance = guidance }+          | active_unf -> tryUnfolding env logger id lone_variable+                                    arg_infos cont_info unf_template+                                    unf_cache guidance+          | otherwise -> traceInline logger uf_opts id "Inactive unfolding:" (ppr id) Nothing+        NoUnfolding      -> Nothing+        BootUnfolding    -> Nothing+        OtherCon {}      -> Nothing+        DFunUnfolding {} -> Nothing     -- Never unfold a DFun+  where+    uf_opts    = seUnfoldingOpts env+    active_unf = activeUnfolding (seMode env) id++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++-- | Report the inlining of an identifier's RHS to the user, if requested.+traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a+traceInline logger opts inline_id str doc result+  -- We take care to ensure that doc is used in only one branch, ensuring that+  -- the simplifier can push its allocation into the branch. See Note [INLINE+  -- conditional tracing utilities].+  | enable    = logTraceMsg logger str doc result+  | otherwise = result+  where+    enable+      | logHasDumpFlag logger Opt_D_dump_verbose_inlinings+      = True+      | Just prefix <- unfoldingReportPrefix opts+      = prefix `isPrefixOf` occNameString (getOccName inline_id)+      | otherwise+      = False+{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities]++{- Note [Avoid inlining into deeply nested cases]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Also called "exponential inlining".++Consider a function f like this: (#18730)++  f arg1 arg2 =+    case ...+      ... -> g arg1+      ... -> g arg2++This function is small. So should be safe to inline.+However sometimes this doesn't quite work out like that.+Consider this code:++    f1 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f2 arg1 ...+          alt2 -> ... f2 arg2 ...++    f2 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f3 arg1 ...+          alt2 -> ... f3 arg2 ...++    f3 arg1 arg2 ... = ...++    ... repeats up to n times. And then f1 is+    applied to some arguments:++    foo = ... f1 <interestingArgs> ...++Initially f2..fn are not interesting to inline so we don't.  However we see+that f1 is applied to interesting args.  So it's an obvious choice to inline+those:++    foo = ...+          case _foo of+            alt1 -> ... f2 <interestingArg> ...+            alt2 -> ... f2 <interestingArg> ...++As a result we go and inline f2 both mentions of f2 in turn are now applied to+interesting arguments and f2 is small:++    foo = ...+          case _foo of+            alt1 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++            alt2 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++The same thing happens for each binding up to f_n, duplicating the amount of inlining+done in each step. Until at some point we are either done or run out of simplifier+ticks/RAM. This pattern happened #18730.++To combat this we introduce one more heuristic when weighing inlining decision.+We keep track of a "case-depth". Which increases each time we look inside a case+expression with more than one alternative.++We then apply a penalty to inlinings based on the case-depth at which they would+be inlined. Bounding the number of inlinings in such a scenario.++The heuristic can be tuned in two ways:++* We can ignore the first n levels of case nestings for inlining decisions using+  -funfolding-case-threshold.++* The penalty grows linear with the depth. It's computed as+     size*(depth-threshold)/scaling.+  Scaling can be set with -funfolding-case-scaling.++Reflections and wrinkles++* See also Note [Do not add unfoldings to join points at birth] in+  GHC.Core.Opt.Simplify.Iteration++* The total case depth is really the wrong thing; it will inhibit inlining of a+  local function, just because there is some giant case nest further out.  What we+  want is the /difference/ in case-depth between the binding site and the call site.+  That could be done quite easily by adding the case-depth to the Unfolding of the+  function.++* What matters more than /depth/ is total /width/; that is how many alternatives+  are in the tree.  We could perhaps multiply depth by width at each case expression.++* There might be a case nest with many alternatives, but the function is called in+  only a handful of them.  So maybe we should ignore case-depth, and instead penalise+  funtions that are called many times -- after all, inlining them bloats code.++  But in the scenario above, we are simplifying an inlined fuction, without doing a+  global occurrence analysis each time.  So if we based the penalty on multiple+  occurences, we should /also/ add a penalty when simplifying an already-simplified+  expression.  We do track this (seInlineDepth) but currently we barely use it.++  An advantage of using occurrences+inline depth is that it'll work when no+  case expressions are involved.  See #15488.++* Test T18730 did not involve join points.  But join points are very prone to+  the same kind of thing.  For exampe in #13253, and several related tickets,+  we got an exponential blowup in code size from a program that looks like+  this.++  let j1a x = case f y     of { True -> p;   False -> q }+      j1b x = case f y     of { True -> q;   False -> p }+      j2a x = case f (y+1) of { True -> j1a x; False -> j1b x}+      j2b x = case f (y+1) of { True -> j1b x; False -> j1a x}+      ...+  in case f (y+10) of { True -> j10a 7; False -> j10b 8 }++  The first danger is this: in Simplifier iteration 1 postInlineUnconditionally+  inlines the last functions, j10a and j10b (they are both small).  Now we have+  two calls to j9a and two to j9b.  In the next Simplifer iteration,+  postInlineUnconditionally inlines all four of these calls, leaving four calls+  to j8a and j8b. Etc.++  Happily, this probably /won't/ happen because the Simplifier works top down, so it'll+  inline j1a/j1b into j2a/j2b, which will make the latter bigger; so the process+  will stop.  But we still need to stop the inline cascade described at the head+  of this Note.++Some guidance on setting these defaults:++* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of+  control. We picked 2 for no particular reason.++* Scaling the penalty by any more than 30 means the reproducer from+  T18730 won't compile even with reasonably small values of n. Instead+  it will run out of runs/ticks. This means to positively affect the reproducer+  a scaling <= 30 is required.++* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.+  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)++* A scaling of >= 25 showed no regressions on nofib. However it showed a number of+  (small) regression for compiler perf benchmarks.++The end result is that we are settling for a scaling of 30, with a threshold of 2.+This gives us minimal compiler perf regressions. No nofib runtime regressions and+will still avoid this pattern sometimes. This is a "safe" default, where we err on+the side of compiler blowup instead of risking runtime regressions.++For cases where the default falls short the flag can be changed to allow+more/less inlining as needed on a per-module basis.++-}++tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance+             -> Maybe CoreExpr+tryUnfolding env logger id lone_variable arg_infos+             cont_info unf_template unf_cache guidance+ = case guidance of+     UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing++     UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }+        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts)+                -- See Note [INLINE for small functions] (3)+        -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template)+        | otherwise+        -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing+        where+          some_benefit = calc_some_benefit uf_arity True+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)++     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }+        | isJoinId id, small_enough         -> inline_join_point+        | unfoldingVeryAggressive opts      -> yes+        | is_wf, some_benefit, small_enough -> yes+        | otherwise                         -> no+        where+          yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True)  (Just unf_template)+          no  = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing++          some_benefit = calc_some_benefit (length arg_discounts) False++          -- depth_penalty: see Note [Avoid inlining into deeply nested cases]+          depth_threshold = unfoldingCaseThreshold opts+          depth_scaling   = unfoldingCaseScaling opts+          depth_penalty | case_depth <= depth_threshold = 0+                        | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling++          adjusted_size = size + depth_penalty - discount+          small_enough = adjusted_size <= unfoldingUseThreshold opts+          discount = computeDiscount arg_discounts res_discount arg_infos cont_info++          extra_doc = vcat [ ppWhen (isJoinId id) $+                             text "join" <+> fsep [ ppr (v, hasCoreUnfolding (idUnfolding v)+                                                        , fmap (isEvaldUnfolding . idUnfolding) (lookupInScope in_scope v)+                                                        , is_more_evald in_scope v)+                                                  | v <- vselems (exprFreeIds unf_template) ]+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "adjusted size =" <+> int adjusted_size ]++          inline_join_point  -- See Note [Inlining join points]+            | or (zipWith scrut_arg arg_discounts arg_infos) = yes+            | anyVarSet (is_more_evald in_scope) $+              exprFreeIds unf_template                       = yes+            | otherwise                                      = no+          -- scrut_arg is True if the function body has a discount and the arg is a value+          scrut_arg disc ValueArg = disc > 0+          scrut_arg _    _        = False++  where+    opts         = seUnfoldingOpts env+    case_depth   = seCaseDepth env+    inline_depth = seInlineDepth env+    in_scope     = seInScope env++    -- Unpack the UnfoldingCache lazily because it may not be needed, and all+    -- its fields are strict; so evaluating unf_cache at all forces all the+    -- isWorkFree etc computations to take place.  That risks wasting effort for+    -- Ids that are never going to inline anyway.+    -- See Note [UnfoldingCache] in GHC.Core+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache++    mk_doc some_benefit extra_doc yes_or_no+      = vcat [ text "arg infos" <+> ppr arg_infos+             , text "interesting continuation" <+> ppr cont_info+             , text "some_benefit" <+> ppr some_benefit+             , text "is exp:" <+> ppr is_exp+             , text "is work-free:" <+> ppr is_wf+             , text "guidance" <+> ppr guidance+             , text "case depth =" <+> int case_depth+             , text "inline depth =" <+> int inline_depth+             , extra_doc+             , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]++    ctx = log_default_dump_context (logFlags logger)+    str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)+    n_val_args = length arg_infos++           -- some_benefit is used when the RHS is small enough+           -- and the call has enough (or too many) value+           -- arguments (ie n_val_args >= arity). But there must+           -- be *something* interesting about some argument, or the+           -- result context, to make it worth inlining+    calc_some_benefit :: Arity -> Bool -> Bool   -- The Arity is the number of args+                                         -- expected by the unfolding+    calc_some_benefit uf_arity is_inline+       | not saturated = interesting_args       -- Under-saturated+                                        -- Note [Unsaturated applications]+       | otherwise = interesting_args   -- Saturated or over-saturated+                  || interesting_call+      where+        saturated      = n_val_args >= uf_arity+        over_saturated = n_val_args > uf_arity+        interesting_args = any nonTriv arg_infos+                -- NB: (any nonTriv arg_infos) looks at the+                -- over-saturated args too which is "wrong";+                -- but if over-saturated we inline anyway.++        interesting_call+          | over_saturated+          = True+          | otherwise+          = case cont_info of+              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone variables]+              ValAppCtxt -> True                           -- Note [Cast then apply]+              RuleArgCtxt -> uf_arity > 0  -- See Note [RHS of lets]+              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]+              RhsCtxt NonRecursive | is_inline+                          -> uf_arity > 0  -- See Note [RHS of lets]+              _other      -> False         -- See Note [Nested functions]+++vselems :: VarSet -> [Var]+vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s++is_more_evald :: InScopeSet -> Id -> Bool+-- See Note [Inlining join points]+is_more_evald in_scope v+  | Just v1 <- lookupInScope in_scope v+  , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v+  = True+  | otherwise+  = False++{- Note [RHS of lets]+~~~~~~~~~~~~~~~~~~~~~+When the call is the argument of a function with a RULE, or the RHS of a let,+we are a little bit keener to inline (in tryUnfolding).  For example+     f y = (y,y,y)+     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...+We'd inline 'f' if the call was in a case context, and it kind-of-is,+only we can't see it.  Also+     x = f v+could be expensive whereas+     x = case v of (a,b) -> a+is patently cheap and may allow more eta expansion.++So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a+/non-recursive/ let as not-totally-boring.  A /recursive/ let isn't+going be inlined so there is much less point.  Hence the (only reason+for the) RecFlag in RhsCtxt++We inline only if `f` has an `UnfWhen` guidance.  I found that being more eager+led to fruitless inlining.  See Note [Seq is boring] wrinkle (SB1) in+GHC.Core.Opt.Simplify.Utils.++Note [Inlining join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we /do not/ want to inline join points /even if they are small/.+See Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration.++But, assuming it is small, there are various times when we /do/ want to+inline a (non-recursive) join point.  Namely, if either of these hold:++(1) A /scrutinised/ argument (non-zero discount) has a /ValueArg/ info.+    Inlining will give some benefit.++(2) A free variable of the RHS is+    * Is /not/ evaluated at the join point defn site+    * Is evaluated at the join point call site.+    This is the is_more_evald predicate.++(1) is fairly obvious but (2) is less so. Here is the code for `integerGT`+without (2):++  integerGt = \ (x :: Integer) (y :: Integer) ->+     join fail _ = case x of {+       IS x1 -> case y of {+           IS y1 -> case <# x1 y1  of+                      _DEFAULT -> case ==# x1 y1 of+                                    DEFAULT -> True;+                                    1#      -> False+                      1# -> False+           IP ds1 -> False+           IN ds1 -> True++       IP x1 -> case y of {+                 _DEFAULT -> True;+                 IP y1    -> case bigNatCompare x1 y1 of+                               _DEFAULT -> False;+                               GT -> True+       IN x1 -> case y of {+                  _DEFAULT -> False;+                  IN y1    -> case bigNatCompare y1 x1 of+                                _DEFAULT -> False;+                                GT -> True+     in case x of {+       _DEFAULT -> jump fail GHC.Prim.(##);+       IS x1    -> case y of {+                     _DEFAULT -> jump fail GHC.Prim.(##);+                     IS y1 -> tagToEnum# @Bool (># x1 y1)++If we inline `fail` we get /much/ better code.  The only clue is that+`x` and `y` (a) are not evaluated at the definition site, and (b) are+evaluated at the call site.  This predicate is `isBetterUnfoldingThan`.++You might think that the variable should also be /scrutinised/ in the+join-point RHS, but here are two reasons for not taking that into+account.++First, we see code somewhat like this in imaginary/wheel-sieve1:+    let x = <small thunk> in+    join $j = (x,y) in+    case z of+      A -> case x of+             P -> $j+             Q -> blah+      B -> (x,x)+      C -> True+Here `x` can't be duplicated into the branches becuase it is used+in both the join point and the A branch.  But if we inline $j we get+    let x = <small thunk> in+    case z of+      A -> case x of x'+             P -> (x', y)+             Q -> blah+      B -> x+      C -> True+and now we /can/ duplicate x into the branches, at which point:+  * it is used strictly in the A branch (evaluated, but no thunk)+  * it is used lazily in the B branch (still a thunk)+  * it is not used at all in the C branch (no thunk)++Second, spectral/treejoin gets a big win from SpecConstr due+to evaluated-ness. Something like this:+    join $j x = ...(foo fv)...+    in case fv of I# x ->+       ...  jump $j True ...+If we inline $j, SpecConstr sees a call (foo (I# x)) and specialises.++Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a call is not saturated, we *still* inline if one of the+arguments has interesting structure.  That's sometimes very important.+A good example is the Ord instance for Bool in Base:++ Rec {+    $fOrdBool =GHC.Classes.D:Ord+                 @ Bool+                 ...+                 $cmin_ajX++    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool+    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool+  }++But the defn of GHC.Classes.$dmmin is:++  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a+    {- Arity: 3, HasNoCafRefs, Strictness: SLL,+       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->+                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {+                     GHC.Types.False -> y GHC.Types.True -> x }) -}++We *really* want to inline $dmmin, even though it has arity 3, in+order to unravel the recursion.+++Note [Things to watch]+~~~~~~~~~~~~~~~~~~~~~~+*   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }+    Assume x is exported, so not inlined unconditionally.+    Then we want x to inline unconditionally; no reason for it+    not to, and doing so avoids an indirection.++*   { x = I# 3; ....f x.... }+    Make sure that x does not inline unconditionally!+    Lest we get extra allocation.++Note [Nested functions]+~~~~~~~~~~~~~~~~~~~~~~~+At one time we treated a call of a non-top-level function as+"interesting" (regardless of how boring the context) in the hope+that inlining it would eliminate the binding, and its allocation.+Specifically, in the default case of interesting_call we had+   _other -> not is_top && uf_arity > 0++But actually postInlineUnconditionally does some of this and overall+it makes virtually no difference to nofib.  So I simplified away this+special case++Note [Cast then apply]+~~~~~~~~~~~~~~~~~~~~~~+Consider+   myIndex = __inline_me ( (/\a. <blah>) |> co )+   co :: (forall a. a -> a) ~ (forall a. T a)+     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...++We need to inline myIndex to unravel this; but the actual call (myIndex a) has+no value arguments.  The ValAppCtxt gives it enough incentive to inline.++Note [Inlining in ArgCtxt]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The condition (arity > 0) here is very important, because otherwise+we end up inlining top-level stuff into useless places; eg+   x = I# 3#+   f = \y.  g x+This can make a very big difference: it adds 16% to nofib 'integer' allocs,+and 20% to 'power'.++At one stage I replaced this condition by 'True' (leading to the above+slow-down).  The motivation was test eyeball/inline1.hs; but that seems+to work ok now.++NOTE: arguably, we should inline in ArgCtxt only if the result of the+call is at least CONLIKE.  At least for the cases where we use ArgCtxt+for the RHS of a 'let', we only profit from the inlining if we get a+CONLIKE thing (modulo lets).++Note [Lone variables]+~~~~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables]+which appears below++The "lone-variable" case is important.  I spent ages messing about+with unsatisfactory variants, but this is nice.  The idea is that if a+variable appears all alone++        as an arg of lazy fn, or rhs    BoringCtxt+        as scrutinee of a case          CaseCtxt+        as arg of a fn                  ArgCtxt+AND+        it is bound to a cheap expression++then we should not inline it (unless there is some other reason,+e.g. it is the sole occurrence).  That is what is happening at+the use of 'lone_variable' in 'interesting_call'.++Why?  At least in the case-scrutinee situation, turning+        let x = (a,b) in case x of y -> ...+into+        let x = (a,b) in case (a,b) of y -> ...+and thence to+        let x = (a,b) in let y = (a,b) in ...+is bad if the binding for x will remain.++Another example: I discovered that strings+were getting inlined straight back into applications of 'error'+because the latter is strict.+        s = "foo"+        f = \x -> ...(error s)...++Fundamentally such contexts should not encourage inlining because, provided+the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the+context can ``see'' the unfolding of the variable (e.g. case or a+RULE) so there's no gain.++However, watch out:++ * Consider this:+        foo = \n. [n])  {-# INLINE foo #-}+        bar = foo 20    {-# INLINE bar #-}+        baz = \n. case bar of { (m:_) -> m + n }+   Here we really want to inline 'bar' so that we can inline 'foo'+   and the whole thing unravels as it should obviously do.  This is+   important: in the NDP project, 'bar' generates a closure data+   structure rather than a list.++   So the non-inlining of lone_variables should only apply if the+   unfolding is regarded as expandable; because that is when+   exprIsConApp_maybe looks through the unfolding.  Hence the "&&+   is_exp" in the CaseCtxt branch of interesting_call++ * Even a type application or coercion isn't a lone variable.+   Consider+        case $fMonadST @ RealWorld of { :DMonad a b c -> c }+   We had better inline that sucker!  The case won't see through it.++   For now, I'm treating treating a variable applied to types+   in a *lazy* context "lone". The motivating example was+        f = /\a. \x. BIG+        g = /\a. \y.  h (f a)+   There's no advantage in inlining f here, and perhaps+   a significant disadvantage.  Hence some_val_args in the Stop case++Note [Interaction of exprIsWorkFree and lone variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The lone-variable test says "don't inline if a case expression+scrutinises a lone variable whose unfolding is cheap".  It's very+important that, under these circumstances, exprIsConApp_maybe+can spot a constructor application. So, for example, we don't+consider+        let x = e in (x,x)+to be cheap, and that's good because exprIsConApp_maybe doesn't+think that expression is a constructor application.++In the 'not (lone_variable && is_wf)' test, I used to test is_value+rather than is_wf, which was utterly wrong, because the above+expression responds True to exprIsHNF, which is what sets is_value.++This kind of thing can occur if you have++        {-# INLINE foo #-}+        foo = let x = e in (x,x)++which Roman did.+++-}++computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt+                -> Int+computeDiscount arg_discounts res_discount arg_infos cont_info++  = 10          -- Discount of 10 because the result replaces the call+                -- so we count 10 for the function itself++    + 10 * length actual_arg_discounts+               -- Discount of 10 for each arg supplied,+               -- because the result replaces the call++    + total_arg_discount + res_discount'+  where+    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos+    total_arg_discount   = sum actual_arg_discounts++    mk_arg_discount _        TrivArg    = 0+    mk_arg_discount _        NonTrivArg = 10+    mk_arg_discount discount ValueArg   = discount++    res_discount'+      | LT <- arg_discounts `compareLength` arg_infos+      = res_discount   -- Over-saturated+      | otherwise+      = case cont_info of+           BoringCtxt  -> 0+           CaseCtxt    -> res_discount  -- Presumably a constructor+           ValAppCtxt  -> res_discount  -- Presumably a function+           _           -> 40 `min` res_discount+                -- ToDo: this 40 `min` res_discount doesn't seem right+                --   for DiscArgCtxt it shouldn't matter because the function will+                --       get the arg discount for any non-triv arg+                --   for RuleArgCtxt we do want to be keener to inline; but not only+                --       constructor results+                --   for RhsCtxt I suppose that exposing a data con is good in general+                --   And 40 seems very arbitrary+                --+                -- res_discount can be very large when a function returns+                -- constructors; but we only want to invoke that large discount+                -- when there's a case continuation.+                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.+                -- But we want to avoid inlining large functions that return+                -- constructors into contexts that are simply "interesting"
+ GHC/Core/Opt/Simplify/Iteration.hs view
@@ -0,0 +1,4827 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[Simplify]{The main module of the simplifier}+-}+++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}++module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.ConstantFold+import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline+import GHC.Core.Opt.Simplify.Utils+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make+import GHC.Core.Coercion hiding ( substCo, substCoVar )+import GHC.Core.Reduction+import GHC.Core.Coercion.Opt    ( optCoercion )+import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )+import GHC.Core.DataCon+import GHC.Core.Opt.Stats ( Tick(..) )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe+                          , pushCoTyArg, pushCoValArg, exprIsDeadEnd+                          , typeArity, arityTypeArity, etaExpandAT )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.FVs     ( mkRuleInfo {- exprsFreeIds -} )+import GHC.Core.Rules   ( lookupRule, getRules )+import GHC.Core.Multiplicity++import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.Id.Make   ( seqId )+import GHC.Types.Id.Info+import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )+import GHC.Types.Demand+import GHC.Types.Unique ( hasKey )+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var    ( isTyCoVar )+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )+import GHC.Builtin.Names( runRWKey, seqHashKey )++import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )+import GHC.Data.FastString+import GHC.Unit.Module ( moduleName )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger+import GHC.Utils.Misc++import Control.Monad+import Data.List.NonEmpty (NonEmpty (..))++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in GHC.Core.Opt.Pipeline++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+     - 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.++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.++Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.++Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.++++************************************************************************+*                                                                      *+\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 rewrite 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 "GHC.Core.Opt.OccurAnal".+        -- See Note [Bangs in the Simplifier]+        ; !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+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env (BC_Let TopLevel Recursive) pairs+    simpl_bind env (NonRec b r)+      = do { let bind_cxt = BC_Let TopLevel NonRecursive+           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt+           ; simplRecOrTopPair env' bind_cxt b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> BindContext+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 bind_cxt pairs0+  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0+        ; let new_bndrs = map sndOf3 triples+        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+                                go env triples+        ; return (mkRecFloats rec_floats, env2) }+  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) bind_cxt+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env bind_cxt+                                                  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+                  -> BindContext+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)+                                          old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | otherwise+  = case bind_cxt of+      BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $+                             simplJoinBind is_rec cont+                                           (old_bndr,env) (new_bndr,env) (rhs,env)++      BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind top_lvl is_rec+                                             (old_bndr,env) (new_bndr,env) (rhs,env)++simplTrace :: String -> SDoc -> SimplM a -> SimplM a+simplTrace herald doc thing_inside = do+  logger <- getLogger+  if logHasDumpFlag logger Opt_D_verbose_core2core+    then logTraceMsg logger herald doc thing_inside+    else thing_inside++--------------------------+simplLazyBind :: TopLevelFlag -> RecFlag+              -> (InId, SimplEnv)       -- InBinder, and static env for its unfolding (if any)+              -> (OutId, SimplEnv)      -- OutBinder, and SimplEnv after simplifying that binder+                                        -- The OutId has IdInfo (notably RULES),+                                        -- except arity, unfolding+              -> (InExpr, SimplEnv)     -- The RHS and its static environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: Ids only, no TyVars; not a JoinId+-- Precondition: rhs obeys the let-can-float invariant+simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)+  = assert (isId bndr )+    assertPpr (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 -- See Note [Bangs in the Simplifier]+                (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 GHC.Core.Opt.Simplify.Utils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+                                   is_rec (idDemandInfo bndr)+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++        -- ANF-ise a constructor or PAP rhs+        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}+                                   prepareBinding env top_lvl is_rec+                                                  False  -- Not strict; this is simplLazyBind+                                                  bndr1 body_floats0 body0+          -- Subtle point: we do not need or want tvs' in the InScope set+          -- of body_floats2, so we pass in 'env' not 'body_env'.+          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do+          -- more renaming than necessary => extra work (see !7777 and test T16577).+          -- Don't need: we wrap tvs' around the RHS anyway.++        ; (rhs_floats, body3)+            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     return (body_floats2, body2)++                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (poly_floats, body3) }++        ; let env1 = env `setInScopeFromF` rhs_floats+        ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: RecFlag+              -> SimplCont+              -> (InId, SimplEnv)       -- InBinder, with static env for its unfolding+              -> (OutId, SimplEnv)      -- OutBinder; SimplEnv has the binder in scope+                                        -- The OutId has IdInfo, except arity, unfolding+              -> (InExpr, SimplEnv)     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se)+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) }++--------------------------+simplAuxBind :: String+             -> SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of completeBindX used to construct non-recursive+-- auxiliary bindings, notably in knownCon.+--+-- The binder comes from a case expression (case binder or alternative)+-- and so does not have rules, unfolding, inline pragmas etc.+--+-- Precondition: rhs satisfies the let-can-float invariant++simplAuxBind _str env bndr new_rhs+  | assertPpr (isId bndr && 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)++  -- Next we have a fast-path for cases that would be inlined unconditionally by+  -- completeBind: but it seems not uncommon, and it turns to be a little more+  -- efficient (in compile time allocations) to do it here.+  -- Effectively this is just a vastly-simplified postInlineUnconditionally+  --   See Note [Post-inline for single-use things] in GHC.Core.Opt.Simplify.Utils+  -- We could instead use postInlineUnconditionally itself, but I think it's simpler+  --   and more direct to focus on the "hot" cases.+  -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings+  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...+    || case (idOccInfo bndr) of+          OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True+          _                                                 -> False+  = return ( emptyFloats env+           , extendCvIdSubst env bndr new_rhs )  -- bndr can be a CoVar++  | otherwise+  = do  { -- ANF-ise the RHS+          let !occ_fs = getOccFS bndr+        ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs+        ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)+        ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats++          -- Simplify the binder and complete the binding+        ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr+        ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (new_bndr, rhs1, env1)++        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           Cast worker/wrapper+*                                                                      *+************************************************************************++Note [Cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a binding+   x = e |> co+we want to do something very similar to worker/wrapper:+   $wx = e+   x = $wx |> co++We call this making a cast worker/wrapper in tryCastWorkerWrapper.++The main motivaiton is that x can be inlined freely.  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+          t = T m+          go 0 = 0+          go n = case t of { T m -> go (n-m) }+                -- This case should optimise++A second reason for doing cast worker/wrapper is that the worker/wrapper+pass after strictness analysis can't deal with RHSs like+     f = (\ a b c. blah) |> co+Instead, it relies on cast worker/wrapper to get rid of the cast,+leaving a simpler job for demand-analysis worker/wrapper.  See #19874.++Wrinkles++1. We must /not/ do cast w/w on+     f = g |> co+   otherwise it'll just keep repeating forever! You might think this+   is avoided because the call to tryCastWorkerWrapper is guarded by+   preInlineUnconditinally, but I'm worried that a loop-breaker or an+   exported Id might say False to preInlineUnonditionally.++2. We need to be careful with inline/noinline pragmas:+       rec { {-# NOINLINE f #-}+             f = (...g...) |> co+           ; g = ...f... }+   This is legitimate -- it tells GHC to use f as the loop breaker+   rather than g.  Now we do the cast thing, to get something like+       rec { $wf = ...g...+           ; f = $wf |> co+           ; g = ...f... }+   Where should the NOINLINE pragma go?  If we leave it on f we'll get+     rec { $wf = ...g...+         ; {-# NOINLINE f #-}+           f = $wf |> co+         ; g = ...f... }+   and that is bad: the whole point is that we want to inline that+   cast!  We want to transfer the pagma to $wf:+      rec { {-# NOINLINE $wf #-}+            $wf = ...g...+          ; f = $wf |> co+          ; g = ...f... }+   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.+      {- f: Stable unfolding = <stable-big> -}+      f = (\xy. <big-body>) |> co+   Then we want to w/w to+      {- $wf: Stable unfolding = <stable-big> |> sym co -}+      $wf = \xy. <big-body>+      f = $wf |> co+   Notice that the stable unfolding moves to the worker!  Now demand analysis+   will work fine on $wf, whereas it has trouble with the original f.+   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.+   This point also applies to strong loopbreakers with INLINE pragmas, see+   wrinkle (4).++4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence+   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to+   loop-breakers) because they'll definitely be inlined anyway, cast and+   all. And if we do cast w/w for an INLINE function with arity zero, we get+   something really silly: we inline that "worker" right back into the wrapper!+   Worse than a no-op, because we have then lost the stable unfolding.++All these wrinkles are exactly like worker/wrapper for strictness analysis:+  f is the wrapper and must inline like crazy+  $wf is the worker and must carry f's original pragma+See Note [Worker/wrapper for INLINABLE functions]+and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++See #17673, #18093, #18078, #19890.++Note [Preserve strictness in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Cast worker/wrapper] 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 [Preserve RuntimeRep info in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not do cast w/w when the presence of the coercion is needed in order+to determine the runtime representation.++Example:++  Suppose we have a type family:++    type F :: RuntimeRep+    type family F where+      F = LiftedRep++  together with a type `ty :: TYPE F` and a top-level binding++    a :: ty |> TYPE F[0]++  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.+  However, were we to apply cast w/w, we would get:++    b :: ty+    b = ...++    a :: ty |> TYPE F[0]+    a = b `cast` GRefl (TYPE F[0])++  Now we are in trouble because `ty :: TYPE F` does not have a known runtime+  representation, because we need to be able to reduce the nullary type family+  application `F` to find that out.++Conclusion: only do cast w/w when doing so would not lose the RuntimeRep+information. That is, when handling `Cast rhs co`, don't attempt cast w/w+unless the kind of the type of rhs is concrete, in the sense of+Note [Concrete types] in GHC.Tc.Utils.Concrete.+-}++tryCastWorkerWrapper :: SimplEnv -> BindContext+                     -> InId -> OutId -> OutExpr+                     -> SimplM (SimplFloats, SimplEnv)+-- See Note [Cast worker/wrapper]+tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)+  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points+  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform+                        --            a DFunUnfolding in mk_worker_unfolding+  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1+  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4+  , typeHasFixedRuntimeRep work_ty    -- Don't peel off a cast if doing so would+                                      -- lose the underlying runtime representation.+                                      -- See Note [Preserve RuntimeRep info in cast w/w]+  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings+                                                   -- See Note [OPAQUE pragma]+  = do  { uniq <- getUniqueM+        ; let work_name = mkSystemVarName uniq occ_fs+              work_id   = mkLocalIdWithInfo work_name ManyTy work_ty work_info+              is_strict = isStrictId bndr++        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict+                                                   work_id (emptyFloats env) rhs++        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs+        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf+               floats   = rhs_floats `addLetFloats`+                          unitLetFloat (NonRec work_id_w_unf work_rhs)++               triv_rhs = Cast (Var work_id_w_unf) co++        ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs+             -- Almost always True, because the RHS is trivial+             -- In that case we want to eliminate the binding fast+             -- We conservatively use postInlineUnconditionally so that we+             -- check all the right things+          then do { tick (PostInlineUnconditionally bndr)+                  ; return ( floats+                           , extendIdSubst (setInScopeFromF env floats) old_bndr $+                             DoneEx triv_rhs NotJoinPoint ) }++          else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs+                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+                                `setIdUnfolding`  wrap_unf+                        floats' = floats `extendFloats` NonRec bndr' triv_rhs+                  ; return ( floats', setInScopeFromF env floats' ) } }+  where+    -- Force the occ_fs so that the old Id is not retained in the new Id.+    !occ_fs = getOccFS bndr+    work_ty = coercionLKind co+    info   = idInfo bndr+    work_arity = arityInfo info `min` typeArity work_ty++    work_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info+                              `setCprSigInfo`     cprSigInfo info+                              `setDemandInfo`     demandInfo info+                              `setInlinePragInfo` inlinePragInfo info+                              `setArityInfo`      work_arity+           -- We do /not/ want to transfer OccInfo, Rules+           -- Note [Preserve strictness in cast w/w]+           -- and Wrinkle 2 of Note [Cast worker/wrapper]++    ----------- Worker unfolding -----------+    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);+    --   the next round of simplification will do the job+    -- Non-stable case: use work_rhs+    -- Wrinkle 3 of Note [Cast worker/wrapper]+    mk_worker_unfolding top_lvl work_id work_rhs+      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers+           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })+           _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs++tryCastWorkerWrapper env _ _ bndr rhs  -- All other bindings+  = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr+                                   , text "rhs:" <+> ppr rhs ])+        ; return (mkFloatBind env (NonRec bndr rhs)) }++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast worker/wrapper]+mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })+  = InlinePragma { inl_src    = SourceText $ fsLit "{-# INLINE"+                 , inl_inline = fn_inl       -- See Note [Worker/wrapper for INLINABLE functions]+                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap+                 , inl_act    = wrap_act     -- See Note [Wrapper activation]+                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap+                                -- RuleMatchInfo is (and must be) unaffected+  where+    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap+    -- But simpler, because we don't need to disable during InitialPhase+    wrap_act | isNeverActive fn_act = activateDuringFinal+             | otherwise            = fn_act+++{- *********************************************************************+*                                                                      *+           prepareBinding, prepareRhs, makeTrivial+*                                                                      *+********************************************************************* -}++prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool+               -> Id   -- Used only for its OccName; can be InId or OutId+               -> SimplFloats -> OutExpr+               -> SimplM (SimplFloats, OutExpr)+-- In (prepareBinding ... bndr floats rhs), the binding is really just+--    bndr = let floats in rhs+-- Maybe we can ANF-ise this binding and float out; e.g.+--    bndr = let a = f x in K a a (g x)+-- we could float out to give+--    a    = f x+--    tmp  = g x+--    bndr = K a a tmp+-- That's what prepareBinding does+-- Precondition: binder is not a JoinId+-- Postcondition: the returned SimplFloats contains only let-floats+prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs+  = do { -- Never float join-floats out of a non-join let-binding (which this is)+         -- So wrap the body in the join-floats right now+         -- Hence: rhs_floats1 consists only of let-floats+         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs++         -- rhs_env: add to in-scope set the binders from rhs_floats+         -- so that prepareRhs knows what is in scope in rhs+       ; let rhs_env = env `setInScopeFromF` rhs_floats1+             -- Force the occ_fs so that the old Id is not retained in the new Id.+             !occ_fs = getOccFS bndr++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2+         then -- Float!+              do { tick LetFloatFromLet+                 ; return (all_floats, rhs2) }++         else -- Abandon floating altogether; revert to original rhs+              -- Since we have already built rhs1, we just need to add+              -- rhs_floats1 to it+              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }++{- 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 :: HasDebugCallStack+           => SimplEnv -> TopLevelFlag+           -> FastString    -- Base for any new variables+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by ANF'ing args+-- for expandable RHSs: constructors and PAPs+-- e.g        x = Just e+-- becomes    a = e               -- 'a' is fresh+--            x = Just a+-- See Note [prepareRhs]+prepareRhs env top_lvl occ rhs0+  | is_expandable = anfise rhs0+  | otherwise     = return (emptyLetFloats, rhs0)+  where+    -- We can't use exprIsExpandable because the WHOLE POINT is that+    -- we want to treat (K <big>) as expandable, because we are just+    -- about "anfise" the <big> expression.  exprIsExpandable would+    -- just say no!+    is_expandable = go rhs0 0+       where+         go (Var fun) n_val_args       = isExpandableApp fun n_val_args+         go (App fun arg) n_val_args+           | isTypeArg arg             = go fun n_val_args+           | otherwise                 = go fun (n_val_args + 1)+         go (Cast rhs _)  n_val_args   = go rhs n_val_args+         go (Tick _ rhs)  n_val_args   = go rhs n_val_args+         go _             _            = False++    anfise :: OutExpr -> SimplM (LetFloats, OutExpr)+    anfise (Cast rhs co)+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Cast rhs' co) }+    anfise (App fun (Type ty))+        = do { (floats, rhs') <- anfise fun+             ; return (floats, App rhs' (Type ty)) }+    anfise (App fun arg)+        = do { (floats1, fun') <- anfise fun+             ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+             ; return (floats1 `addLetFlts` floats2, App fun' arg') }+    anfise (Var fun)+        = return (emptyLetFloats, Var fun)++    anfise (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (floats, rhs') <- anfise rhs+             ; return (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 { (floats, rhs') <- anfise rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (floats', Tick t rhs') }++    anfise other = return (emptyLetFloats, other)++makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })+  = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e+       ; return (floats, arg { as_arg = e' }) }+makeTrivialArg _ arg@(TyArg {})+  = return (emptyLetFloats, arg)++makeTrivial :: HasDebugCallStack+            => SimplEnv -> TopLevelFlag -> Demand+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]+makeTrivial env top_lvl dmd occ_fs expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | Cast expr' co <- expr+  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'+       ; return (floats, Cast triv_expr co) }++  | otherwise -- 'expr' is not of form (Cast e co)+  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr+        ; uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name ManyTy expr_ty id_info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1+          -- Technically we should extend the in-scope set in 'env' with+          -- the 'floats' from prepareRHS; but they are all fresh, so there is+          -- no danger of introducing name shadowing in eta expansion++        ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2++        ; let final_id = addLetBndrInfo var arity_type unf+              bind     = NonRec final_id expr2++        ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }+  where+    id_info = vanillaIdInfo `setDemandInfo` dmd+    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 [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 [Core top-level string literals] in GHC.Core.++************************************************************************+*                                                                      *+          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+  - extend the InScopeSet of the SimplEnv++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 :: BindContext+             -> (InId, SimplEnv)           -- Old binder, and the static envt in which to simplify+                                           --   its stable unfolding (if any)+             -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId.+                                           -- And the SimplEnv with that OutId in scope.+             -> 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-can-float invariant+completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)+ | 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  = realUnfoldingInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs++        -- Simplify the unfolding; see Note [Environment for simplLetUnfolding]+      ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env)+                            bind_cxt old_bndr+                            eta_rhs (idType new_bndr) new_arity old_unf++      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding+        -- See Note [In-scope set as a substitution]++      ; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs+                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]+                 ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $+                   return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx unf_rhs (idJoinPointHood 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; do cast worker/wrapper+--             simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr+--                                             , text "eta_rhs" <+> ppr eta_rhs ]) $+             tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info eta_rhs }++addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf+  = new_bndr `setIdInfo` info5+  where+    new_arity = arityTypeArity new_arity_type+    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]+    info3 | isEvaldUnfolding new_unf+          = lazifyDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 = case arityTypeBotSigs_maybe new_arity_type of+        Nothing -> info3+        Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $+                                       info3 `setDmdSigInfo` str_sig+                                             `setCprSigInfo` cpr_sig++     -- 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 [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \y. error (y ++ "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 (or f's) RHS is bottom to x's (or f's)+IdInfo as rapidly as possible.++We use tryEtaExpandRhs on every binding, and it turns out that the+arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++There is a second reason for settting  the strictness signature. Consider+   let -- f :: <[S]b>+       f = \x. error "urk"+   in ...(f a b c)...+Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`+to eta-expand to+   let f = \x y z. error "urk"+   in ...(f a b c)...++But now f's strictness signature has too short an arity; see+GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth].+Fortuitously, the same strictness-signature-fixup code+gives the function a new strictness signature with the right number of+arguments.  Example in stranal/should_compile/EtaExpansion.++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...++Note [Use occ-anald RHS in postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we postInlineUnconditionally 'f in+  let f = \x -> x True in ...(f blah)...+then we'd like to inline the /occ-anald/ RHS for 'f'.  If we+use the non-occ-anald version, we'll end up with a+    ...(let x = blah in x True)...+and hence an extra Simplifier iteration.++We already /have/ the occ-anald version in the Unfolding for+the Id.  Well, maybe not /quite/ always.  If the binder is Dead,+postInlineUnconditionally will return True, but we may not have an+unfolding because it's too big. Hence the belt-and-braces `orElse`+in the defn of unf_rhs.  The Nothing case probably never happens.++Note [Environment for simplLetUnfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be rather careful about the static environment in which+we simplify a stable unfolding.  Consider (#24242):++  f x = let y_Xb = ... in+        let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in+         ...++Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen;+see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier].+This is perfectly fine. The `y_Xb` in the stable unfolding of the non-+recursive binding for `step1` refers, of course, to `let y_Xb = ....`.+When simplifying the binder `step1_Xb` we'll give it a new unique, and+extend the static environment with [Xb :-> step1_Xc], say.++But when simplifying step1's stable unfolding, we must use static environment+/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps+[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc].++That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping+track of the right environment for the unfolding of that InId.  See the type+of `simplLazyBind`, `simplJoinBind`, `completeBind`.++This only matters when we have+  - A non-recursive binding for f+  - has a stable unfolding+  - and that unfolding mentions a variable y+  - that has the same unique as f.+So triggering  a bug here is really hard!++************************************************************************+*                                                                      *+\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) -- See Note [Bangs in the Simplifier]+  = 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) $+    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 -- See Note [Bangs in the Simplifier]+  = -- 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 :: HasDebugCallStack+            => SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) cont+  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)+    -- 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 "simplInId" #-} simplInId 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 } }+      _       ->+          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will+          -- be forced only if we need to run contHoleType.+          -- When these are forced, we might get quadratic behavior;+          -- this quadratic blowup could be avoided by drilling down+          -- to the function and getting its multiplicities all at once+          -- (instead of one-at-a-time). But in practice, we have not+          -- observed the quadratic behavior, so this extra entanglement+          -- seems not worthwhile.+        simplExprF env fun $+        ApplyToVal { sc_arg = arg, sc_env = env+                   , sc_hole_ty = substTy env (exprType fun)+                   , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env (zapLambdaBndrs expr n_args) cont+        -- zapLambdaBndrs: the 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+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++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 env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+    -- Because of the let-can-float invariant, it's ok to+    -- inline freely, or to drop the binding if it is dead.+  = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $+         tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++  -- Now check for a join point.  It's better to do the preInlineUnconditionally+  -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial+  -- binding like { j = j2 |> co } would first be eta-expanded and then inlined+  -- Better to test preInlineUnconditionally first.+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-}+    simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-}+    simplNonRecE env FromLet 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 [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | JoinPoint arity <- idJoinPointHood bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+              mult = contHoleScaling cont+        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) 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 { let opt_co | reSimplifying env = substCo env co+                    | otherwise         = optCoercion opts subst co+             -- If (reSimplifying env) is True we have already simplified+             -- this coercion once, and we don't want do so again; doing+             -- so repeatedly risks non-linear behaviour+             -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env+       ; seqCo opt_co `seq` return opt_co }+  where+    subst = getTCvSubst env+    opts  = seOptCoercionOpts env++-----------------------------------+-- | 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 -> CoreTickish -> 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.++--------------------------+--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)+-- 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.+--------------------------++  -- 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 (Alt c bs e) = Alt 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) = (zapIdDmdSig (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 ext bid ids <- tickish+          = Breakpoint ext bid (mapMaybe (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 cont@(CastIt { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = Just id+  getDoneId (DoneEx (Var id) _) = Just id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst+  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)+rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont++rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- only the in-scope set matters, plus the flags.+rebuild_go env expr cont+  = assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $+    case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild_go env (mkTick t expr) cont+      CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }+        -> rebuild_go env (mkCast expr co') cont+           -- NB: mkCast implements the (Coercion co |> g) optimisation+        where+          co' = optOutCoercion env co opt++      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, sc_fun_ty = fun_ty }+        -> rebuildCall env (addValArgTo fun expr fun_ty) cont++      StrictBind { sc_bndr = b, sc_body = body, sc_env = se+                 , sc_cont = cont, sc_from = from_what }+        -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild_go env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag+                 , sc_cont = cont, sc_hole_ty = fun_ty }+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg+              ; rebuild_go env (App expr arg') cont }++completeBindX :: SimplEnv+              -> FromWhat+              -> InId -> OutExpr   -- Non-recursively bind this Id to this (simplified) expression+                                   -- (the let-can-float invariant may not be satisfied)+              -> InExpr            -- In this body+              -> SimplCont         -- Consumed by this continuation+              -> SimplM (SimplFloats, OutExpr)+completeBindX env from_what bndr rhs body cont+  | FromBeta arg_levity <- from_what+  , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant+  = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules+       ; (floats, expr') <- simplNonRecBody env1 from_what body cont+       -- Do not float floats past the Case binder below+       ; let expr'' = wrapFloats floats expr'+             case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+       ; return (emptyFloats env, case_expr) }++  | otherwise -- Make a let-binding+  = do  { (env1, bndr1) <- simplNonRecBndr env bndr+        ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)++        ; let is_strict = isStrictId bndr2+              -- isStrictId: use simplified binder because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism]++        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               bndr2 (emptyFloats env) rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is completeBindX, so bndr is not in scope in the RHS.++        ; let env3 = env2 `setInScopeFromF` rhs_floats+        ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (bndr2, rhs1, env3)+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        -- Simplify the body+        ; (body_floats, body') <- simplNonRecBody env4 from_what body cont++        ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats+        ; return ( all_floats, body' ) }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we will use pushCoTyArg and pushCoValArg successively, which+   build up SelCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.++Note [Avoid re-simplifying coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some benchmarks (with deeply nested cases) we successively push+casts onto the SimplCont.  We don't want to call the coercion optimiser+on each successive composition -- that's at least quadratic.  So:++* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to+  record whether the coercion optimiser has been applied to the coercion.++* In `simplCast`, when we see (Cast e co), we simplify `co` to get+  an OutCoercion, and built a CastIt with sc_opt=True.++  Actually not quite: if we are simplifying the result of inlining an+  unfolding (seInlineDepth > 0), then instead of /optimising/ it again,+  just /substitute/ which is cheaper.  See `simplCoercion`.++* In `addCoerce` (in `simplCast`) if we combine this new coercion with+  an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False.++* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise+  the (presumably composed) coercion if sc_opt=False; this is done+  by `optOutCoercion`.++* When duplicating a continuation in `mkDupableContWithDmds`, before+  duplicating a CastIt, optimise the coercion. Otherwise we'll end up+  optimising it separately in the duplicate copies.+-}+++optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion+-- See Note [Avoid re-simplifying coercions]+optOutCoercion env co already_optimised+  | already_optimised = co  -- See Note [Avoid re-simplifying coercions]+  | otherwise         = optCoercion opts empty_subst co+  where+    empty_subst = mkEmptySubst (seInScope env)+    opts = seOptCoercionOpts env++simplCast :: SimplEnv -> InExpr -> InCoercion -> 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 True cont0+                        -- True <=> co1 is optimised+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where++        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl    _   cont = return cont+        addCoerceM (MCo co) opt cont = addCoerce co opt cont++        addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont })  -- See Note [Optimising reflexivity]+          = addCoerce (mkTransCo co1 co2) False cont+                      -- False: (mkTransCo co1 co2) is not fully optimised+                      -- See Note [Avoid re-simplifying coercions]++        addCoerce co opt (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' opt tail+               ; return (ApplyToTy { sc_arg_ty  = arg_ty'+                                   , sc_cont    = tail'+                                   , sc_hole_ty = coercionLKind co }) }+                                        -- NB!  As the cast goes past, the+                                        -- type of the hole changes (#16312)+        -- (f |> co) e   ===>   (f (e |> co1)) |> co2+        -- where   co :: (s1->s2) ~ (t1->t2)+        --         co1 :: t1 ~ s1+        --         co2 :: s2 ~ t2+        addCoerce co opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                          , sc_dup = dup, sc_cont = tail+                                          , sc_hole_ty = fun_ty })+          | not opt  -- pushCoValArg duplicates the coercion, so optimise first+          = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont++          | Just (m_co1, m_co2) <- pushCoValArg co+          , fixed_rep m_co1+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 opt tail+               ; case m_co1 of {+                   MRefl -> return (cont { sc_cont = tail'+                                         , sc_hole_ty = coercionLKind co }) ;+                      -- See Note [Avoiding simplifying repeatedly]++                   MCo co1 ->+            do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail'+                                    , sc_hole_ty = coercionLKind co }) } } }++        addCoerce co opt cont+          | isReflCo co = return cont  -- Having this at the end makes a huge+                                       -- difference in T12227, for some reason+                                       -- See Note [Optimising reflexivity]+          | otherwise = return (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })++        fixed_rep :: MCoercionR -> Bool+        fixed_rep MRefl    = True+        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co+          -- Without this check, we can get an argument which does not+          -- have a fixed runtime representation.+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- test: typecheck/should_run/EtaExpandLevPoly++simplLazyArg :: SimplEnvIS              -- ^ Used only for its InScopeSet+             -> DupFlag+             -> OutType                 -- ^ Type of the function applied to this arg+             -> Maybe ArgInfo           -- ^ Just <=> This arg `ai` occurs in an app+                                        --   `f a1 ... an` where we have ArgInfo on+                                        --   how `f` uses `ai`, affecting the Stop+                                        --   continuation passed to 'simplExprC'+             -> StaticEnv -> CoreExpr   -- ^ Expression with its static envt+             -> SimplM (DupFlag, StaticEnv, OutExpr)+simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { let arg_env' = arg_env `setInScopeFromE` env+       ; let arg_ty = funArgTy fun_ty+       ; let stop = case mb_arg_info of+               Nothing -> mkBoringStop arg_ty+               Just ai -> mkLazyArgStop arg_ty ai+       ; arg' <- simplExprC arg_env' arg stop+       ; return (Simplified, zapSubstEnv arg_env', arg') }+         -- Return a StaticEnv that includes the in-scope set from 'env',+         -- because arg' may well mention those variables (#20639)++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplNonRecBody :: SimplEnv -> FromWhat+                -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+simplNonRecBody env from_what body cont+  = case from_what of+      FromLet     -> simplExprF env body cont+      FromBeta {} -> simplLam   env body cont++simplLam :: SimplEnv -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont+simplLam env expr            cont = simplExprF env expr cont++simpl_lam :: HasDebugCallStack+          => SimplEnv -> InBndr -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- Type beta-reduction+simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) body cont }++-- Coercion beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se+                                    , sc_cont = cont })+  = assertPpr (isCoVar bndr) (ppr bndr) $+    do { tick (BetaReduction bndr)+       ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co+       ; simplLam (extendCvSubst env bndr arg_co') body cont }++-- Value beta-reduction+-- This works for /coercion/ lambdas too+simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                    , sc_cont = cont, sc_dup = dup+                                    , sc_hole_ty = fun_ty})+  = do { tick (BetaReduction bndr)+       ; let from_what = FromBeta arg_levity+             arg_levity+               | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted+               | otherwise         = typeLevity (funArgTy fun_ty)+             -- Example:  (\(cv::a ~# b). blah) co+             -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType++             -- Using fun_ty: see Note [Dark corner with representation polymorphism]+             -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+             --      When we come to `x=arg` we must choose lazy/strict correctly+             --      It's wrong to err in either direction+             --      But fun_ty is an OutType, so is fully substituted++       ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se+            , not (needsCaseBindingL arg_levity arg)+              -- Ok to test arg::InExpr in needsCaseBinding because+              -- exprOkForSpeculation is stable under simplification+            , not ( isSimplified dup &&  -- See (SR2) in Note [Avoiding simplifying repeatedly]+                    not (exprIsTrivial arg) &&+                    not (isDeadOcc (idOccInfo bndr)) )+            -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $+                    tick (PreInlineUnconditionally bndr)+                  ; simplLam env' body cont }++            | isSimplified dup  -- Don't re-simplify if we've simplified it once+                                -- Including don't preInlineUnconditionally+                                -- See Note [Avoiding simplifying repeatedly]+            -> completeBindX env from_what bndr arg body cont++            | otherwise+            -> simplNonRecE env from_what bndr (arg, arg_se) body cont }++-- 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.+simpl_lam env bndr body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simpl_lam env bndr body cont++-- Not enough args, so there are real lambdas left to put in the result+simpl_lam env bndr body cont+  = do  { let (inner_bndrs, inner_body) = collectBinders body+        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)+        ; body'   <- simplExpr env' inner_body+        ; new_lam <- rebuildLam env' bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Historically this had a special case for when a lambda-binder+-- could have a stable unfolding;+-- see Historical Note [Case binders and join points]+-- But now it is much simpler! We now only remove unfoldings.+-- See Note [Never put `OtherCon` unfoldings on lambda binders]+simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: HasDebugCallStack+             => SimplEnv+             -> FromWhat+             -> InId               -- The binder, always an Id+                                   -- Never a join point+                                   -- The static env for its unfolding (if any) is the first parameter+             -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)+             -> InExpr             -- Body of the let/lambda+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * from=FromLet:  a non-top-level non-recursive non-join-point let-expression+--  * from=FromBeta: a binding arising from a beta reduction+--+-- simplNonRecE env b (rhs, rhs_se) body k+--   = let env in+--     cont< let b = rhs_se(rhs) in body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process.+--+-- from_what=FromLet => the RHS satisfies the let-can-float invariant+-- Otherwise it may or may not satisfy it.++simplNonRecE env from_what bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) $+    is_strict_bind+  = -- Evaluate RHS strictly+    simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })++  | otherwise  -- Evaluate RHS lazily+  = do { (env1, bndr1)    <- simplNonRecBndr env bndr+       ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind NotTopLevel NonRecursive+                                           (bndr,env) (bndr2,env2) (rhs,rhs_se)+       ; (floats2, expr') <- simplNonRecBody env3 from_what body cont+       ; return (floats1 `addFloats` floats2, expr') }++  where+    is_strict_bind = case from_what of+       FromBeta Unlifted -> True+       -- If we are coming from a beta-reduction (FromBeta) we must+       -- establish the let-can-float invariant, so go via StrictBind+       -- If not, the invariant holds already, and it's optional.++       -- (FromBeta Lifted) or FromLet: look at the demand info+       _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)+++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+-- Precondition: not a join-point binding+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 (BC_Let NotTopLevel Recursive) pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Dark corner with representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail+if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).+So we are careful to call `isStrictId` on the OutId, not the InId, in case we have+     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)+That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell+if x is lifted or unlifted from that.++We only get such redexes from the compulsory inlining of a wired-in,+representation-polymorphic function like `rightSection` (see+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined+such compulsory inlinings already, but belt and braces does no harm.++Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the+Simplifier without first calling SimpleOpt, so anything involving+GHCi or TH and operator sections will fall over if we don't take+care here.++Note [Avoiding simplifying repeatedly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and then re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression (#13379).++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+   (forcing this simplification is why we have the RULE in this example)+ * We inline f = \x. g x, in `simpl_lam`+ * So if `simpl_lam` did preInlineUnconditionally we get (g BIG)+ * Now if g has a RULE we'll simplify BIG again, and this whole thing can+   iterate.+ * However, if `f` did not have a RULE, so that BIG has /not/ already been+   simplified, we /want/ to do preInlineUnconditionally in simpl_lam.++So we go to some effort to avoid repeatedly simplifying the same thing:++* ApplyToVal has a (sc_dup :: DupFlag) field which records if the argument+  has been evaluated.++* simplArg checks this flag to avoid re-simplifying.++* simpl_lam has:+    - a case for (isSimplified dup), which goes via completeBindX, and+    - a case for an un-simplified argument, which tries preInlineUnconditionally++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - We sometimes try rewrite RULES befoe simplifying arguments;+      see Note [tryRules: plan (BEFORE)]++Wrinkles:++(SR1) All that said /postInlineUnconditionally/ (called in `completeBind`) does+    fire in the above (f BIG) situation.  See Note [Post-inline for single-use+    things] in Simplify.Utils.  This certainly risks repeated simplification,+    but in practice seems to be a small win.++(SR2) When considering preInlineUnconditionally in `simpl_lam`, if the+   expression is trivial, or it is dead (the binder doesn't occur), then there+   is no danger of simplifying repeatedly. But there is a benefit: it can save+   a simplifier iteration.  So we check for that.+++************************************************************************+*                                                                      *+                     Join points+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 was caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+   = assert (isJoinId bndr ) $+     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 mult   = contHoleScaling cont+              res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)+        ; (floats1, env3)  <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (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+             mult   = contHoleScaling cont+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 (BC_Join Recursive 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 (seCaseCase env)+    -- See Note [Join points with -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         -- Used only in error message+             -> JoinPointHood+             -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ NotJoinPoint cont+  = cont -- Not a jump+trimJoinCont var (JoinPoint 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 mkDupableCont.+++Note [Join points with -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 continuation into the RHS of the+join point j" if we also push the continuation 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+*                                                                      *+************************************************************************++Note [zapSubstEnv]+~~~~~~~~~~~~~~~~~~+When simplifying something that has already been simplified, be sure to+zap the SubstEnv.  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!!++Note [Fast path for lazy data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For applications of a /lazy/ data constructor worker, the full glory of+rebuildCall is a waste of effort;+* They never inline, obviously+* They have no rewrite rules+* Lazy constructors don't need the `StrictArg` treatment.+So it's fine to zoom straight to `rebuild` which just rebuilds the+call in a very straightforward way.++For a data constructor worker that is strict (see Note [Strict fields in Core])+we take the slow path, so that we'll transform+  K (case x of (a,b) -> a)  -->   case x of (a,b) -> K a+via the StrictArg case of rebuildCall++Some programs have a /lot/ of data constructors in the source program+(compiler/perf/T9961 is an example), so this fast path can be very+valuable.+-}++simplInVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplInVar env var+  -- Why $! ? See Note [Bangs in the Simplifier]+  | 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 -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplInId env var cont+  | Just dc <- isDataConWorkId_maybe var+  , isLazyDataConRep dc                    -- See Note [Fast path for lazy data constructors]+  = rebuild zapped_env (Var var) cont+  | otherwise+  = case substId env var of+      ContEx tvs cvs ids e -> simplExprF env' e cont+        -- Don't trimJoinCont; haven't already simplified e,+        -- so the cont is not embodied in e+        where+          env' = setSubstEnv env tvs cvs ids++      DoneId out_id -> simplOutId zapped_env out_id cont'+        where+          cont' = trimJoinCont out_id (idJoinPointHood out_id) cont++      DoneEx e mb_join -> simplExprF zapped_env e cont'+        where+          cont' = trimJoinCont var mb_join cont+  where+    zapped_env =  zapSubstEnv env  -- See Note [zapSubstEnv]++---------------------------------------------------------+simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)++---------- The runRW# rule ------+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.+--+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o+-- K[ runRW# @rr @hole_ty body ]   -->   runRW @rr' @ty' (\s. K[ body s ])+simplOutId env fun cont+  | fun `hasKey` runRWKey+  , ApplyToTy  { sc_cont = cont1 } <- cont+  , ApplyToTy  { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1+  , ApplyToVal { sc_cont = cont3, sc_arg = arg+               , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2+  -- Do this even if (contIsStop cont), or if seCaseCase is off.+  -- See Note [No eta-expansion in runRW#]+  = do { let arg_env = arg_se `setInScopeFromE` env++             overall_res_ty = contResultType cont3+             -- hole_ty is the type of the current runRW# application+             (outer_cont, new_runrw_res_ty, inner_cont)+                | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3)+                | otherwise      = (cont3, hole_ty, mkBoringStop hole_ty)+                -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+                --    Note [Case-of-case and full laziness]++       -- If the argument is a literal lambda already, take a short cut+       -- This isn't just efficiency:+       --    * If we don't do this we get a beta-redex every time, so the+       --      simplifier keeps doing more iterations.+       --    * Even more important: see Note [No eta-expansion in runRW#]+       ; arg' <- case arg of+           Lam s body -> do { (env', s') <- simplBinder arg_env s+                            ; body' <- simplExprC env' body inner_cont+                            ; return (Lam s' body') }+                            -- Important: do not try to eta-expand this lambda+                            -- See Note [No eta-expansion in runRW#]++           _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy+                   ; let (m,_,_) = splitFunTy fun_ty+                         env'  = arg_env `addNewInScopeIds` [s']+                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'+                                            , sc_env = env', sc_cont = inner_cont+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }+                                -- cont' applies to s', then K+                   ; body' <- simplExprC env' arg cont'+                   ; return (Lam s' body') }++       ; let rr'   = getRuntimeRep new_runrw_res_ty+             call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']+       ; rebuild env call' outer_cont }++-- Normal case for (f e1 .. en)+simplOutId env fun cont+  = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules]+    do { rule_base <- getSimplRules+       ; let rules_for_me = getRules rule_base fun+             out_args     = contOutArgs env cont :: [OutExpr]+       ; mb_match <- if not (null rules_for_me) &&+                        (isClassOpId fun || activeUnfolding (seMode env) fun)+                     then tryRules env rules_for_me fun out_args+                     else return Nothing+       ; case mb_match of {+             Just (rule_arity, rhs) -> simplExprF env rhs $+                                       dropContArgs rule_arity cont ;+             Nothing ->++    -- Try inlining+    do { logger <- getLogger+       ; mb_inline <- tryInlining env logger fun cont+       ; case mb_inline of{+            Just expr -> do { checkedTick (UnfoldingDone fun)+                            ; simplExprF env expr cont } ;+            Nothing ->++    -- Neither worked, so just rebuild+    do { let arg_info = mkArgInfo env fun rules_for_me cont+       ; rebuildCall env arg_info cont+    } } } } }++---------------------------------------------------------+--      Dealing with a call site++rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- it is usually empty, and regardless should be ignored.+-- Only the in-scope set matters, plus the seMode flags++-- Check the invariant+rebuildCall env arg_info _cont+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env $$ ppr arg_info) False+  = pprPanic "rebuildCall" empty++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.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++---------- Simplify type applications --------------+rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont++---------- Simplify value arguments --------------------+rebuildCall env fun_info+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_hole_ty = fun_ty+                        , sc_cont = cont })+  -- Argument is already simplified+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont++  -- Strict arguments+  | isStrictArgInfo fun_info+  , seCaseCase env    -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+                      --    Note [Case-of-case and full laziness]+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+                          , sc_dup = Simplified+                          , sc_cont = cont })+                -- Note [Shadowing in the Simplifier]++  -- Lazy arguments+  | otherwise+        -- 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') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg+        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont+  | null rules+  = rebuild env (argInfoExpr fun rev_args) cont+  | otherwise  -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]+  = do { let args = reverse rev_args+       ; mb_match <- tryRules env rules fun (map argSpecArg args)+       ; case mb_match of+           Just (rule_arity, rhs) -> simplExprF env rhs $+                                     pushSimplifiedArgs env (drop rule_arity args) cont+           Nothing -> rebuild env (argInfoExpr fun rev_args) cont }++-----------------------------------+tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)+tryInlining env logger var cont+  | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont+  = do { dump_inline expr cont+       ; return (Just expr) }++  | otherwise+  = return Nothing++  where+    (lone_variable, arg_infos, call_cont) = contArgs cont+    interesting_cont = interestingCallContext env call_cont++    log_inlining doc+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)+           Opt_D_dump_inlinings+           "" FormatText doc++    dump_inline unfolding cont+      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()+      | not (logHasDumpFlag logger Opt_D_verbose_core2core)+      = when (isExternalName (idName var)) $+            log_inlining $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = log_inlining $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]+++{- Note [When to apply rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we apply rewrite rules before simplifying the arguments, or after?+Each is highly desirable in some cases, and in fact we do both!++  - Plan (BEFORE) selectively, in `simplOutId`+    See Note [tryRules: plan (BEFORE)]++  - Plan (AFTER) always, in the finishing-up case of `rebuildCall`+    See Note [tryRules: plan (AFTER)]++Historical note.  Pre-2025, GHC only did tryRules once, when it had simplified+enough arguments to saturate all the RULEs it had in hand.  But alas, if a new+unrelated RULE showed up (but did not fire), it could nevertheless change the+simplifier's behaviour a bit; and that messed up deterministic compilation+(#25170).  (This was particularly nasty if the rule wasn't even transitively+below the module being compiled.)  Current solution: ensure that adding a new,+unrelated rule that never fires does not change the simplifier behaviour.  End+of historical note.++Note [tryRules: plan (BEFORE)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is sometimes desirable to apply RULES before simplifying the function+arguments.  We do so in `simplOutId`.++We do so /selectively/ (see (BF2)), in two particular cases:++* 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, if+      (+) dNumInt e2 e3   -->    (\x y -> ....) e2 e3+  Frequently `x` is used just once in the body of the (\x y -> ...).+  If `e2` is un-simplified we can preInlineUnconditinally and that saves+  simplifying `e2` twice. See Note [Avoiding simplifying repeatedly].++* Specialisation RULES.  In general we try to arrange that inlining is disabled+  (via a pragma) if a rewrite rule should apply, so that the rule has a decent+  chance to fire before we inline the function.++  But it turns out that (especially when type-class specialisation or+  SpecConstr is involved) it is very helpful for the the rewrite rule to+  "win" over inlining when both are active at once: see #21851, #22097.++  So if the Id has an unfolding, we want to try RULES before we try inlining.++Wrinkles:++(BF1) Each un-simplified argument has its own static environment, stored+  in its `ApplyToVal` nodes.   So we can't just match on the un-simplified+  arguments: we  have to apply that static environment as a substitution+  first!  This is done lazily in `GHC.Core.Opt.Simplify.Utils.contOutArgs`,+  so it'll be done just enough to allow the rule to match, or not.++(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc:++  * We want Plan (BEFORE) for class ops (see above in this Note)++  * But we do NOT want Plan (BEFORE) for primops, because the constant-folding+    rules are quite complicated and expensive, and we don't want to try them+    twice.  Moreover the benefts of Plan (BEFORE), described in the Note, don't+    apply to primops.++Note [tryRules: plan (AFTER)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified,+because doing so ensures that rule cascades work in one pass. We do this+in the finishing-up case of `rebuildCall`.++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 for++* Superclass selectors+        op ($p1 ($p2 (df d)))+  We want all this to unravel in one sweep++* Constant folding+        +# 3# (+# 4# 5#)+  We want this to happen in one pass++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES often apply to simplified arguments (see Note [Plan (AFTER)]),+there's a danger of simplifying already-simplified arguments.  For example,+suppose we have+   RULE f (x,y) = $sf x  y+and the expression+   f (p,q) e1 e2+With Plan (AFTER) by the time the rule fires, we will have already simplified e1, e2,+and we want to avoid doing so a second time.  So ApplyToVal records if the argument+is already Simplified.++Note [Shadowing in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This part of the simplifier may return an expression that has shadowing.+(See Note [Shadowing in Core] in GHC.Core.hs.) 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!++See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils.++Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda.  Why not?  Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> OutId -> [OutExpr]+         -> SimplM (Maybe (FullArgCount, CoreExpr))++tryRules env rules fn args+  | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env+                                        act_fun fn args rules+  -- Fire a rule for the function+  = do { logger <- getLogger+       ; checkedTick (RuleFired (ruleName rule))+       ; let occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump logger rule rule_rhs+       ; return (Just (ruleArity rule, occ_anald_rhs)) }++  | otherwise  -- No rule fires+  = do { logger <- getLogger+       ; nodump logger  -- This ensures that an empty file is written+       ; return Nothing }++  where+    ropts        = seRuleOpts env :: RuleOpts+    in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv+    act_fun      = activeRule (seMode env) :: Activation -> Bool++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump logger rule rule_rhs+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Full arity:" <+>  ppr (ruleArity rule)+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> pprCoreExpr rule_rhs ]++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = log_rule Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump logger+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_rewrites++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_firings++      | otherwise+      = return ()++    log_rule flag hdr details+      = do+      { logger <- getLogger+      ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText+               $ sep [text hdr, nest 4 details]+      }++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+-- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr`+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; let seq_rules = getRules rule_base seqId+       ; mb_match <- tryRules in_env seq_rules seqId out_args+       ; case mb_match of+            Nothing                -> return Nothing+            Just (rule_arity, rhs) -> return (Just (rhs, cont'))+                where+                  cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont+       }+  where+    no_cast_scrut = drop_casts scrut++    -- All these are OutTypes+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b+    res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b+    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b+    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty+    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty+    rhs_ty    = substTy in_env (exprType rhs)+    rhs_rep   = getRuntimeRep rhs_ty++    out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut]+               -- Cheaper than (map argSpecArg out_arg_specs)+    out_arg_specs  = [ TyArg { as_arg_ty  = rhs_rep+                        , as_hole_ty = seq_id_ty }+                     , TyArg { as_arg_ty  = scrut_ty+                             , as_hole_ty = res1_ty }+                     , TyArg { as_arg_ty  = rhs_ty+                             , as_hole_ty = res2_ty }+                     , ValArg { as_arg = no_cast_scrut+                              , as_dmd = seqDmd+                              , as_hole_ty = res3_ty } ]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont+                           , sc_hole_ty = res4_ty }++    -- 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 GHC.Types.Id.Make.++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.++Note, however, that the rule RHS is /already/ occ-analysed; see+Note [OccInfo in unfoldings and rules] in GHC.Core.  There is something+unsatisfactory about doing it twice; but the rule RHS is usually very+small, and this is simple.++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 GHC.Core.Opt.Simplify.Utils.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 GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be eliminated 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-can-float 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]++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 /could/ safely transform to+   let r = <scrut> in ...r...+As a special case,  we have a plain `seq` like+   case r of r1 { _ -> ...r1... }+where `r` is used strictly, we /could/ simply drop the `case` to get+   ...r....++HOWEVER, there are some serious downsides to this transformation, so+GHC doesn't do it any longer (#24251):++* Suppose the Simplifier sees+     case x of y* { __DEFAULT ->+     let z = case y of { __DEFAULT -> expr } in+     z+1 }+  The "y*" means "y is used strictly in its scope.  Now we may:+     - Eliminate the inner case because `y` is evaluated.+  Now the demand-info on `y` is not right, because `y` is no longer used+  strictly in its scope.  But it is hard to spot that without doing a new+  demand analysis.  So there is a danger that we will subsequently:+     - Eliminate the outer case because `y` is used strictly+  Yikes!  We can't eliminate both!++* It introduces space leaks (#24251).  Consider+      go 0 where go x = x `seq` go (x + 1)+  It is an infinite loop, true, but it should not leak space. Yet if we drop+  the `seq`, it will.  Another great example is #21741.++* Dropping the outer `case` 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").  Tht is OK accoring to the paper "A semantics for+  imprecise exceptions", but see #8900 for an example where the loss of this+  transformation bit us in practice.++* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x`+  is strictly used, and we could soundly transform to+     let x = e in f x+  But if f's strictness info got worse (which can happen in in obscure cases;+  see #21392) then we might have turned a non-thunk into a thunk!  Bad.++Lacking this "drop-strictly-used-seq" transformation means we can end up with+some redundant-looking evals.  For example, consider+    f x y = case x of DEFAULT ->    -- A redundant-looking eval+            case y of+              True  -> case x of { Nothing -> False; Just z  -> z }+              False -> case x of { Nothing -> True;  Just z  -> z }+That outer eval will be retained right through to code generation.  But,+perhaps surprisingly, that is probably a /good/ thing:++   Key point: those inner (case x) expressions will be compiled a simple 'if',+   because the code generator can see that `x` is, at those points, evaluated+   and properly tagged.++If we dropped the outer eval, both the inner (case x) expressions would need to+do a proper eval, pushing a return address, with an info table. See the example+in #15631 where, in the Description, the (case ys) will be a simple multi-way+jump.++In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs+transformation, binary sizes fell by 1%, and a few programs actually allocated+less and ran faster.  A case in point is nofib/imaginary/digits-of-e2. (I'm not+sure exactly why it improves so much, though.)++Slightly related: Note [Empty case alternatives] in GHC.Core.++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 _)    = isStrUsedDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+we cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.++Note [Do not duplicate constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#20125)+   let x = (a,b)+   in ...(case x of x' -> blah)...x...x...++We want that `case` to vanish (since `x` is bound to a data con) leaving+   let x = (a,b)+   in ...(let x'=x in blah)...x..x...++In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,+since is bound to (a,b).  But in eliminating the case, if the scrutinee+is trivial, we want to bind the case-binder to the scrutinee, /not/ to+the constructor application.  Hence the case_bndr_rhs in rebuildCase.++This applies equally to a non-DEFAULT case alternative, say+   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...+This variant is handled by bind_case_bndr in knownCon.++We want to bind x' to x, and not to a duplicated (a,b)).+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing             -> missingAlt env case_bndr alts cont+            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; let scaled_wfloats = map scale_float wfloats+              -- case_bndr_unf: see Note [Do not duplicate constructor applications]+              case_bndr_rhs | exprIsTrivial scrut = scrut+                            | otherwise           = con_app+              con_app = Var (dataConWorkId con) `mkTyApps` ty_args+                                                `mkApps`   other_args+        ; case findAlt (DataAlt con) alts of+            Nothing                   -> missingAlt env0 case_bndr alts cont+            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs+            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args+                                                  other_args case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats case_bndr_rhs bs rhs =+      assert (null bs) $+      do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs+             -- scrut is a constructor application,+             -- hence satisfies let-can-float invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     GHC.Core.Make.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}++    -- This scales case floats by the multiplicity of the continuation hole (see+    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because+    -- they are aliases anyway.+    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =+      let+        scale_id id = scaleVarBy holeScaling id+      in+      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)+    scale_float f = f++    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr+     -- We are in the following situation+     --   case[p] case[q] u of { D x -> C v } of { C x -> w }+     -- And we are producing case[??] u of { D x -> w[x\v]}+     --+     -- What should the multiplicity `??` be? In order to preserve the usage of+     -- variables in `u`, it needs to be `pq`.+     --+     -- As an illustration, consider the following+     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }+     -- Where C :: A %1 -> T is linear+     -- If we were to produce a case[1], like the inner case, we would get+     --   case[1] of { C x -> (x, x) }+     -- Which is ill-typed with respect to linearity. So it needs to be a+     -- case[Many].++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[Alt _ 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+  , exprOkToDiscard 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+   = 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')  <- simplAuxBind "rebuildCaseAlt1" 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 GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont'+           Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }++--------------------------------------------------+--      3. Primop-related case-rules+--------------------------------------------------++  |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts+  = 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 GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (exprType scrut)+    -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).+    -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'+    -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].+    -- Using `exprType` is typically cheap because `scrut` is typically a variable.+    -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts+    -- the brain more.  Consider that if this test ever turns out to be a perf+    -- problem (which seems unlikely).+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+       --    || isStrUsedDmd (idDemandInfo case_bndr)+       -- We no longer look at the demand on the case binder+       -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (seCaseCase env)    -- Only when case-of-case is on.+                            -- See GHC.Driver.Config.Core.Opt.Simplify+                            --    Note [Case-of-case and full laziness]+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild (zapSubstEnv env) case_expr cont }++  | otherwise+  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts env' scrut+                                (scaleIdBy holeScaling case_bndr)+                                (scaleAltsBy holeScaling alts)+                                cont'+       ; return (floats, case_expr) }+  where+    holeScaling = contHoleScaling cont+    -- Note [Scaling in case-of-case]++{-+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+"GHC.Core.Opt.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 [DataAlt occ info]+~~~~~~~~~~~~~~~~~~~~~~~+Our general goal is to preserve dead-ness occ-info on the field binders of a+case alternative. Why? It's generally a good idea, but one specific reason is to+support (SEQ4) of Note [seq# magic].++But we have to be careful: even if the field binder is not mentioned in the case+alternative and thus annotated IAmDead by OccurAnal, it might "come back to+life" in one of two ways:++ 1. If the case binder is alive, its unfolding might bring back the field+    binder, as in Note [knownCon occ info]:+      case blah of y { I# _ -> $wf (case y of I# v -> v) }+      ==>+      case blah of y { I# v -> $wf v }+ 2. Even if the case binder appears to be dead, there is the scenario in+    Note [Add unfolding for scrutinee], in which the fields come back to live+    through the unfolding of variable scrutinee, as follows:+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just _ -> jump j; Nothing -> ...+      ==> { inline j, unfold x to Just v, simplify }+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just v -> blah v; Nothing -> ...++Thus, when we are simply reconstructing a case (the common case), and the+case binder is not dead, or the scrutinee is a variable, we zap the+occurrence info on DataAlt field binders. See `adjustFieldOccInfo`.++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)++Note [Scaling in case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When two cases commute, if done naively, the multiplicities will be wrong:++  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]+  { (z[Many], t[Many]) -> z+  }++The multiplicities here, are correct, but if I perform a case of case:++  case u of w[1]+  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and+`y` must have multiplicities `Many` not `1`! The correct solution is to make+all the `1`-s be `Many`-s instead:++  case u of w[Many]+  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++In general, when commuting two cases, the rule has to be:++  case (case … of x[p] {…}) of y[q] { … }+  ===> case … of x[p*q] { … case … of y[q] { … } }++This is materialised, in the simplifier, by the fact that every time we simplify+case alternatives with a continuation (the surrounded case (or more!)), we must+scale the entire case we are simplifying, by a scaling factor which can be+computed in the continuation (with function `contHoleScaling`).+-}++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   = seFamEnvs env0++        ; (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+          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts+          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils++        ; alts' <- forM in_alts $+            simplAlt alt_env' (Just scrut') imposs_deflt_cons+                     case_bndr' (scrutOkForBinderSwap scrut) cont'++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seMode 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 [Alt DEFAULT _ _]+  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint+              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 `bndr`+         -> BinderSwapDecision  -- DoBinderSwap v co <==> scrut = Just (v |> co),+                                --           add unfolding `v :-> bndr |> sym co`+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt DEFAULT [] rhs') }++simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt (LitAlt lit) [] rhs') }++simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          -- and Note [DataAlt occ info]+        ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs+          -- Adjust evaluated-ness and occ-info flags before `simplBinders`+          -- because the latter extends the in-scope set, which propagates this+          -- adjusted info to use sites.+        ; (env', vs') <- simplBinders env vs_with_info++                -- 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' case_bndr' bndr_swap' con_app++        ; rhs' <- simplExprC env'' rhs cont'+        ; return (Alt (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 [Strict fields in Core] in GHC.Core.++NB: simplLamBndrs 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 GHC.Types.Id.Make.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+-- and Note [DataAlt occ info]+adjustFieldsIdInfo scrut case_bndr bndr_swap con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleDataCon 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+  , f `hasKey` seqHashKey+  , let x' = setCaseBndrEvald MarkedStrict x+  = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x']++  -- Deal with banged datacon fields+  -- This case is quite allocation sensitive to T9233 which has a large record+  -- with strict fields. Hence we try not to update vs twice!+adjustFieldsIdInfo _scrut case_bndr bndr_swap con vs+  | Nothing <- dataConWrapId_maybe con+      -- A common fast path; no need to allocate the_strs when they are all lazy+      -- anyway! It shaves off 2% in T9675+  = map (adjustFieldOccInfo case_bndr bndr_swap) vs+  | otherwise+  = 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) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs+    go _ _ = pprPanic "Simplify.adjustFieldsIdInfo"+              (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 :: StrictnessMark -> SDoc+        strdisp MarkedStrict = text "MarkedStrict"+        strdisp NotMarkedStrict = text "NotMarkedStrict"++adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr+-- Kill occ info if we do binder swap and the case binder is alive;+-- see Note [DataAlt occ info]+adjustFieldOccInfo case_bndr bndr_swap field_bndr+  | isTyVar field_bndr+  = field_bndr++  | not (isDeadBinder case_bndr)  -- (1) in the Note: If the case binder is alive,+  = zapIdOccInfo field_bndr       -- the field binders might come back alive++  | DoBinderSwap{} <- bndr_swap   -- (2) in the Note: If binder swap might take place,+  = zapIdOccInfo field_bndr       -- the case binder might come back alive++  | otherwise+  = field_bndr                    -- otherwise the field binders stay dead++addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv+addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons+  = env2+  where+    unf = mkOtherCon imposs_deflt_cons+          -- Record the constructors that the case-binder *can't* be.+    env1 = addBinderUnfolding env case_bndr unf+    env2 | DoBinderSwap v _mco <- bndr_swap+         = addBinderUnfolding env1 v unf+         | otherwise = env1+++addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv+addAltUnfoldings env case_bndr bndr_swap con_app+  = env2+  where+    con_app_unf = mk_simple_unf con_app+    env1 = addBinderUnfolding env case_bndr con_app_unf++    -- See Note [Add unfolding for scrutinee]+    env2 | DoBinderSwap v mco <- bndr_swap+         = addBinderUnfolding env1 v $+              if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf+              then con_app_unf  --            twice in the common case+              else mk_simple_unf (mkCastMCo con_app mco)++         | otherwise = env1++    -- Force the opts, so that the whole SimplEnv isn't retained+    !opts = seUnfoldingOpts env+    mk_simple_unf = mkSimpleUnfolding opts++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))+          "unfolding type mismatch"+          (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-can-float invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....+                ; K       -> blah }++The let-can-float invariant requires that y is evaluated in the call to+reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccurAnal has got rid of all such occurrences+See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".++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-elimination -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++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.++Since this transformation is tantamount to a binder swap, we use+GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check.++Exactly the same issue arises in GHC.Core.Opt.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2)  <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , GHC.Core.Make.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = assert (isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = assert (isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = assert (isId b) $+        do { let b' = zap_occ b+             -- zap_occ: the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplAuxBind may therefore discard it.+             -- 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) <- simplAuxBind "knownCon" env' b' arg  -- arg satisfies let-can-float 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 NotJoinPoint))+                              -- See Note [Do not duplicate constructor applications]+      | otherwise           = do { dc_args <- mapM (simplInVar env) bs+                                         -- dc_ty_args are already OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplAuxBind "case-bndr" 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+  = warnPprTrace True "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 "Simplify.Iteration.missingAlt")++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM ( SimplFloats  -- Join points (if any)+                            , SimplEnv     -- Use this for the alts+                            , SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont+                           ; let env' = bumpCaseDepth $+                                        env `setInScopeFromF` floats+                           ; return (floats, env', cont) }+  | otherwise         = return (emptyFloats env, 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)+    -- otherwise case: first alt is non-bot, so all the rest must be bot+  where+    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd 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+  = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont++mkDupableContWithDmds+   :: SimplEnvIS  -> [Demand]  -- Demands on arguments; always infinite+   -> SimplCont -> SimplM ( SimplFloats, SimplCont)++mkDupableContWithDmds env _ cont+  -- Check the invariant+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False+  = pprPanic "mkDupableContWithDmds" empty++  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, CastIt { sc_co = optOutCoercion env co opt+                                 , sc_opt = True, sc_cont = cont' }) }+                 -- optOutCoercion: see Note [Avoid re-simplifying coercions]++-- Duplicating ticks for now, not sure if this is good or not+mkDupableContWithDmds env dmds (TickIt t cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, TickIt t cont') }++mkDupableContWithDmds env _+     (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                 , sc_env = se, sc_cont = cont})+-- See Note [Duplicating StrictBind]+-- K[ let x = <> in b ]  -->   join j x = K[ b ]+--                             j <>+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr')      <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont+          -- No need to use mkDupableCont before simplNonRecBody; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; mkDupableStrictBind env bndr' join_body res_ty }++mkDupableContWithDmds env _+    (StrictArg { sc_fun = fun, sc_cont = cont+               , sc_fun_ty = fun_ty })+  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  | isNothing (isDataConId_maybe (ai_fun fun))+         -- isDataConId: see point (DJ4) of Note [Duplicating join points]+  , thumbsUpPlanA cont+  = -- Use Plan A of Note [Duplicating StrictArg]+--    pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $+    do { let _ :| dmds = expectNonEmpty $ ai_dmds fun+       ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont+                              -- Use the demands from the function to add the right+                              -- demand info on any bindings we make for further args+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)+                                           (ai_args fun)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = fun { ai_args = args' }+                            , sc_cont = cont'+                            , sc_fun_ty = fun_ty+                            , sc_dup = OkToDup} ) }++  | otherwise+  = -- Use Plan B of Note [Duplicating StrictArg]+    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]+    --                         j <>+    do { let rhs_ty       = contResultType cont+             (m,arg_ty,_) = splitFunTy fun_ty+       ; arg_bndr <- newId (fsLit "arg") m arg_ty+       ; let env' = env `addNewInScopeIds` [arg_bndr]+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont+       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }+  where+    thumbsUpPlanA (StrictArg {})               = False+    thumbsUpPlanA (StrictBind {})              = True+    thumbsUpPlanA (Stop {})                    = True+    thumbsUpPlanA (Select {})                  = True+    thumbsUpPlanA (CastIt { sc_cont = k })     = thumbsUpPlanA k+    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k++mkDupableContWithDmds env dmds+    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env dmds+    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se+                , sc_cont = cont, sc_hole_ty = hole_ty })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { let dmd:|cont_dmds = expectNonEmpty dmds+        ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg+        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (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 GHC.Core.Opt.Simplify.Utils+                              , sc_dup = OkToDup, sc_cont = cont'+                              , sc_hole_ty = hole_ty }) }++mkDupableContWithDmds 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_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` 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 cont_scaling = contHoleScaling cont+          -- See Note [Scaling in case-of-case]+        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)+        ; alts' <- forM (scaleAltsBy cont_scaling alts) $+            simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont+                -- 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 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 GHC.Core.Opt.Simplify.Utils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType+                    -> SimplM (SimplFloats, SimplCont)+mkDupableStrictBind env arg_bndr join_rhs res_ty+  | uncondInlineJoin [arg_bndr] join_rhs+     -- See point (DJ2) of Note [Duplicating join points]+  = return (emptyFloats env+           , StrictBind { sc_bndr = arg_bndr+                        , sc_body = join_rhs+                        , sc_env  = zapSubstEnv env+                        , sc_from = FromLet+                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                        , sc_dup  = OkToDup+                        , sc_cont = mkBoringStop res_ty } )+  | otherwise+  = do { join_bndr <- newJoinId [arg_bndr] res_ty+       ; let arg_info = ArgInfo { ai_fun   = join_bndr+                                , ai_rules = [], ai_args  = []+                                , ai_encl  = False, ai_dmds  = repeat topDmd+                                , ai_discs = repeat 0 }+       ; return ( addJoinFloats (emptyFloats env) $+                  unitJoinFloat                   $+                  NonRec join_bndr                $+                  Lam (setOneShotLambda arg_bndr) join_rhs+                , StrictArg { sc_dup    = OkToDup+                            , sc_fun    = arg_info+                            , sc_fun_ty = idType join_bndr+                            , sc_cont   = mkBoringStop res_ty+                            } ) }++mkDupableAlt :: SimplEnv -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt _env case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | uncondInlineJoin alt_bndrs alt_rhs_in+    -- See point (DJ2) of Note [Duplicating join points]+  = return (jfloats, Alt con alt_bndrs alt_rhs_in)++  | otherwise+  = do  { let rhs_ty'  = exprType alt_rhs_in++              bangs+                | DataAlt c <- con+                = dataConRepStrictness c+                | otherwise = []++              abstracted_binders = abstract_binders alt_bndrs bangs++              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]+              abstract_binders [] []+                -- Abstract over the case binder too if it's used.+                | isDeadBinder case_bndr  = []+                | otherwise               = [(case_bndr,MarkedStrict)]+              abstract_binders (alt_bndr:alt_bndrs) marks+                -- Abstract over all type variables just in case+                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks+              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)+                -- The deadness info on the new Ids is preserved by simplBinders+                -- We don't abstract over dead ids here.+                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks+                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks+              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)++              filtered_binders = map fst abstracted_binders+              -- We want to make any binder with an evaldUnfolding strict in the rhs.+              -- See Note [Call-by-value for worker args] (which also applies to join points)+              rhs_with_seqs = mkStrictFieldSeqs abstracted_binders alt_rhs_in++              final_args = varsToCoreExprs filtered_binders+                           -- 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+              final_bndrs     = map one_shot filtered_binders+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v++              -- No lambda binder has an unfolding, but (currently) case binders can,+              -- so we must zap them here.+              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs++        ; join_bndr <- newJoinId filtered_binders rhs_ty'+        ; let -- join_bndr_w_unf = join_bndr `setIdUnfolding`+              --                   mkUnfolding uf_opts VanillaSrc False False join_rhs Nothing+              -- See Note [Do not add unfoldings to join points at birth]+              join_call = mkApps (Var join_bndr) final_args+              alt'      = Alt con alt_bndrs join_call++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Do not add unfoldings to join points at birth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15360)++   case (case (case (case ...))) of+      Left x  -> e1+      Right y -> e2++We will make a join point for e1, e2, thus+    $j1a x = e1+    $j1b y = e2++Now those join point calls count as "duplicable" , so we feel free to duplicate+them into the loop nest.  And each of those calls are then subject to+callSiteInline, which might inline them, if e1, e2 are reasonably small.  Now,+if this applies recursive to the next `case` inwards, and so on, the net+effect is that we can get an exponential number of calls to $j1a and $j1b, and+an exponential number of inlinings (since each is done independently).++This hit #15360 (not a complicated program!) badly.  Our simple solution is this:+when a join point is born, we don't give it an unfolding, so it will not be inlined+at its call sites, at least not in that pass.  So we end up with+    $j1a x = e1+    $j1b y = e2+    $j2a x = ...$j1a ... $j1b...+    $j2b x = ...$j1a ... $j1b...+    ... and so on...++In the next iteration of the Simplifier we are into Note [Avoid inlining into+deeply nested cases] in Simplify.Inline, which is still a challenge.  But at+least we have a chance. If we add inlinings at birth we never get that chance.++Wrinkle++(JU1) It turns out that the same problem shows up in a different guise, via+      Note [Post-inline for single-use things] in Simplify.Utils.  I think+      we have something like+         case K (join $j x = <rhs> in jblah) of K y{OneOcc} -> blah+      where $j is a freshly-born join point.  After case-of-known-constructor+      wo we end up substituting (join $j x = <rhs> in jblah) for `y` in `blah`;+      and thus we re-simplify that join binding.  In test T15630 this results in+      massive duplication.++      So in `simplLetUnfolding` we spot this case a bit hackily; a freshly-born+      join point will have OccInfo of ManyOccs, unlike an existing join point which+      will have OneOcc.  So in simplLetUnfolding we kill the unfolding of a freshly+      born join point.++I can't quite articulate precisely why this is so important.  But it makes a+MASSIVE difference in T15630 (a fantastic test case); and at worst it'll merely+delay inlining join points by one simplifier iteration.++In effect (JU1) just extends the original Note [Do not add unfoldings to join+points at birth] to occasions where we re-visit the same join-point in the same+Simplifier iteration.++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 GHC.Core.Opt.WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Duplicating join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19996 we discovered that we want to be really careful about+inlining join points.   Consider+    case (join $j x = K f x )+         (in case v of      )+         (     p1 -> $j x1  ) of+         (     p2 -> $j x2  )+         (     p3 -> $j x3  )+      K g y -> blah[g,y]++Here the join-point RHS is very small, just a constructor+application (K f x).  So we might inline it to get+    case (case v of          )+         (     p1 -> K f x1  ) of+         (     p2 -> K f x2  )+         (     p3 -> K f x3  )+      K g y -> blah[g,y]++But now we have to make `blah` into a join point, /abstracted/+over `g` and `y`. We get+    join $j2 g y = blah+    in case v of+         p1 -> $j2 f x1+         p2 -> $j2 f x2+         p3 -> $j2 f x3+So now we can't see that `g` is always `f` in `blah`.++In contrast, if we /don't/ inline $j we+don't need a new join point for `blah` and we'll get+    join $j' x = let g=f, y=x in blah[g,y]+    in case v of+       p1 -> $j' x1+       p2 -> $j' x2+       p3 -> $j' x3++This can make a /massive/ difference, because `blah` can see+what `f` is, instead of lambda-abstracting over it.++If instead the RHS of the join point is a simple application that has no free+variables, as in++    case (join $j x f = K f x )+         (in case v of      )+         (     p1 -> $j x1 f1 ) of+         (     p2 -> $j x2 f2 )+         (     p3 -> $j x3 f3 )+      K g y -> blah[g,y]++then no information can be gained by preserving the join point (c.f. `f` being+free in the join point above and being useful to `blah`). In this case, it's+more beneficial to inline the join point (see (DJ3)(c)) to allow further+optimisations to fire. An example where failing to do this went wrong is #25723.++Beyond this, not-inlining join points reduces duplication.  In the above+example, if `blah` was small enough we'd inline it, but that duplicates code,+for no gain.  Best just to keep not-inline the join point in the first place.+So not-inlining join points is our default: but see Note [Inlining join points]+in GHC.Core.Opt.Simplify.Inline for when we /do/ inline them.++To achieve this parsimonious inlining of join points, we need to do two things:+(a) create a join point even if the RHS is small; and (b) don't do+unconditional-inlining for join points.++(DJ1) Do not postInlineUnconditionally a join point, ever. Doing+   postInlineUnconditionally is primarily to push allocation into cold+   branches; but a join point doesn't allocate, so that's a non-motivation.++(DJ2) In mkDupableAlt and mkDupableStrictBind, generate an alterative for /all/+   alternatives, /except/ for ones that will definitely inline unconditionally+   straight away.  (In that case it's silly to make a join point in the first+   place; it just takes an extra Simplifier iteration to undo.)  This choice is+   made by GHC.Core.Unfold.uncondInlineJoin.++   This plan generates a lot of join points, but makes them much more+   case-of-case friendly.++(DJ3) When should `uncondInlineJoin` return True?+   (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see+     the defn of exprIsTrivial.  Also nullary constructors.++   (b) The RHS is a call ($j x y z), where the arguments are all trivial and $j+     is a join point: there is no point in creating an indirection.++   (c) The RHS is a data constructor application (K x y z) where++      - all the args x,y,z are trivial+      - the free LocalIds of `f x y z` are a subset of the join point binders++      Examples that return True+        $j x y = K y (x |> co)+        $j x y = x (y @Int)+      Examples that return False+        $j x = K y x    -- y is free+        $j y = f y      -- f is free++      Not duplicating these join points has no benefits and blocks other important+      optimisations from firing (see #25723)++(DJ4) By the same token we want to use Plan B in Note [Duplicating StrictArg] when+   the RHS of the new join point is a data constructor application.  See the+   call to isDataConId in the StrictArg case of mkDupableContWithDmds.++   That same Note [Duplicating StrictArg] explains why we sometimes want Plan A+   when the RHS of the new join point would be a non-data-constructor+   application++(DJ5) You might worry that $j = K x y might look so small that it is inlined+   by the call site inliner, defeating (DJ3). But in fact++   - The UnfoldingGuidance for a join point is only UnfWhen (unconditional)+     if `uncondInlineJoin` is true; see GHC.Core.Unfold.uncondInline++   - `GHC.Core.Opt.Simplify.Inline.tryUnfolding` has a special case for join+     points, described Note [Inlining join points] in that module.++Historical Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this entire Note is now irrelevant.  In Jun 21 we stopped+adding unfoldings to lambda binders (#17530).  It was always a+hack and bit us in multiple small and not-so-small ways++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 GHC.Core.Opt.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 [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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with making a StrictArg continuation duplicable has turned out+to be one of the trickiest corners of the simplifier, giving rise+to several cases in which the simplier expanded the program's size+*exponentially*.  They include+  #13253 exponential inlining+  #10421 ditto+  #18140 strict constructors+  #18282 another nested-function call case++Suppose we have a call+  f e1 (case x of { True -> r1; False -> r2 }) e3+and f is strict in its second argument.  Then we end up in+mkDupableCont with a StrictArg continuation for (f e1 <> e3).+There are two ways to make it duplicable.++* Plan A: move the entire call inwards, being careful not+  to duplicate e1 or e3, thus:+     let a1 = e1+         a3 = e3+     in case x of { True  -> f a1 r1 a3+                  ; False -> f a1 r2 a3 }++* Plan B: make a join point:+     join $j x = f e1 x e3+     in case x of { True  -> jump $j r1+                  ; False -> jump $j r2 }++  Notice that Plan B is very like the way we handle strict bindings;+  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd+  get if we turned use a case expression to evaluate the strict arg:++       case (case x of { True -> r1; False -> r2 }) of+         r -> f e1 r e3++  So, looking at Note [Duplicating join points], we also want Plan B+  when `f` is a data constructor.++Plan A is often good:++* The calls to `f` may well be able to inline, since they are now applied+  to more informative arguments, `r1`, `r2`. For example:+        && E (case x of { T -> F; F -> T })+  Pushing the call inward (being careful not to duplicate E) we get+        let a = E+        in case x of { T -> && a F; F -> && a T }+  and now the (&& a F) etc can optimise.++* Moreover there might be a RULE for the function that can fire when it "sees"+  the particular case alternative.++* More specialisation can happen.  Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')++  If we pushed the entire call for 'go' inside the case, we get+  call-pattern specialisation for 'go', which is *crucial* for+  this particular program.++But Plan A can have terrible, terrible behaviour. Here is a classic+case:+  f (f (f (f (f True))))++Suppose f is strict, and has a body that is small enough to inline.+The innermost call inlines (seeing the True) to give+  f (f (f (f (case v of { True -> e1; False -> e2 }))))++Now, suppose we naively push the entire continuation into both+case branches (it doesn't look large, just f.f.f.f). We get+  case v of+    True  -> f (f (f (f e1)))+    False -> f (f (f (f e2)))++And now the process repeats, so we end up with an exponentially large+number of copies of f. No good!++CONCLUSION: we want Plan A in general, but do Plan B is there a+danger of this nested call behaviour. The function that decides+this is called thumbsUpPlanA.++Note [Keeping demand info in StrictArg Plan A]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Following on from Note [Duplicating StrictArg], another common code+pattern that can go bad is this:+   f (case x1 of { T -> F; F -> T })+     (case x2 of { T -> F; F -> T })+     ...etc...+when f is strict in all its arguments.  (It might, for example, be a+strict data constructor whose wrapper has not yet been inlined.)++We use Plan A (because there is no nesting) giving+  let a2 = case x2 of ...+      a3 = case x3 of ...+  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }++Now we must be careful!  a2 and a3 are small, and the OneOcc code in+postInlineUnconditionally may inline them both at both sites; see Note+Note [Inline small things to avoid creating a thunk] in+Simplify.Utils. But if we do inline them, the entire process will+repeat -- back to exponential behaviour.++So we are careful to keep the demand-info on a2 and a3.  Then they'll+be /strict/ let-bindings, which will be dealt with by StrictBind.+That's why contIsDupableWithDmds is careful to propagage demand+info to the auxiliary bindings it creates.  See the Demand argument+to makeTrivial.++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 j <>++Just like StrictArg in fact -- and indeed they share code.++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+                  -> BindContext+                  -> InId+                  -> OutExpr -> OutType -> ArityType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf+  | isStableUnfolding unf+  = simplStableUnfolding env bind_cxt id rhs_ty arity unf++  | freshly_born_join_point id+  = -- This is a tricky one!+    -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]+    return noUnfolding++  | isExitJoinId id+  = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify+    return noUnfolding++  | otherwise+  = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs++  where+    is_join_point = isJoinId id+    freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id)+      -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627++-------------------+mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource+               -> InId -> Bool    -- True <=> this is a join point+               -> OutExpr -> SimplM Unfolding+mkLetUnfolding env top_lvl src id is_join new_rhs+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In GHC.Iface.Tidy 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+    -- !opts: otherwise, we end up retaining all the SimpleEnv+    !uf_opts = seUnfoldingOpts env++    -- Might as well force this, profiles indicate up to+    -- 0.5MB of thunks just from this site.+    !is_top_lvl   = isTopLevel top_lvl+    -- See Note [Force bottoming field]+    !is_bottoming = isDeadEndId id++-------------------+simplStableUnfolding :: SimplEnv -> BindContext+                     -> InId+                     -> OutType+                     -> ArityType      -- Used to eta expand, but only for non-join-points+                     -> Unfolding+                     ->SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf+  = 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 bind_cxt of+                  BC_Join _ cont    -> -- Binder is a join point+                                       -- See Note [Rules and unfolding for join points]+                                       simplJoinRhs unf_env id expr cont+                  BC_Let _ is_rec -> -- Binder is not a join point+                                     do { let cont = mkRhsStop rhs_ty is_rec topDmd+                                           -- mkRhsStop: switch off eta-expansion at the top level+                                        ; expr' <- simplExprC unf_env expr cont+                                        ; return (eta_expand expr') }+              ; case guide of+                  UnfWhen { ug_boring_ok = boring_ok }+                     -- Happens for INLINE things+                     -- Really important to force new_boring_ok since otherwise+                     --   `ug_boring_ok` is a thunk chain of+                     --   inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...+                     -- See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' = guide { ug_boring_ok = new_boring_ok }+                        -- 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 GHC.Tc.TyCl.Instance.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding env top_lvl src id False 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+    -- Forcing this can save about 0.5MB of max residency and the result+    -- is small and easy to compute so might as well force it.+    top_lvl     = bindContextLevel bind_cxt+    !is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils++    -- See Note [Eta-expand stable unfoldings]+    -- Use the arity from the main Id (in id_arity), rather than computing it from rhs+    -- Not used for join points+    eta_expand expr | seEtaExpand env+                    , exprArity expr < arityTypeArity id_arity+                    , wantEtaExpansion expr+                    = etaExpandAT (getInScope env) id_arity expr+                    | otherwise+                    = expr++{- Note [Eta-expand stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For INLINE/INLINABLE things (which get stable unfoldings) there's a danger+of getting+   f :: Int -> Int -> Int -> Blah+   [ Arity = 3                 -- Good arity+   , Unf=Stable (\xy. blah)    -- Less good arity, only 2+   f = \pqr. e++This can happen because f's RHS is optimised more vigorously than+its stable unfolding.  Now suppose we have a call+   g = f x+Because f has arity=3, g will have arity=2.  But if we inline f (using+its stable unfolding) g's arity will reduce to 1, because <blah>+hasn't been optimised yet.  This happened in the 'parsec' library,+for Text.Pasec.Char.string.++Generally, if we know that 'f' has arity N, it seems sensible to+eta-expand the stable unfolding to arity N too. Simple and consistent.++Wrinkles++* See Historical-note [Eta-expansion in stable unfoldings] in+  GHC.Core.Opt.Simplify.Utils++* Don't eta-expand a trivial expr, else each pass will eta-reduce it,+  and then eta-expand again. See Note [Which RHSs do we eta-expand?]+  in GHC.Core.Opt.Simplify.Utils.++* Don't eta-expand join points; see Note [Do not eta-expand join points]+  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point+  case (bind_cxt = BC_Join {}) doesn't use eta_expand.++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 "GHC.Core.Opt.OccurAnal"+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> BindContext+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id bind_cxt+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]+-- Simplify local rules for imported Ids+simplImpRules env rules+  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> BindContext -> SimplM [CoreRule]+simplRules env mb_new_id rules bind_cxt+  = 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+                          , ru_act = act })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]+                                BC_Let {}      -> mkBoringStop rhs_ty+                                BC_Join _ cont -> assertPpr join_ok bad_join_msg cont+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]+                 -- Force this to avoid retaining reference to old Id+                 !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 | JoinPoint join_arity <- idJoinPointHood id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap idJoinPointHood mb_new_id) ]++           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = occurAnalyseExpr rhs' }) }+                            -- Remember to occ-analyse, to drop dead code.+                            -- See Note [OccInfo in unfoldings and rules] in GHC.Core++{- Note [Simplifying the RHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can simplify the RHS of a RULE much as we do the RHS of a stable+unfolding.  We used to use the much more conservative updModeForRules+for the RHS as well as the LHS, but that seems more conservative+than necesary.  Allowing some inlining might, for example, eliminate+a binding.+-}
+ GHC/Core/Opt/Simplify/Monad.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE PatternSynonyms #-}+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}+-}++module GHC.Core.Opt.Simplify.Monad (+        -- The monad+        TopEnvConfig(..), SimplM,+        initSmpl, traceSmpl,+        getSimplRules,++        -- Unique supply+        MonadUnique(..), newId, newJoinId,++        -- Counting+        SimplCount, tick, freeTick, checkedTick,+        getSimplCount, zeroSimplCount, pprSimplCount,+        plusSimplCount, isZeroSimplCount+    ) where++import GHC.Prelude++import GHC.Types.Var       ( Var, isId, mkLocalVar )+import GHC.Types.Name      ( mkSystemVarName )+import GHC.Types.Id        ( Id, mkSysLocalOrCoVarM )+import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo )+import GHC.Core.Type       ( Type, Mult )+import GHC.Core.Opt.Stats+import GHC.Core.Rules+import GHC.Core.Utils      ( mkLamTypes )+import GHC.Types.Unique.Supply+import GHC.Driver.Flags+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Utils.Monad+import GHC.Utils.Logger as Logger+import GHC.Utils.Misc      ( count )+import GHC.Utils.Panic     (throwGhcExceptionIO, GhcException (..))+import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf )+import Control.Monad       ( ap )+import GHC.Core.Multiplicity        ( pattern ManyTy )+import GHC.Exts( oneShot )++{-+************************************************************************+*                                                                      *+\subsection{Monad plumbing}+*                                                                      *+************************************************************************+-}++newtype SimplM result+  =  SM'  { unSM :: SimplTopEnv+                 -> SimplCount+                 -> IO (result, SimplCount)}+    -- We only need IO here for dump output, but since we already have it+    -- we might as well use it for uniques.++pattern SM :: (SimplTopEnv -> SimplCount+               -> IO (result, SimplCount))+          -> SimplM result+-- This pattern synonym makes the simplifier monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- (worth a 1-2% reduction in bytes-allocated).  See #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern SM m <- SM' m+  where+    SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct)++-- See Note [The environments of the Simplify pass]+data TopEnvConfig = TopEnvConfig+  { te_history_size :: !Int+  , te_tick_factor :: !Int+  }++data SimplTopEnv+  = STE { -- See Note [The environments of the Simplify pass]+          st_config :: !TopEnvConfig+        , st_logger    :: !Logger+        , st_max_ticks :: !IntWithInf  -- ^ Max #ticks in this simplifier run+        , st_read_ruleenv :: !(IO RuleEnv)+          -- ^ The action to retrieve an up-to-date EPS RuleEnv+          -- See Note [Overall plumbing for rules]+        }++initSmpl :: Logger+         -> IO RuleEnv+         -> TopEnvConfig+         -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow+         -> SimplM a+         -> IO (a, SimplCount)++initSmpl logger read_ruleenv cfg size m+  = do -- No init count; set to 0+       let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats+       unSM m env simplCount+  where+    env = STE { st_config = cfg+              , st_logger = logger+              , st_max_ticks = computeMaxTicks cfg size+              , st_read_ruleenv = read_ruleenv+              }++computeMaxTicks :: TopEnvConfig -> 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 cfg size+  = treatZeroAsInf $+    fromInteger ((toInteger (size + base_size)+                  * toInteger (tick_factor * magic_multiplier))+          `div` 100)+  where+    tick_factor      = te_tick_factor cfg+    base_size        = 100+    magic_multiplier = 40+        -- MAGIC NUMBER, multiplies the simplTickFactor+        -- We can afford to be generous; this is really+        -- just checking for loops, and shouldn't usually fire+        -- A figure of 20 was too small: see #5539.++{-# INLINE thenSmpl #-}+{-# INLINE thenSmpl_ #-}+{-# INLINE returnSmpl #-}+{-# INLINE mapSmpl #-}++instance Functor SimplM where+  fmap = mapSmpl++instance Applicative SimplM where+    pure  = returnSmpl+    (<*>) = ap+    (*>)  = thenSmpl_++instance Monad SimplM where+   (>>)   = (*>)+   (>>=)  = thenSmpl++mapSmpl :: (a -> b) -> SimplM a -> SimplM b+mapSmpl f m = thenSmpl m (returnSmpl . f)++returnSmpl :: a -> SimplM a+returnSmpl e = SM (\_st_env sc -> return (e, sc))++thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b++thenSmpl m k+  = SM $ \st_env sc0 -> do+      (m_result, sc1) <- unSM m st_env sc0+      unSM (k m_result) st_env sc1++thenSmpl_ m k+  = SM $ \st_env sc0 -> do+      (_, sc1) <- unSM m st_env sc0+      unSM k st_env 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 logger <- getLogger+       liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace"+         FormatText+         (hang (text herald) 2 doc)+{-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]++{-+************************************************************************+*                                                                      *+\subsection{The unique supply}+*                                                                      *+************************************************************************+-}++-- See Note [Uniques for wired-in prelude things and known tags] in GHC.Builtin.Uniques+simplTag :: Char+simplTag = 's'++instance MonadUnique SimplM where+    getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag+    getUniqueM = liftIO $ uniqFromTag simplTag++instance HasLogger SimplM where+    getLogger = gets st_logger++instance MonadIO SimplM where+    liftIO = liftIOWithEnv . const++getSimplRules :: SimplM RuleEnv+getSimplRules = liftIOWithEnv st_read_ruleenv++liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a+liftIOWithEnv m = SM (\st_env sc -> do+    x <- m st_env+    return (x, sc))++gets :: (SimplTopEnv -> a) -> SimplM a+gets f = liftIOWithEnv (return . f)++newId :: FastString -> Mult -> Type -> SimplM Id+newId fs w ty = mkSysLocalOrCoVarM fs w ty++-- | Make a join id with given type and arity but without call-by-value annotations.+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      = count isId bndrs+             -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core+             join_arity = length bndrs+             details    = JoinId join_arity Nothing+             id_info    = vanillaIdInfo `setArityInfo` arity++       ; return (mkLocalVar details name ManyTy join_id_ty id_info) }++{-+************************************************************************+*                                                                      *+\subsection{Counting up what we've done}+*                                                                      *+************************************************************************+-}++getSimplCount :: SimplM SimplCount+getSimplCount = SM (\_st_env sc -> return (sc, sc))++tick :: Tick -> SimplM ()+tick t = SM (\st_env sc -> let+  history_size = te_history_size (st_config st_env)+  sc' = doSimplTick history_size t sc+  in sc' `seq` return ((), sc'))++checkedTick :: Tick -> SimplM ()+-- Try to take a tick, but fail if too many+checkedTick t+  = SM (\st_env sc ->+           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)+           then throwGhcExceptionIO $+                  PprProgramError "Simplifier ticks exhausted" (msg sc)+           else let+             history_size = te_history_size (st_config st_env)+             sc' = doSimplTick history_size t sc+             in sc' `seq` return ((), sc'))+  where+    msg sc = vcat+      [ text "When trying" <+> ppr t+      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."+      , space+      , text "In addition try adjusting -funfolding-case-threshold=N and"+      , text "-funfolding-case-scaling=N for the module in question."+      , text "Using threshold=1 and scaling=5 should break most inlining loops."+      , space+      , text "If you need to increase the tick factor substantially, while also"+      , text "adjusting unfolding parameters please file a bug report and"+      , text "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 sc -> let sc' = doFreeSimplTick t sc+                           in sc' `seq` return ((), sc'))
+ GHC/Core/Opt/Simplify/Utils.hs view
@@ -0,0 +1,2817 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++The simplifier utilities+-}++++module GHC.Core.Opt.Simplify.Utils (+        -- Rebuilding+        rebuildLam, mkCase, prepareAlts,+        tryEtaExpandRhs, wantEtaExpansion,++        -- Inlining,+        preInlineUnconditionally, postInlineUnconditionally,+        activeRule,+        getUnfoldingInRuleMatch,+        updModeForStableUnfoldings, updModeForRules,++        -- The BindContext type+        BindContext(..), bindContextLevel,++        -- The continuation type+        SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,+        isSimplified, contIsStop,+        contIsDupable, contResultType, contHoleType, contHoleScaling,+        contIsTrivial, contArgs, contIsRhs,+        countArgs, contOutArgs, dropContArgs,+        mkBoringStop, mkRhsStop, mkLazyArgStop,+        interestingCallContext,++        -- ArgInfo+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addTyArgTo,+        argInfoExpr, argSpecArg,+        pushSimplifiedArgs,+        isStrictArgInfo, lazyArgContext,++        abstractFloats,++        -- Utilities+        isExitJoinId+    ) where++import GHC.Prelude hiding (head, init, last, tail)+import qualified GHC.Prelude as Partial (head)++import GHC.Core+import GHC.Types.Literal ( isLitRubbish )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline )+import GHC.Core.Opt.Stats ( Tick(..) )+import qualified GHC.Core.Subst+import GHC.Core.Ppr+import GHC.Core.TyCo.Ppr ( pprParendType )+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Opt.Arity+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Type     hiding( substTy )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )+import GHC.Core.Multiplicity+import GHC.Core.Opt.ConstantFold++import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Tickish+import GHC.Types.Demand+import GHC.Types.Var.Set+import GHC.Types.Basic++import GHC.Data.OrdList ( isNilOL )+import GHC.Data.FastString ( fsLit )++import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad    ( when )+import Data.List        ( sortBy )+import GHC.Types.Name.Env+import Data.Graph++{- *********************************************************************+*                                                                      *+                The BindContext type+*                                                                      *+********************************************************************* -}++-- What sort of binding is this? A let-binding or a join-binding?+data BindContext+  = BC_Let                 -- A regular let-binding+      TopLevelFlag RecFlag++  | BC_Join                -- A join point with continuation k+      RecFlag              -- See Note [Rules and unfolding for join points]+      SimplCont            -- in GHC.Core.Opt.Simplify++bindContextLevel :: BindContext -> TopLevelFlag+bindContextLevel (BC_Let top_lvl _) = top_lvl+bindContextLevel (BC_Join {})       = NotTopLevel++bindContextRec :: BindContext -> RecFlag+bindContextRec (BC_Let _ rec_flag)  = rec_flag+bindContextRec (BC_Join rec_flag _) = rec_flag++isJoinBC :: BindContext -> Bool+isJoinBC (BC_Let {})  = False+isJoinBC (BC_Join {}) = True+++{- *********************************************************************+*                                                                      *+                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 syntactic 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)+        SubDemand       -- ^ The evaluation context of e. Tells how e is evaluated.+                        -- This fuels eta-expansion or eta-reduction without looking+                        -- at lambda bodies, for example.+                        --+                        -- See Note [Eta reduction based on evaluation context]+                        -- The evaluation context for other SimplConts can be+                        -- reconstructed with 'contEvalContext'+++  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]+      { sc_co   :: OutCoercion  -- The coercion simplified+                                -- Invariant: never an identity coercion+      , sc_opt  :: Bool         -- True <=> sc_co has had optCoercion applied to it+                                --      See Note [Avoid re-simplifying coercions]+                                --      in GHC.Core.Opt.Simplify.Iteration+      , sc_cont :: SimplCont }++  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]+      { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]+      , sc_hole_ty :: OutType   -- Type of the function, presumably (forall a. blah)+                                -- See Note [The hole type in ApplyToTy]+      , 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 b K)[e] = let x = e in K[b]+                        --       or, equivalently,  = K[ (\x.b) e ]+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]+      , sc_from  :: FromWhat+      , sc_bndr  :: InId+      , sc_body  :: InExpr+      , sc_env   :: StaticEnv      -- Static env for both sc_bndr (stable unfolding thereof)+                                   -- and sc_body.  Also 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 demands and discount flags for *this* arg+                               --          and further args+                               --     So ai_dmds and ai_discs are never empty+      , sc_fun_ty :: OutType   -- Type of the function (f e1 .. en),+                               -- presumably (arg_ty -> res_ty)+                               -- where res_ty is expected by sc_cont+      , sc_cont :: SimplCont }++  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]+        CoreTickish     -- Tick tickish <hole>+        SimplCont++type StaticEnv = SimplEnv       -- Just the static part is relevant++data FromWhat = FromLet | FromBeta Levity++-- See Note [DupFlag invariants]+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 { se_dup = dup, se_env = env, se_cont = k}+   and  Select { se_dup = dup, se_env = env, se_cont = 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,+               or at least is always ignored; the payload is+               already an OutThing+-}++instance Outputable DupFlag where+  ppr OkToDup    = text "ok"+  ppr NoDup      = text "nodup"+  ppr Simplified = text "simpl"++instance Outputable SimplCont where+  ppr (Stop ty interesting eval_sd)+    = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty+    where+      pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd]+  ppr (CastIt { sc_co = co, sc_cont = 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, sc_hole_ty = hole_ty })+    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)+          2 (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_cont = cont })+    = (text "Select" <+> ppr dup <+> ppr bndr) $$+      whenPprDebug (nest 2 $ 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)+                                -- NB: all these argumennts are already simplified++        ai_rules :: [CoreRule], -- 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_dmds :: [Demand],    -- Demands on remaining value arguments (beyond ai_args)+                                --   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 value arguments (beyond ai_args)+                                --   non-zero => be keener to inline+                                --   Always infinite+    }++data ArgSpec+  = ValArg { as_dmd  :: Demand        -- Demand placed on this argument+           , as_arg  :: OutExpr       -- Apply to this (coercion or value); c.f. ApplyToVal+           , as_hole_ty :: OutType }  -- Type of the function (presumably t1 -> t2)++  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)++instance Outputable ArgInfo where+  ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules })+    = text "ArgInfo" <+> braces+         (sep [ text "fun =" <+> ppr fun+              , text "dmds(first 10) =" <+> ppr (take 10 dmds)+              , text "args =" <+> ppr args+              , text "rewrite =" <+> ppr rules ])++instance Outputable ArgSpec where+  ppr (ValArg { as_arg = arg })  = text "ValArg" <+> ppr arg+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty++addValArgTo :: ArgInfo ->  OutExpr -> OutType -> ArgInfo+addValArgTo ai arg hole_ty+  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai+      -- Pop the top demand and and discounts off+  , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }+  = ai { ai_args    = arg_spec : ai_args ai+       , ai_dmds    = dmds+       , ai_discs   = discs }+  | otherwise+  = pprPanic "addValArgTo" (ppr ai $$ ppr arg)+    -- There should always be enough demands and discounts++addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo+addTyArgTo ai arg_ty hole_ty = ai { ai_args    = arg_spec : ai_args ai }+  where+    arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }++isStrictArgInfo :: ArgInfo -> Bool+-- True if the function is strict in the next argument+isStrictArgInfo (ArgInfo { ai_dmds = dmds })+  | dmd:_ <- dmds = isStrUsedDmd dmd+  | otherwise     = False++pushSimplifiedArgs :: SimplEnv+                   -> [ArgSpec]   -- In normal, forward order+                   -> SimplCont -> SimplCont+pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args+-- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args++pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont+pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont+  = ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }+pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont+  = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified+                 -- The SubstEnv will be ignored since sc_dup=Simplified+               , sc_hole_ty = hole_ty, sc_cont = cont }++argSpecArg :: ArgSpec -> OutExpr+argSpecArg (ValArg { as_arg = arg })   = arg+argSpecArg (TyArg  { as_arg_ty = ty }) = Type ty++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 { as_arg = arg }  : as) = go as `App` arg+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty++{-+************************************************************************+*                                                                      *+                Functions on SimplCont+*                                                                      *+************************************************************************+-}++mkBoringStop :: OutType -> SimplCont+mkBoringStop ty = Stop ty BoringCtxt topSubDmd++mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont+-- See Note [RHS of lets] in GHC.Core.Unfold+mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd)++mkLazyArgStop :: OutType -> ArgInfo -> SimplCont+mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd+  where+    arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))++-------------------+contIsRhs :: SimplCont -> Maybe RecFlag+contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec+contIsRhs (CastIt { sc_cont = k })    = contIsRhs k   -- For f = e |> co, treat e as Rhs context+contIsRhs _                           = Nothing++-------------------+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 { sc_cont = k })          = contIsDupable k+contIsDupable _                                 = False++-------------------+contIsTrivial :: SimplCont -> Bool+contIsTrivial (Stop {})                                         = True+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k+-- This one doesn't look right.  A value application is not trivial+-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+contIsTrivial (CastIt { sc_cont = k })                          = contIsTrivial k+contIsTrivial _                                                 = False++-------------------+contResultType :: SimplCont -> OutType+contResultType (Stop ty _ _)                = ty+contResultType (CastIt { sc_cont = 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 { sc_co = co })          = coercionLKind co+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })+  = perhapsSubstTy dup se (idType b)+contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })+  = perhapsSubstTy d se (idType b)+++-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of+-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling+-- factor is p. And in E[G[]], the scaling factor is the product of the scaling+-- factor of E and that of G.+--+-- The scaling factor at the hole of E[] is used to determine how a binder+-- should be scaled if it commutes with E. This appears, in particular, in the+-- case-of-case transformation.+contHoleScaling :: SimplCont -> Mult+contHoleScaling (Stop _ _ _) = OneTy+contHoleScaling (CastIt { sc_cont = k })+  = contHoleScaling k+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })+  = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (Select { sc_bndr = id, sc_cont = k })+  = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })+  = w `mkMultMul` contHoleScaling k+  where+    (w, _, _) = splitFunTy fun_ty+contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k+contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k+contHoleScaling (TickIt _ k) = contHoleScaling k++-------------------+countArgs :: SimplCont -> Int+-- Count all arguments, including types, coercions,+-- and other values; skipping over casts.+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs (CastIt     { sc_cont = cont }) = countArgs cont+countArgs _                               = 0++countValArgs :: SimplCont -> Int+-- Count value arguments only+countValArgs (ApplyToTy  { sc_cont = cont }) = countValArgs cont+countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont+countValArgs (CastIt     { sc_cont = cont }) = countValArgs cont+countValArgs _                               = 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 GHC.Core.Unfold+    lone (ApplyToVal {}) = False  -- NB: even a type application or cast+    lone (CastIt {})     = False  --     stops it being "lone"+    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 { sc_cont = 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++contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]+-- Get the leading arguments from the `SimplCont`, as /OutExprs/+contOutArgs env cont+  = go cont+  where+    in_scope = seInScope env++    go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })+      = Type ty : go cont++    go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })+      | isSimplified dup = arg : go cont+      | otherwise        = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont+        -- Make sure we apply the static environment `sc_env` as a substitution+        --   to get an OutExpr.  See (BF1) in Note [tryRules: plan (BEFORE)]+        --   in GHC.Core.Opt.Simplify.Iteration+        -- NB: we use substExpr, not substExprSC: we want to get the benefit of+        --     knowing what is evaluated etc, via the in-scope set++    -- No more arguments+    go _ = []++dropContArgs :: FullArgCount -> SimplCont -> SimplCont+dropContArgs 0 cont = cont+dropContArgs n (ApplyToTy  { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n (ApplyToVal { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont)++-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'.+-- This can be more insightful than the limited syntactic context that+-- 'SimplCont' provides, because the 'Stop' constructor might carry a useful+-- 'SubDemand'.+-- For example, when simplifying the argument `e` in `f e` and `f` has the+-- demand signature `<MP(S,A)>`, this function will give you back `P(S,A)` when+-- simplifying `e`.+--+-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought+-- about what to do then and no call sites so far seem to care.+contEvalContext :: SimplCont -> SubDemand+contEvalContext k = case k of+  Stop _ _ sd              -> sd+  TickIt _ k               -> contEvalContext k+  CastIt   { sc_cont = k } -> contEvalContext k+  ApplyToTy{ sc_cont = k } -> contEvalContext k+    --  ApplyToVal{sc_cont=k}      -> mkCalledOnceDmd $ contEvalContext k+    -- Not 100% sure that's correct, . Here's an example:+    --   f (e x) and f :: <SC(S,C(1,L))>+    -- then what is the evaluation context of 'e' when we simplify it? E.g.,+    --   simpl e (ApplyToVal x $ Stop "C(S,C(1,L))")+    -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all.+    -- But for now we just panic:+  ApplyToVal{}               -> pprPanic "contEvalContext" (ppr k)+  StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info))+  StrictBind{sc_bndr=bndr}   -> subDemandIfEvaluated (idDemandInfo bndr)+  Select{}                   -> topSubDmd+    -- Perhaps reconstruct the demand on the scrutinee by looking at field+    -- and case binder dmds, see addCaseBndrDmd. No priority right now.++-------------------+mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo+mkArgInfo env fun rules_for_fun cont+  | n_val_args < idArity fun            -- Note [Unsaturated functions]+  = ArgInfo { ai_fun = fun, ai_args = []+            , ai_rules = rules_for_fun+            , ai_encl = False+            , ai_dmds = vanilla_dmds+            , ai_discs = vanilla_discounts }+  | otherwise+  = ArgInfo { ai_fun   = fun+            , ai_args  = []+            , ai_rules = rules_for_fun+            , ai_encl  = fun_has_rules || contHasRules cont+            , ai_dmds  = add_type_strictness (idType fun) arg_dmds+            , ai_discs = arg_discounts }+  where+    n_val_args  = countValArgs cont++    fun_has_rules = not (null rules_for_fun)++    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_dmds, arg_dmds :: [Demand]+    vanilla_dmds  = repeat topDmd++    arg_dmds+      | not (seInline env)+      = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]+      | otherwise+      = -- add_type_str fun_ty $+        case splitDmdSig (idDmdSig 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 GHC.Core.Op.Simplify.Utils.analyseCont)+                   if isDeadEndDiv result_info then+                        demands  -- Finite => result is bottom+                   else+                        demands ++ vanilla_dmds+               | otherwise+               -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands) $+                  vanilla_dmds      -- Not enough args, or no strictness++    add_type_strictness :: Type -> [Demand] -> [Demand]+    -- 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_strictness is done repeatedly (for each call);+    --   might be better once-for-all in the function+    -- But beware primops/datacons with no strictness++    add_type_strictness fun_ty dmds+      | null dmds = []++      | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty+      = add_type_strictness fun_ty' dmds     -- Look through foralls++      | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info+      , dmd : rest_dmds <- dmds+      , let dmd'+             | definitelyUnliftedType arg_ty+             = strictifyDmd dmd+             | otherwise+             -- Something that's not definitely unlifted.+             -- If the type is representation-polymorphic, we can't know whether+             -- it's strict.+             = dmd+      = dmd' : add_type_strictness fun_ty' rest_dmds++      | otherwise+      = dmds++{- Note [Unsaturated functions]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (test eyeball/inline4)+        x = a:as+        y = f x+where f has arity 2.  Then we do not want to inline 'x', because+it'll just be floated out again.  Even if f has lots of discounts+on its first argument -- it must be saturated for these to kick in++Note [Do not expose strictness if sm_inline=False]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#15163 showed a case in which we had++  {-# INLINE [1] zip #-}+  zip = undefined++  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}++If we expose zip's bottoming nature when simplifying 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 pathological 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 that isn't just a seq, 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.++Note [Seq is boring]+~~~~~~~~~~~~~~~~~~~~+Suppose+  f x = case v of+          True  -> Just x+          False -> Just (x-1)++Now consider these variants of+   case (f x) of ...++1. [Dead case binder]: inline f+      case f x of b{-dead-} { DEFAULT -> blah[no b] }+   Inlining (f x) will allow us to avoid ever allocating (Just x),+   since the case binder `b` is dead.  We will end up with a+     join point for blah, thus+         join j = blah in+         case v of { True -> j; False -> j }+   which will turn into (case v of DEFAULT -> blah)+   All good++2. [Live case binder, live alt binders]: inline f+       case f x of b { Just y -> blah[y,b] }+   Inlining (f x) will mean we still allocate (Just x),+   but we also get to bind `y` without fetching it out of the Just, thus+         join j y b = blah[y,b]+         case v of { True -> j x (Just x)+                   ; False -> let y = x-1 in j y (Just y) }+   Inlining (f x) has a small benefit, perhaps.+   (To T14955 it makes a surprisingly large difference of ~30% to inline here.)++3. [Live case binder, dead alt binders]: maybe don't inline f+      case f x of b { DEFAULT -> blah[b] }+   Inlining (f x) will still mean we allocate (Just x). We'd get:+         join j b = blah[b]+         case v of { True -> j (Just x); False -> j (Just (x-1)) }+   No new optimisations are revealed. Nothing is gained.+   (This is the situation in T22317.)++   A variant is when we have a data constructor with dead binders:+       case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] }+   Instead of DEFAULT we have a single constructor alternative+   with all dead binders.  Again, no gain from inlining (f x)++4. [Live case binder, dead alt binders]: small f+   Suppose f is CPR'd, so it looks like+       f x = case $wf x of (# a #) -> Just a+   Then even in case (3) we want to inline:+      case f x of b { DEFAULT -> blah[b] }+   -->+      case $wf x of (# a #) ->+      let b = Just a in blah[b]+   This is very good; we now know a lot about `b` (instead of nothing)+   and `blah` might benefit.  Similarly if `f` has a join point+      f x = join $j y = Just y in ...+   Again the case (f x) is now consuming a constructor (Just y).++   This is very like the situation described in Note [RHS of lets]+   in GHC.Core.Opt.Simplify.Inline; (case e of b -> blah) is just+   like a strict `let`.++Conclusion: in interestingCallCtxt, a case-expression (i.e. Select continuation)+usually gives a CaseCtxt (cases 1,2); but when (cases 3,4):+  * It has a non-dead case-binder+  * It has one alternative+  * All the binders in the alternative are dead+then the `case` is just a strict let-binding, so use RhsCtxt NonRecursive.+This RhsCtxt gives a small incentive for small functions to inline.+That incentive is what is needed in case (4).++Wrinkle (SB1).  The 'small incentive' is implemented by `calc_some_benefit` in+GHC.Core.Opt.Simplify.Inline.tryUnfolding.  We restrict the incentive just to+funtions that have unfolding guidance of `UnfWhen`, which particularly includes+wrappers created by CPR, exactly case (4) above.  Without this limitation I+got too much fruitless inlining, which led to regressions (#22317 is an example).++A good example of a function where this 'small incentive' is important is+GHC.Internal.Bignum.Integer where we ended up with calls like this:+     case (integerSignum a b) of r -> ...+but were failing to inline integerSignum, even though it always returns+a single constructor, so it is very helpful to inline it. There is also an+issue of confluence-of-the-simplifier.  Suppose we have+    f x = case x of r -> ...+and the Simplifier sees+    f (integerSigNum a b)+Because `f` scrutines `x`, the unfolding guidance for f gives a discount+for `x`; and that discount makes interestingCallContext for the context+`f <>` return DiscArgCtxt, which again gives that incentive.  We don't want+the incentive to disappear when we inline `f`!+-}++lazyArgContext :: ArgInfo -> CallCtxt+-- Use this for lazy arguments+lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+  | encl_rules                = RuleArgCtxt+  | disc:_ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here+  | otherwise                 = BoringCtxt   -- Nothing interesting++strictArgContext :: ArgInfo -> CallCtxt+strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+-- Use this for strict arguments+  | encl_rules                = RuleArgCtxt+  | disc:_ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here+  | otherwise                 = RhsCtxt NonRecursive+      -- Why RhsCtxt?  if we see f (g 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'+      --+      -- Why NonRecursive?  Becuase it's a bit like+      --   let a = g x in f a++interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt+-- See Note [Interesting call context]+interestingCallContext env cont+  = interesting cont+  where+    interesting (Select {sc_alts=alts, sc_bndr=case_bndr})+      | not (seCaseCase env)         = BoringCtxt -- See Note [No case of case is boring]+      | [Alt _ bs _] <- alts+      , all isDeadBinder bs+      , not (isDeadBinder case_bndr) = RhsCtxt NonRecursive -- See Note [Seq is boring]+      | otherwise                    = CaseCtxt+++    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 GHC.Core.Unfold++    interesting (StrictArg { sc_fun = fun }) = strictArgContext fun+    interesting (StrictBind {})              = BoringCtxt+    interesting (Stop _ cci _)               = cci+    interesting (TickIt _ k)                 = interesting k+    interesting (ApplyToTy { sc_cont = k })  = interesting k+    interesting (CastIt { sc_cont = 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.++contHasRules :: 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.  So contHasRules+-- tries to see if the context of the f-call is a call to a function+-- with rules.+--+-- The ai_encl 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+contHasRules cont+  = go cont+  where+    go (ApplyToVal { sc_cont = cont }) = go cont+    go (ApplyToTy  { sc_cont = cont }) = go cont+    go (CastIt { sc_cont = cont })     = go cont+    go (StrictArg { sc_fun = fun })    = ai_encl fun+    go (Stop _ RuleArgCtxt _)          = True+    go (TickIt _ c)                    = go c+    go (Select {})                     = False+    go (StrictBind {})                 = False      -- ??+    go (Stop _ _ _)                    = False++{- Note [Interesting arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An argument is interesting if it deserves a discount for unfoldings+with a discount in that argument position.  The idea is to avoid+unfolding a function that is applied only to variables that have no+unfolding (i.e. they are probably lambda bound): f x y z There is+little point in inlining f here.++Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But+we must look through lets, eg (let x = e in C a b), because the let will+float, exposing the value, if we inline.  That makes it different to+exprIsHNF.++Before 2009 we said it was interesting if the argument had *any* structure+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.++But we don't regard (f x y) as interesting, unless f is unsaturated.+If it's saturated and f hasn't inlined, then it's probably not going+to now!++Note [Conlike is interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f d = ...((*) d x y)...+        ... f (df d')...+where df is con-like. Then we'd really like to inline 'f' so that the+rule for (*) (df d) can fire.  To do this+  a) we give a discount for being an argument of a class-op (eg (*) d)+  b) we say that a con-like argument (eg (df d)) is interesting+-}++interestingArg :: SimplEnv -> CoreExpr -> ArgSummary+-- See Note [Interesting arguments]+interestingArg env e = go env 0 e+  where+    -- n is # value args to which the expression is applied+    go env n (Var v)+       = case substId env v of+           DoneId v'            -> go_var n v'+           DoneEx e _           -> go (zapSubstEnv env)             n e+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e++    go _   _ (Lit l)+       | isLitRubbish l        = TrivArg -- Leads to unproductive inlining in WWRec, #20035+       | otherwise             = 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+                                    -- DFuns are con-like; see Note [Conlike is interesting]+       | idArity v > n = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0         = NonTrivArg -- Saturated or unknown call+       | otherwise  -- n==0, no value arguments; look for an interesting unfolding+       = case idUnfolding v of+           OtherCon [] -> NonTrivArg   -- It's evaluated, but that's all we know+           OtherCon _  -> ValueArg     -- Evaluated and we know it isn't these constructors+              -- See Note [OtherCon and interestingArg]+           DFunUnfolding {} -> ValueArg   -- We konw that idArity=0+           CoreUnfolding{ uf_cache = cache }+             | uf_is_conlike cache -> ValueArg    -- Includes constructor applications+             | uf_is_value cache   -> NonTrivArg  -- Things like partial applications+             | otherwise           -> TrivArg+           BootUnfolding           -> TrivArg+           NoUnfolding             -> TrivArg++{- Note [OtherCon and interestingArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+interstingArg returns+   (a) NonTrivArg for an arg with an OtherCon [] unfolding+   (b) ValueArg for an arg with an OtherCon [c1,c2..] unfolding.++Reason for (a): I found (in the GHC.Internal.Bignum.Integer module) that I was+inlining a pretty big function when all we knew was that its arguments+were evaluated, nothing more.  That in turn make the enclosing function+too big to inline elsewhere.++Reason for (b): we want to inline integerCompare here+  integerLt# :: Integer -> Integer -> Bool#+  integerLt# (IS x) (IS y)                  = x <# y+  integerLt# x y | LT <- integerCompare x y = 1#+  integerLt# _ _                            = 0#++************************************************************************+*                                                                      *+                  SimplMode+*                                                                      *+************************************************************************+-}++updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode+-- See Note [The environments of the Simplify pass]+updModeForStableUnfoldings unf_act current_mode+  = current_mode { sm_phase      = phaseFromActivation unf_act+                 , sm_eta_expand = False+                 , sm_inline     = True }+       -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules]+       -- 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]+-- See Note [The environments of the Simplify pass]+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_cast_swizzle = False+                      -- See Note [Cast swizzling on rule LHSs]+                 , sm_eta_expand   = False }++{- Note [Simplifying rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying a rule LHS, refrain from /any/ inlining or applying+of other RULES. Doing anything to the LHS is plain confusing, because+it means that what the rule matches is not what the user+wrote. c.f. #10595, and #10528.++* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks+  introducing Ticks into the LHS, which makes matching+  trickier. #10665, #10745.++  Doing this to either side confounds tools like HERMIT, which seek to reason+  about and apply the RULES as originally written. See #10829.++  See also Note [Do not expose strictness if sm_inline=False]++* sm_eta_expand: the template (LHS) of a rule must only mention coercion+  /variables/ not arbitrary coercions.  See Note [Casts in the template] in+  GHC.Core.Rules.  Eta expansion can create new coercions; so we switch+  it off.++There is, however, one case where we are pretty much /forced/ to transform the+LHS of a rule: postInlineUnconditionally. For instance, in the case of++    let f = g @Int in f++We very much want to inline f into the body of the let. However, to do so (and+be able to safely drop f's binding) we must inline into all occurrences of f,+including those in the LHS of rules.++This can cause somewhat surprising results; for instance, in #18162 we found+that a rule template contained ticks in its arguments, because+postInlineUnconditionally substituted in a trivial expression that contains+ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for+details.++Note [Cast swizzling on rule LHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the LHS of a RULE we may have+       (\x. blah |> CoVar cv)+where `cv` is a coercion variable.  Critically, we really only want+coercion /variables/, not general coercions, on the LHS of a RULE.  So+we don't want to swizzle this to+      (\x. blah) |> (Refl xty `FunCo` CoVar cv)+So we switch off cast swizzling in updModeForRules.++Note [Eta expansion in stable unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+SPJ Jul 22: whether or not eta-expansion is switched on in a stable+unfolding, or the RHS of a RULE, seems to be a bit moot. But switching+it on adds clutter, so I'm experimenting with switching off+eta-expansion in such places.++In the olden days, we really /wanted/ to switch it off.++    Old note: 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 now specialisation of the overloading doesn't work properly+    (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509.+    So we disable eta-expansion in stable unfoldings.++But this old note is no longer relevant because the specialiser has+improved: see Note [Account for casts in binding] in+GHC.Core.Opt.Specialise.  So we seem to have a free choice.++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.+-}++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+  = ISE in_scope id_unf+  where+    in_scope = seInScope env+    phase    = sePhase env+    id_unf   = whenActiveUnfoldingFun (isActive phase)+     -- When sm_rules was off we used to test for a /stable/ unfolding,+     -- but that seems wrong (#20941)++----------------------+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 occurrence 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 FinalPhase (the last+phase), at which point don't.++Note [pre/postInlineUnconditionally in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in gentle mode we want to do preInlineUnconditionally.  The+reason is that too little clean-up happens if you don't inline+use-once things.  Also a bit of inlining is *good* for full laziness;+it can expose constant sub-expressions.  Example in+spectral/mandel/Mandel.hs, where the mandelset function gets a useful+let-float if you inline windowToViewport++However, as usual for Gentle mode, do not inline things that are+inactive in the initial stages.  See Note [Gentle mode].++Note [Stable unfoldings and preInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!+Example++   {-# INLINE f #-}+   f :: Eq a => a -> a+   f x = ...++   fInt :: Int -> Int+   fInt = f Int dEqInt++   ...fInt...fInt...fInt...++Here f occurs just once, in the RHS of fInt. But if we inline it there+it might make fInt look big, and we'll lose the opportunity to inline f+at each of fInt's call sites.  The INLINE pragma will only inline when+the application is saturated for exactly this reason; and we don't+want PreInlineUnconditionally to second-guess it. A live example is #3736.+    c.f. Note [Stable unfoldings and postInlineUnconditionally]++NB: this only applies for INLINE things. Do /not/ switch off+preInlineUnconditionally for++* INLINABLE. It just says to GHC "inline this if you like".  If there+  is a unique occurrence, we want to inline the stable unfolding, not+  the RHS.++* NONLINE[n] just switches off inlining until phase n.  We should+  respect that, but after phase n, just behave as usual.++* NoUserInlinePrag.  There is no pragma at all. This ends up on wrappers.+  (See #18815.)++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-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core+-- 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 && isDeadEndId 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)++  -- See Note [Stable unfoldings and preInlineUnconditionally]+  | not (isInlinePragma 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_n_br   = 1+                  , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase+    one_occ OneOcc{ occ_n_br   = 1+                  , occ_in_lam = IsInsideLam+                  , occ_int_cxt = IsInteresting } = canInlineInLam rhs+    one_occ _                                     = False++    pre_inline_unconditionally = sePreInline env+    active = isActive (sePhase env) (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 (Var v)    = case idOccInfo v of+                                  OneOcc { occ_in_lam = IsInsideLam } -> True+                                  ManyOccs {}                         -> True+                                  _                                   -> False+    canInlineInLam _          = False+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting+      -- ticks around a Lam will disappear anyway.++    early_phase = sePhase env /= FinalPhase+    -- 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.+    --+    -- What exactly to check in `early_phase` above is the subject of #17910.+    --+    -- !10088 introduced an additional Simplifier iteration in LargeRecord+    -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#`+    -- (a non-trivial value) which we immediately inline back in.+    -- Ideally, we'd never have inlined it because the binding turns out to+    -- be expandable; unfortunately we need an iteration of the Simplifier to+    -- attach the proper unfolding and can't check isExpandableUnfolding right+    -- here.+    -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look+    -- at the non-existent unfolding for the `I# 2#` which is also floated out.)++{-+************************************************************************+*                                                                      *+                  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 trivial 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.++NB: unconditional inlining of this sort can introduce ticks in places that+may seem surprising; for instance, the LHS of rules. See Note [Simplifying+rules] for details.+-}++postInlineUnconditionally+    :: SimplEnv -> BindContext+    -> InId -> OutId    -- The binder (*not* a CoVar), including its unfolding+    -> OutExpr+    -> Bool+-- Precondition: rhs satisfies the let-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+postInlineUnconditionally env bind_cxt old_bndr bndr 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 (bindContextLevel bind_cxt)+                                = False -- Note [Top level and postInlineUnconditionally]+  | exprIsTrivial rhs           = True+  | BC_Join {} <- bind_cxt      = False -- See point (1) of Note [Duplicating join points]+                                        --     in GHC.Core.Opt.Simplify.Iteration+  | otherwise+  = case occ_info of+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }+        -- See Note [Inline small things to avoid creating a thunk]++        | n_br >= 100 -> False  -- See #23627++        | n_br == 1, NotInsideLam <- in_lam  -- One syntactic occurrence+        -> True                              -- See Note [Post-inline for single-use things]++--        | is_unlifted                        -- Unlifted binding, hence ok-for-spec+--        -> True                              -- hence cheap to inline probably just a primop+--                                             -- Not a big deal either way+-- No, this is wrong.  {v = p +# q; x = K v}.+-- Don't inline v; it'll just get floated out again. Stupid.++        | is_demanded+        -> False                            -- No allocation (it'll be a case expression in the end)+                                            -- so inlining duplicates code but nothing more++        | otherwise+        -> work_ok in_lam int_cxt && smallEnoughToInline uf_opts unfolding+              -- Multiple syntactic occurences; but lazy, and small enough to dup+              -- ToDo: consider discount on smallEnoughToInline if int_cxt is true++      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++  where+    work_ok NotInsideLam _              = True+    work_ok IsInsideLam  IsInteresting  = isCheapUnfolding unfolding+    work_ok IsInsideLam  NotInteresting = False+      -- NotInsideLam: 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'++      -- InsideLam: check for acceptable work duplication, using isCheapUnfoldign+      -- int_cxt to prevent us inlining inside a lambda without some+      -- good reason.  See the notes on int_cxt in preInlineUnconditionally++--    is_unlifted = isUnliftedType (idType bndr)+    is_demanded = isStrUsedDmd (idDemandInfo bndr)+    occ_info    = idOccInfo old_bndr+    unfolding   = idUnfolding bndr+    uf_opts     = seUnfoldingOpts env+    phase       = sePhase env+    active      = isActive phase (idInlineActivation bndr)+        -- See Note [pre/postInlineUnconditionally in gentle mode]++{- Note [Inline small things to avoid creating a thunk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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.  And bits of GHC itself start+to allocate more.  An egregious example is test perf/compiler/T14697,+where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more.++Note [Post-inline for single-use things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have++   let x = rhs in ...x...++and `x` is used exactly once, and not inside a lambda, then we will usually+preInlineUnconditinally. But we can still get this situation in+postInlineUnconditionally:++  case K rhs of K x -> ...x....++Here we'll use `simplAuxBind` to bind `x` to (the already-simplified) `rhs`;+and `x` is used exactly once.  It's beneficial to inline right away; otherwise+we risk creating++   let x = rhs in ...x...++which will take another iteration of the Simplifier to eliminate.  We do this in+two places++1. In the full `postInlineUnconditionally` look for the special case+   of "one occurrence, not under a lambda", and inline unconditionally then.++   This is a bit risky: see Note [Avoiding simplifying repeatedly] in+   Simplify.Iteration.  But in practice it seems to be a small win.++2. `simplAuxBind` does a kind of poor-man's `postInlineUnconditionally`.  It+   does not need to account for many of the cases (e.g. top level) that the+   full `postInlineUnconditionally` does.  Moreover, we don't have an+   OutId, which `postInlineUnconditionally` needs.  I got a slight improvement+   in compiler performance when I added this test.++Here's an example that we don't currently 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 would 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!+++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+*                                                                      *+************************************************************************+-}++rebuildLam :: SimplEnv+           -> [OutBndr] -> OutExpr+           -> SimplCont+           -> SimplM OutExpr+-- (rebuildLam env bndrs body cont)+-- returns expr which means the same as \bndrs. body+--+-- But it tries+--      a) eta reduction, if that gives a trivial expression+--      b) eta expansion [only if there are some value lambdas]+--+-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set++rebuildLam _env [] body _cont+  = return body++rebuildLam env bndrs@(bndr:_) body cont+  = {-# SCC "rebuildLam" #-} try_eta bndrs body+  where+    rec_ids  = seRecIds env+    in_scope = getInScope env  -- Includes 'bndrs'+    mb_rhs   = contIsRhs cont++    -- See Note [Eta reduction based on evaluation context]+    eval_sd = contEvalContext cont+        -- NB: cont is never ApplyToVal, because beta-reduction would+        -- have happened.  So contEvalContext can panic on ApplyToVal.++    try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr+    try_eta bndrs body+      | -- Try eta reduction+        seDoEtaReduction env+      , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd+      = do { tick (EtaReduction bndr)+           ; return etad_lam }++      | -- Try eta expansion+        Nothing <- mb_rhs  -- See Note [Eta expanding lambdas]+      , seEtaExpand env+      , any isRuntimeVar bndrs  -- Only when there is at least one value lambda already+      , Just body_arity <- exprEtaExpandArity (seArityOpts env) body+      = do { tick (EtaExpansion bndr)+           ; let body' = etaExpandAT in_scope body_arity body+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body+                                          , text "after" <+> ppr body'])+           -- NB: body' might have an outer Cast, but if so+           --     mk_lams will pull it further out, past 'bndrs' to the top+           ; return (mk_lams bndrs body') }++      | otherwise+      = return (mk_lams bndrs body)++    mk_lams :: [OutBndr] -> OutExpr -> OutExpr+    -- mk_lams pulls casts and ticks to the top+    mk_lams bndrs body@(Lam {})+      = mk_lams (bndrs ++ bndrs1) body1+      where+        (bndrs1, body1) = collectBinders body++    mk_lams bndrs (Tick t expr)+      | tickishFloatable t+      = mkTick t (mk_lams bndrs expr)++    mk_lams bndrs (Cast body co)+      | -- Note [Casts and lambdas]+        seCastSwizzle env+      , not (any bad bndrs)+      = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co)+      where+        co_vars  = tyCoVarsOfCo co+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++    mk_lams bndrs body+      = 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.++Note [Casts and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        (\(x:tx). (\(y:ty). e) `cast` co)++We float the cast out, thus+        (\(x:tx) (y:ty). e) `cast` (tx -> co)++We do this for at least three reasons:++1. There is a danger here that the two lambdas look separated, and the+   full laziness pass might float an expression to between the two.++2. The occurrence analyser will mark x as InsideLam if the Lam nodes+   are separated (see the Lam case of occAnal).  By floating the cast+   out we put the two Lams together, so x can get a vanilla Once+   annotation.  If this lambda is the RHS of a let, which we inline,+   we can do preInlineUnconditionally on that x=arg binding.  With the+   InsideLam OccInfo, we can't do that, which results in an extra+   iteration of the Simplifier.++3. It may cancel with another cast.  E.g+      (\x. e |> co1) |> co2+   If we float out co1 it might cancel with co2.  Similarly+      let f = (\x. e |> co1) in ...+   If we float out co1, and then do cast worker/wrapper, we get+      let f1 = \x.e; f = f1 |> co1 in ...+   and now we can inline f, hoping that co1 may cancel at a call site.++TL;DR: put the lambdas together if at all possible.++In general, here's the transformation:+        \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))++We call this "cast swizzling". It is controlled by sm_cast_swizzle.+See also Note [Cast swizzling on rule LHSs]++Wrinkles++* 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, namely+  not (any bad bndrs).  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 :: SimplEnv -> BindContext -> OutId -> OutExpr+                -> SimplM (ArityType, OutExpr)+-- See Note [Eta-expanding at let bindings]+tryEtaExpandRhs env bind_cxt bndr rhs+  | seEtaExpand env         -- If Eta-expansion is on+  , wantEtaExpansion rhs    -- and we'd like to eta-expand e+  , do_eta_expand           -- and e's manifest arity is lower than+                            --     what it could be+                            --     (never true for join points)+  =                         -- Do eta-expansion.+    assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $+       -- assert: this never happens for join points; see GHC.Core.Opt.Arity+       --         Note [Do not eta-expand join points]+    do { tick (EtaExpansion bndr)+       ; return (arity_type, etaExpandAT in_scope arity_type rhs) }++  | otherwise+  = return (arity_type, rhs)++  where+    in_scope   = getInScope env+    arity_opts = seArityOpts env+    is_rec     = bindContextRec bind_cxt+    (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs++wantEtaExpansion :: CoreExpr -> Bool+-- Mostly True; but False of PAPs which will immediately eta-reduce again+-- See Note [Which RHSs do we eta-expand?]+wantEtaExpansion (Cast e _)             = wantEtaExpansion e+wantEtaExpansion (Tick _ e)             = wantEtaExpansion e+wantEtaExpansion (Lam b e) | isTyVar b  = wantEtaExpansion e+wantEtaExpansion (App e _)              = wantEtaExpansion e+wantEtaExpansion (Var {})               = False+wantEtaExpansion (Lit {})               = False+wantEtaExpansion _                      = True++{-+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 GHC.Core.Opt.Arity.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 [Which RHSs do we eta-expand?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't eta-expand:++* Trivial RHSs, e.g.     f = g+  If we eta expand do+    f = \x. g x+  we'll just eta-reduce again, and so on; so the+  simplifier never terminates.++* PAPs: see Note [Do not eta-expand PAPs]++What about things like this?+   f = case y of p -> \x -> blah++Here we do eta-expand.  This is a change (Jun 20), but if we have+really decided that f has arity 1, then putting that lambda at the top+seems like a Good idea.++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs.  But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by #9020.+Suppose we have a PAP+    foo :: IO ()+    foo = returnIO ()+Then we can eta-expand to+    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 before, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++Moreover, if we eta expand+        f = g d  ==>  f = \x. g d x+that might in turn make g inline (if it has an inline pragma), which+we might not want.  After all, INLINE pragmas say "inline only when+saturated" so we don't want to be too gung-ho about saturating!++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+GHC.Core.Opt.Simplify.Utils.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.  Several points worth noting++(AB1) 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*)++(AB2) We must do closeOverKinds.  Example (#10934):+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...+      Here we want to float 't', but we must remember to abstract over+      'k' as well, even though it is not explicitly mentioned in the RHS,+      otherwise we get+         t = /\ (f:k->*) (a:k). AccFailure @ (f a)+      which is obviously bogus.++(AB3) We get the variables to abstract over by filtering down the+      the main_tvs for the original function, picking only ones+      mentioned in the abstracted body. This means:+      - they are automatically in dependency order, because main_tvs is+      - there is no issue about non-determinism+      - we don't gratuitously change order, which may help (in a tiny+        way) with CSE and/or the compiler-debugging experience++(AB4) 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'.+      Remember this bizarre case too:+           x::a = x+      Here, we must abstract 'x' over 'a'.++      Why is it worth doing this?  Partly tidiness; and partly #22459+      which showed that it's harder to do polymorphic specialisation well+      if there are dictionaries abstracted over unnecessary type variables.+      See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise++(AB5) We do dependency analysis on recursive groups prior to determining+      which variables to abstract over.+      This is useful, because ANFisation in prepareBinding may float out+      values out of a complex recursive binding, e.g.,+          letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...+        ==> { prepareBinding }+          letrec { foo = "blah"#+                   bar = [42]+                   xs = g @a foo bar xs } in+          ...+      and we don't want to abstract foo and bar over @a.++      (Why is it OK to float the unlifted `foo` there?+      See Note [Core top-level string literals] in GHC.Core;+      it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)++      It is also necessary to do dependency analysis, because+      otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the+      top-level, and that triggers a CoreLint error because `foo` is *not*+      manifestly a literal string.+-}++abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats+              -> OutExpr -> SimplM ([OutBind], OutExpr)+abstractFloats uf_opts top_lvl main_tvs floats body+  = assert (notNull body_floats) $+    assert (isNilOL (sfJoinFloats floats)) $+    do  { let sccs = concatMap to_sccs body_floats+        ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs+        ; return (float_binds, GHC.Core.Subst.substExpr subst body) }+  where+    is_top_lvl  = isTopLevel top_lvl+    body_floats = letFloatBinds (sfLetFloats floats)+    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)++    -- See wrinkle (AB5) in Note [Which type variables to abstract over]+    -- for why we need to re-do dependency analysis+    to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]+    to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it+    to_sccs (Rec prs)     = sccs+      where+        (ids,rhss) = unzip prs+        sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])+                       (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)+                       (zip3 ids rhss (map exprFreeVars rhss))++    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)+    abstract subst (AcyclicSCC (id, rhs, _empty_var_set))+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'+                 !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app+           ; return (subst', NonRec poly_id2 poly_rhs) }+      where+        rhs' = GHC.Core.Subst.substExpr subst rhs++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')++    abstract subst (CyclicSCC trpls)+      = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids+           ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)+                 poly_pairs = [ mk_poly2 poly_id tvs_here rhs'+                              | (poly_id, rhs) <- poly_ids `zip` rhss+                              , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]+           ; return (subst', Rec poly_pairs) }+      where+        (ids,rhss,_fvss) = unzip3 trpls++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)++        -- See wrinkle (AB4) in Note [Which type variables to abstract over]+        get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs+        get_rec_rhs_tvs rhs_fvs        = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs+                                  -- nonDet is safe because of wrinkle (AB3)++        get_tvs :: Var -> VarSet -> VarSet+        get_tvs var free_tvs+           | isTyVar var      -- CoVars have been substituted away+           = extendVarSet free_tvs var+           | isCoVar var  -- CoVars can be free in the RHS, but they are never let-bound;+           = free_tvs     -- Do not call lookupIdSubst_maybe, though (#23426)+                          --    because it has a non-CoVar precondition+           | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var+           = -- 'var' is like 'x' in (AB4)+             exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs+           | otherwise+           = free_tvs++    choose_tvs free_tvs+       = filter (`elemVarSet` all_free_tvs) main_tvs  -- (AB3)+       where+         all_free_tvs = closeOverKinds free_tvs       -- (AB2)++    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   = mkInfForAllTys tvs_here (idType var) -- But new type of course+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id+                              mkLocalId poly_name (idMult var) 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 uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing++        -- 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.  filterAlts: eliminate alternatives that cannot match, including+    the DEFAULT alternative.  Here "cannot match" includes knowledge+    from GADTs++2.  refineDefaultAlt: 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.+    See GHC.Core.Utils Note [Refine DEFAULT case alternatives]++3. combineIdenticalAlts: combine identical alternatives into a DEFAULT.+   See CoreUtils Note [Combine identical alternatives], which also+   says why we do this on InAlts not on OutAlts++4. Returns a list of the constructors that cannot holds in the+   DEFAULT alternative (if there is one)++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!++Note [Shadowing in prepareAlts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an+/OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build+a new /InAlt/.  If you pass an OutId, we'll end up applying the+substitution twice: disaster (#23012).++However this does mean that filling in the default alt might be+delayed by a simplifier cycle, because an InId has less info than an+OutId.  Test simplCore/should_compile/simpl013 apparently shows this+up, although I'm not sure exactly how..+-}++prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])+-- The returned alternatives can be empty, none are possible+--+-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]+prepareAlts scrut case_bndr alts+  | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)+  = do { us <- getUniquesM+       ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts+             (yes2,  alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1+               -- The multiplicity on case_bndr's is the multiplicity of the+               -- case expression The newly introduced patterns in+               -- refineDefaultAlt must be scaled by this multiplicity+             (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)+                    _     -> []++{- Note [Merging nested cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic case-merge stuff is described in Note [Merge Nested Cases] in GHC.Core.Utils++We do it here in `prepareAlts` (on InAlts) rather than after (on OutAlts) for two reasons:++* It "belongs" here with `filterAlts`, `refineDefaultAlt` and `combineIdenticalAlts`.++* In test perf/compiler/T22428 I found that I was getting extra Simplifer iterations:+    1. Create a join point+    2. That join point gets inlined at all call sites, so it is now dead.+    3. Case-merge happened, but left behind some trivial bindings (see `mergeCaseAlts`)+    4. Get rid of the trivial bindings+  The first two seem reasonable.  It's imaginable that we could do better on+  (3), by making case-merge join-point-aware, but it's not trivial.  But the+  fourth is just stupid.  Rather than always do an extra iteration, it's better+  to do the transformation on the input-end of teh Simplifier.+-}++{-+************************************************************************+*                                                                      *+                mkCase+*                                                                      *+************************************************************************++mkCase tries these things++* Note [Eliminate Identity Case]+* Note [Scrutinee Constant Folding]++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##     -> ...+            DEFAULT -> 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.++Wrinkle 1:+  Do not apply caseRules if there is just a single DEFAULT alternative,+  unless the case-binder is dead. Example:+     case e +# 3# of b { DEFAULT -> rhs }+  If we applied the transformation here we would (stupidly) get+     case e of b' { DEFAULT -> let b = b' +# 3# in rhs }+  and now the process may repeat, because that let will really+  be a case. But if the original case binder b is dead, we instead get+     case e of b' { DEFAULT -> rhs }+  and there is no such problem.++  See Note [Example of case-merging and caseRules] for a compelling+  example of why this dead-binder business can be really important.+++Wrinkle 2:+  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++Wrinkle 3:+  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'.++Wrinkle 4:+  In dataToTag we might need to make up some fake binders;+  see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold+++Note [Example of case-merging and caseRules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The case-transformation rules are quite powerful. Here's a+subtle example from #22375.  We start with++  data T = A | B | ...+    deriving Eq++  f :: T -> String+  f x = if | x==A -> "one"+           | x==B -> "two"+           | ...++In Core after a bit of simplification we get:++    f x = case dataToTagLarge# x of a# { _DEFAULT ->+          case a# of+            _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT ->+                        case b# of+                           _DEFAULT -> ...+                           1# -> "two"+                        }+            0# -> "one"+          }++Now consider what mkCase does to these case expressions.+The case-merge transformation Note [Merge Nested Cases]+does this (affecting both pairs of cases):++    f x = case dataToTagLarge# x of a# {+             _DEFAULT -> case dataToTagLarge# x of b# {+                          _DEFAULT -> ...+                          1# -> "two"+                         }+             0# -> "one"+          }++Now Note [caseRules for dataToTag] does its work, again+on both dataToTagLarge# cases:++    f x = case x of x1 {+             _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT ->+                         case x of x2 {+                           _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... }+                           B -> "two"+                         }}+             A -> "one"+          }+++The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of+caseRules (note that a# and b# were not dead in the original program+before all this merging).  However, since a# and b# /are/ in fact dead+in the resulting program, we are left with redundant dataToTagLarge# calls.+But they are easily eliminated by doing caseRules again, in+the next Simplifier iteration, this time noticing that a# and b# are+dead.  Hence the "dead-binder" sub-case of Wrinkle 1 of Note+[Scrutinee Constant Folding] above.  Once we do this we get++    f x = case x of x1 {+             _DEFAULT -> case x1 of x2 { _DEFAULT ->+                         case x1 of x2 {+                            _DEFAULT -> case x2 of x3 { _DEFAULT -> ... }+                            B -> "two"+                         }}+             A -> "one"+          }++and now we can do case-merge again, getting the desired++    f x = case x of+            A -> "one"+            B -> "two"+            ...++-}++mkCase, mkCase1, mkCase2, mkCase3+   :: SimplMode+   -> OutExpr -> OutId+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order+   -> SimplM OutExpr++--------------------------------------------------+--      1. Merge Nested Cases+--         See Note [Merge Nested Cases]+--             Note [Example of case-merging and caseRules]+--             Note [Cascading case merge]+--------------------------------------------------++mkCase mode scrut outer_bndr alts_ty alts+  | sm_case_merge mode+  , Just (joins, alts') <- mergeCaseAlts outer_bndr alts+  = do  { tick (CaseMerge outer_bndr)+        ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'+        ; return (mkLets joins case_expr) }+        -- mkCase1: 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!+  | otherwise+  = mkCase1 mode scrut outer_bndr alts_ty alts++--------------------------------------------------+--      2. Eliminate Identity Case+--         See Note [Eliminate Identity Case]+--------------------------------------------------++mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts')      -- Identity case+  | all identity_alt alts+  = do { tick (CaseIdentity case_bndr)+       ; return (mkTicks ticks $ re_cast scrut rhs1) }+  where+    ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts'+    identity_alt (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 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts+++--------------------------------------------------+--      2. Scrutinee Constant Folding+--         See Note [Scrutinee Constant Folding]+--------------------------------------------------++mkCase2 mode scrut bndr alts_ty alts+  | -- See Note [Scrutinee Constant Folding]+    case alts of+      [Alt DEFAULT _ _] -> isDeadBinder bndr -- see wrinkle 1+      _                 -> True+  , sm_case_folding mode+  , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut+  = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut')++       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts+                  -- mapMaybeM: discard unreachable alternatives+                  -- See Note [Unreachable caseRules alternatives]+                  -- in GHC.Core.Opt.ConstantFold++       ; mkCase3 mode scrut' bndr' alts_ty $+         add_default (re_sort alts')+       }++  | otherwise+  = mkCase3 mode 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 = 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 (Alt con bs rhs)+      = case tx_con con of+          Nothing   -> return Nothing+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'+                          ; return (Just (Alt 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 GHC.Core.Opt.ConstantFold+        do { us <- getUniquesM+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc+                                        (tyConAppArgs (idType new_bndr))+           ; return (ex_tvs ++ arg_ids) }+    mk_new_bndrs _ _ = return []++    re_sort :: [CoreAlt] -> [CoreAlt]+    -- Sort the alternatives to re-establish+    -- GHC.Core Note [Case expression invariants]+    re_sort alts = sortBy cmpAlt alts++    add_default :: [CoreAlt] -> [CoreAlt]+    -- See Note [Literal cases]+    add_default (Alt (LitAlt {}) bs rhs : alts) = Alt 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 slightly better code (although it should not, since+all cases are exhaustive) and/or optimise better.  I'm not certain that+it's necessary, but currently we do make this change.  We do it here,+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]+in GHC.Core.Opt.ConstantFold)+-}++--------------------------------------------------+--      Catch-all+--------------------------------------------------+mkCase3 _mode scrut bndr alts_ty alts+  = return (Case scrut bndr alts_ty alts)++-- See Note [Exitification] and Note [Do not inline exit join points] in+-- GHC.Core.Opt.Exitify+-- 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+  && case idOccInfo id of+        OneOcc { occ_in_lam = IsInsideLam } -> True+        _                                   -> False++{-+Note [Dead binders]+~~~~~~~~~~~~~~~~~~~~+Note that dead-ness is maintained by the simplifier, so that it is+accurate after simplification as well as before.++-}
+ GHC/Core/Opt/SpecConstr.hs view
@@ -0,0 +1,2946 @@+{-# LANGUAGE LambdaCase #-}+{-+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}+-}++module GHC.Core.Opt.SpecConstr(+        specConstrProgram,+        SpecConstrAnnotation(..),+        SpecFailWarning(..)+    ) where++import GHC.Prelude++import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug )++import GHC.Core+import GHC.Core.Subst+import GHC.Core.Utils+import GHC.Core.Unfold+import GHC.Core.Opt.Simplify.Inline+import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )+import GHC.Core.Opt.Monad+import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )+import GHC.Core.DataCon+import GHC.Core.Class( classTyVars )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.Rules+import GHC.Core.Predicate ( scopedSort, 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.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))+import GHC.Types.Literal ( litIsLifted )+import GHC.Types.Id+import GHC.Types.Id.Info ( IdDetails(..) )+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+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     ( fromMaybe, orElse, catMaybes, isJust, isNothing )+import GHC.Data.FastString++import GHC.Utils.Misc+import GHC.Utils.Outputable+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+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )+import Data.List.NonEmpty ( NonEmpty (..) )+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 in SpecConstr] 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 SpecConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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:++(FS1) Ignore specConstrThreshold, to specialise functions of arbitrary size+        (see scTopBind)+(FS2) Ignore specConstrCount, to make arbitrary numbers of specialisations+        (see specialise)+(FS3) Specialise even for arguments that are not scrutinised in the loop+        (see argToPat; #4448)+(FS4) Only specialise on recursive types a finite number of times+        (see sc_recursive; #5550; Note [Limit recursive specialisation])+(FS5) Use a different restriction on the maximum number of arguments which+        the optimisation will specialise. We tried removing the limit on worker+        args for forced specs (#14003) but this caused issues when specializing+        code for large data structures (#25197).+        This is handled by `too_many_worker_args` in `callsToNewPats`++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.++(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944).+  We don't want to make+     case M.foo_acf of M.foo_acf { DEFAULT -> blah }+  because the binder of a case-expression should never be imported.  Rather,+  we must localise it thus:+     case M.foo_acf of foo_acf { DEFAULT -> blah }+  We keep the same unique, so in the next round of simplification we'll replace+  any M.foo_acf's in `blah` by `foo_acf`.++  c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils.++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', warnings) = initUs_ us $+                              scTopBinds env0 (mg_binds guts)++       ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)++       ; return (guts { mg_binds = binds' }) }++  where+    specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing+    warn_msg :: SpecFailWarnings -> SDoc+    warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$+                        text "which resulted in no specialization being generated for these functions:" $$+                        nest 2 (vcat (map ppr warnings)) $$+                        (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")+scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])+scTopBinds _env []     = return (nullUsage, [], [])+scTopBinds env  (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $+                                                (\env -> scTopBinds env bs)+                            ; return (usg, b' ++ bs', warnings) }++{-+************************************************************************+*                                                                      *+\subsection{Environment: goes downwards}+*                                                                      *+************************************************************************++Note [ConVal work-free-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_vals field keeps track of in-scope value bindings, and is used in+two ways:++(1) To do case-of-known-constructor in a case expression.  E.g. if sc_vals+    includes [x :-> ConVal Just e], then we can simplify+      case x of Just y -> ...+    with the case-of-known-constructor transformation. (Yes this is+    done by the Simplifier, but SpecConstr creates new opportunities when+    it makes a specialised RHS for a function.)++    For (1) it is crucial that the arguments are /work-free/; see (CV1)+    below.++(2) To figure out call pattresns. E.g. if sc_vals includes+    [x :-> ConVal Just e], and we have call (f x), then we might want+    to specialise `f (Just _)`++    For (2) it is /not/ important that the constructor arguments are work-free;+    indeed, it would be bad to insist on that. For example+       let x = Just <expensive>+       in ....(f x)...+    Here we want to specialise for `f (Just _)`, and we won't do so if we+    don't allow [x :-> ConVal Just e] into the environment.  Does this ever happen?+    Yes: see #24282.++    (Yes, the Simplifier will ANF that let-binding, but SpecConstr can+    make more: see (CV1) for an example.)++Wrinkle:++(CV1) Why is work-free-ness important for (1)?  In the example in (1) above, of `e` is+      expensive, we do /not/ want to simplify+         case x of { Just y -> ... }  ==>   let y = e in ...+      because the x-binding still exists and we've now duplicated `e`.++      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_max_forced_args  :: !Int+  -- ^ The threshold at which a worker-wrapper transformation used as part of+  -- this pass will no longer happen even if a SPEC arg was used to force+  -- specialization. Measured in the number of arguments.+  -- See Note [Forcing specialisation]++  , 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)++                   sc_annotations :: UniqFM Name SpecConstrAnnotation+             }++---------------------+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars++---------------------+type ValueEnv = IdEnv Value            -- Domain is OutIds++data Value = ConVal            -- Constructor application+                  Bool             -- True <=> all args are work-free+                                   --      See Note [ConVal work-free-ness]+                  AltCon           -- Never DEFAULT+                  [CoreArg]        -- Saturates the constructor+           | LambdaVal         -- Inlinable lambdas or PAPs++instance Outputable Value where+   ppr LambdaVal            = text "<Lambda>"+   ppr (ConVal wf con args)+     | null args = ppr con+     | otherwise = parens (ppr con <> braces pp_wf <+> interpp'SP args)+     where+       pp_wf | wf        = text "wf"+             | otherwise = text "not-wf"+++---------------------+initScOpts :: DynFlags -> Module -> SpecConstrOpts+initScOpts dflags this_mod = SpecConstrOpts+        { sc_max_args    = maxWorkerArgs dflags,+          sc_max_forced_args = maxForcedSpecArgs 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+++++-- 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 id mb_val+  = case mb_val of+      Nothing -> env+      Just cv -> env { sc_vals = extendVarEnv (sc_vals env) id cv }++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 | DoBinderSwap v mco <- scrutOkForBinderSwap 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 True con [])+                DataAlt {} -> Just (ConVal True 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 scrutOkForBinderSwap+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 = foldr1WithDefault nullUsage combineUsage++lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc)+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},+    fromMaybe NoOcc . lookupVarEnv sc_occs <$> 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 occurrence 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 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, [SpecFailWarning]))   -- Specialise the scope of the binding+       -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])+scBind top_lvl env (NonRec bndr rhs) do_body+  | isTyVar bndr         -- Type-lets may be created by doBeta+  = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs)+       ; return (final_usage, [], body', warnings) }++  | 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, rhs_ws)  <- 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', warnings_body) <- do_body body_env3++          -- Now make specialised copies of the binding,+          -- based on calls in body_usg+        ; (spec_usg, specs, warnings_bnd) <- 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', mconcat [warnings_bnd, warnings_body, rhs_ws])+        }++  | 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', ws_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', body_warnings) <- do_body body_env++       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) }++scBind top_lvl env (Rec prs) do_body+  | isTopLevel top_lvl+  , Just threshold <- sc_size (sc_opts env)+  , not force_spec -- See Note [Forcing specialisation], point (FS1)+  , 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', warnings_body) <- do_body rhs_env2+        ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss+        ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)+                        `delCallsFor` bndrs'+              bind'   = Rec (bndrs' `zip` rhss')+        ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) }++  | otherwise+  = do  { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; let rhs_ws = mconcat rhs_wss+        ; (body_usg, body', warnings_body) <- do_body rhs_env2++        ; (spec_usg, specs, spec_ws) <- 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 ruleInfoBinds rhs_infos specs))+                        -- zipWithEqual: length of returned [SpecInfo]+                        -- should be the same as incoming [RhsInfo]++        ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) }+  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.+-}++withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings)+withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2)++------------------------+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)+        -- 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', ws) <- scExpr env e+                              return (usg, Tick (scTickish env t) e', ws)+scExpr' env (Cast e co)  = do (usg, e', ws) <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co), ws)+                              -- 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', ws) <- scExpr env' e+                              return (usg, Lam b' e', ws)++scExpr' env (Let bind body)+  = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $+                                         (\env -> scExpr env body)+       ; return (final_usage, mkLets binds' body', ws) }++scExpr' env (Case scrut b ty alts)+  = do  { (scrut_usg, scrut', ws) <- scExpr env scrut+        ; case isValue (sc_vals env) scrut' of+                Just (ConVal args_are_work_free con args)+                   | args_are_work_free -> sc_con_app con args scrut' ws+                     -- Don't duplicate work!!  #7865+                     -- See Note [ConVal work-free-ness] (1)+                _other -> sc_vanilla scrut_usg scrut' ws+        }+  where+    sc_con_app con args scrut' ws  -- Known constructor; simplify+     = do { let Alt _ bs rhs = findAlt con alts+                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)+          ; (use',expr',ws_new) <- scExpr alt_env' rhs+          ; return (use',expr',ws ++ ws_new) }++    sc_vanilla scrut_usg scrut' ws -- Normal case+     = do { let (alt_env,b') = extendBndrWith RecArg env b+                        -- Record RecArg for the components++          ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (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', ws ++ concat ws_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', ws) <- 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)+                                  -> ScrutOcc (unitUFM dc arg_occs)+                               _  -> UnkOcc+          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) }+++-- | Substitute the free variables captured by a breakpoint.+-- Variables are dropped if they have a non-variable substitution, like in+-- 'GHC.Opt.Specialise.specTickish'.+scTickish :: ScEnv -> CoreTickish -> CoreTickish+scTickish SCE {sc_subst = subst} = substTickish subst++{- 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, SpecFailWarnings)++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', arg_ws) = unzip3 args_w_usgs+              arg_usg = combineUsages arg_usgs+              arg_w = concat arg_ws+        ; case scSubstId env fn of+            fn'@(Lam {}) -> withWarnings arg_w <$> 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', arg_w )+               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', arg_w) }+                -- 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', fn_ws)   <- scExpr env other_fn+        ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) }++----------------------+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, SpecFailWarnings)+scRecRhs env (bndr,rhs)+  = do  { let (arg_bndrs,body)       = collectBinders rhs+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs+        ; (body_usg, body', body_ws)         <- 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 }, body_ws) }+                -- 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, [SpecFailWarning])       -- 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], SpecFailWarnings)+                                           -- 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+                 -> SpecFailWarnings -- Warnings so far+                 -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+    go n_iter seed_calls usg_so_far spec_infos ws_so_far+      = -- 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, extra_ws ) = unzip3 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 (ws_so_far ++ concat extra_ws) }++    -- go_again deals with termination+    go_again n_iter seed_calls usg_so_far spec_infos ws_so_far+      | isEmptyVarEnv seed_calls+      = return (usg_so_far, spec_infos, ws_so_far)++      -- 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+           -- See Note [Forcing specialisation], point (FS4) and (FS2)+      , 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, ws_so_far)++      | otherwise+      = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far++    -- 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, [SpecFailWarning])  -- 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, warnings)+             <- 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, new_wss) <- mapAndUnzip3M (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' }+                 ,warnings ++ concat new_wss) }++  | 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, SpecFailWarnings)   -- Rule and binding, warnings if any++-- 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, body_warnings) <- scExpr body_env body++                -- And build the results+        ; (qvars', pats') <- generaliseDictPats qvars pats+        ; let spec_body_ty = exprType spec_body+              (spec_lam_args, spec_call_args, spec_sig)+                  = calcSpecInfo fn arg_bndrs call_pat extra_bndrs++              spec_arity = count isId spec_lam_args+              spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args)+                              | otherwise   = NotJoinPoint+              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+        -- mkSeqs: see Note [SpecConstr and strict fields]+              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)+              rule_rhs = mkVarApps (Var spec_id) 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 }, body_warnings) }++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)++mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+-- See Note [SpecConstr and strict fields]+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)+               (localiseId arg_id)  -- See (SCF1) in Note [SpecConstr and strict fields]+               res_ty+               ([Alt DEFAULT [] rhs])++        | otherwise+        = rhs+++{- Note [SpecConstr void argument insertion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function+    f :: Bool -> forall t. blah+    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 :: forall t. blah+    $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!++More precisely, in `calcSpecInfo`+(i)  we need the void arg to /precede/ the `extra_bndrs`, but+(ii) it must still /follow/ `qvar_bndrs`.++Example to illustrate (ii):+  f :: forall r (a :: TYPE r). Bool -> a+  f = /\r. /\(a::TYPE r). \b. body++  {- Specialise for f _ _ True -}++  $sf :: forall r (a :: TYPE r). Void# -> a+  $sf = /\r. /\(a::TYPE r). \v. body[True/b]+  RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void#++The void argument must follow the foralls, lest the forall be+ill-kinded.  See Note [Worker/wrapper needs to add void arg last] in+GHC.Core.Opt.WorkWrap.Utils.++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+             -> [InVar]      -- Lambda binders of original RHS+             -> CallPat      -- Call pattern+             -> [Var]        -- Extra bndrs+             -> ( [Var]           -- Demand-decorated lambda binders+                                  --   for RHS of specialised function+                , [Var]           -- Args for call site+                , DmdSig )        -- Strictness of specialised thing+-- Calculate bits of IdInfo for the specialised function+-- See Note [Transfer strictness]+-- See Note [Strictness information in worker binders]+calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs+  = ( spec_lam_bndrs_w_dmds+    , spec_call_args+    , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) )+  where+    DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn+    spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b]++    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 arg_dmd_env.+    arg_dmd_env = go emptyVarEnv fn_dmds val_pats+    qvar_dmds  = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    extra_dmds = dropList val_pats fn_dmds++    -- Annotate the variables with the strictness information from+    -- the function (see Note [Strictness information in worker binders])+    qvars_w_dmds          = set_dmds qvars       qvar_dmds+    extras_w_dmds         = set_dmds extra_bndrs extra_dmds+    spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds++    (final_qvars_w_dmds, spec_call_args)+       | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs)+         -- Usual w/w hack to avoid generating+         -- a spec_rhs of unlifted or ill-kinded type and no args.+         -- See Note [SpecConstr void argument insertion]+       = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] )+       | otherwise+       = ( qvars_w_dmds,                qvars )++    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'++    go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand+    -- 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 :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand+    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 callToPat.++* 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 callToPat).  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 |> cv)) ...++where 'cv' is a coercion variable not in scope at f's definition site.+If we aren't careful we'll get++    let $sf a cv = e (K @(a |> cv))+        RULE "SC:f" forall a cv.  f (K @(a |> cv)) = $sf a co+        f = e+    in ...++But alas, when we match the call we may fail to bind 'co', because the rule+matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear+in casts (see Note [Casts in the template] in GHC.Core.Rules).++This seems intractable (see #23209). So:++* Key point: we /never/ quantify over coercion variables in a SpecConstr rule.+  If we would need to quantify over a coercion variable, we just discard the+  call pattern. See the test for `bad_covars` in callToPat.++* However (#14936) we /do/ still allow casts in call patterns. For example+     f ((e1,e2) |> sym co)+  where, say,+     f  :: Foo -> blah   -- Foo is a newtype+     f = f_rhs+     co :: Foo ~R (Int,Int)+  We want to specialise on that pair!++So for our function f, we might generate+  RULE forall x y.  f ((x,y) |> co) = $sf x y+  $sf x y = f_rhs ((x,y) |> co)++This works provided the free vars of `co` are either in-scope at the+definition of `f`, or quantified. For the latter, suppose `f` was polymorphic:++     f2  :: Foo2 a -> blah   -- Foo is a newtype+     f2 = f2_rhs+     co2 :: Foo a ~R (a,a)++Then it's fine for `co2` to mention `a`.  We'll get+  RULE forall a (x::a) (y::a).  f2 @a ((x,y) |> co2) = $sf2 a x y+  $sf2 @a x y = f2_rhs ((x,y) |> co2)+-}++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 and strict fields]++     -- 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 ])++newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name }++type SpecFailWarnings = [SpecFailWarning]++instance Outputable SpecFailWarning where+  ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name++combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings+combineSpecWarning = (++)++data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name++callsToNewPats :: ScEnv -> Id+               -> SpecInfo+               -> [ArgOcc] -> [Call]+               -> UniqSM ( Bool        -- At least one boring call+                         , Bool        -- Patterns were discarded+                         , [CallPat]   -- Patterns to specialise+                         , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about)+                         )+-- 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 (callToPat env bndr_occs) calls++        ; let have_boring_call = any isNothing mb_pats++              good_pats :: [CallPat]+              good_pats = catMaybes mb_pats++              in_scope = substInScopeSet (sc_subst env)++              -- Remove patterns we have already done+              new_pats = filterOut is_done good_pats+              is_done p = any is_better done_specs+                 where+                   is_better done = betterPat in_scope (os_pat done) p++              -- Remove duplicates+              non_dups = subsumePats in_scope new_pats++              -- Remove ones that have too many worker variables+              (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups++              -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool+              too_many_worker_args (CP { cp_qvars = vars, cp_args = args })+                | sc_force env+                -- See (FS5) of Note [Forcing specialisation]+                = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars)+                    then WorkerSmallEnough+                    else WorkerTooLargeForced (idName fn)+                | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+                = WorkerSmallEnough+                | otherwise = WorkerTooLarge+                  -- 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 "good_pats:" <+> ppr good_pats+--                                        , text "new_pats:" <+> ppr new_pats+--                                        , text "non_dups:" <+> ppr non_dups+--                                        , text "small_pats:" <+> ppr small_pats+--                                        , text "done_specs:" <+> ppr (map os_pat done_specs)+--                                        , text "trimmed_pats:" <+> ppr trimmed_pats ])++        ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) }+          -- 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.+  where+    partitionByWorkerSize worker_size pats = go pats [] []+      where+        go [] small warnings = (small, warnings)+        go (p:ps) small warnings =+          case worker_size p of+            WorkerSmallEnough -> go ps (p:small) warnings+            WorkerTooLarge -> go ps small warnings+            WorkerTooLargeForced name -> go ps small (SpecFailForcedArgCount name : warnings)+++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+  | False <- sc_force env+  , Just max_specs <- mb_scc+  , let n_remaining = max_specs - done_spec_count+  , n_remaining < n_pats+  = emit_trace max_specs n_remaining $  -- Need to trim, so keep the best ones+    (True, take n_remaining sorted_pats)++  | otherwise+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)+    (False, pats)          -- No need to trim++  where+    n_pats         = length pats+    spec_count'    = n_pats + done_spec_count+    mb_scc         = sc_count $ sc_opts env++    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 max_specs n_remaining result+       | debugIsOn || sc_debug (sc_opts env)+         -- Suppress this scary message for ordinary users!  #5125+       = pprTrace "SpecConstr" msg result+       | otherwise+       = result+      where+        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) ]++callToPat :: 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+callToPat env bndr_occs call@(Call fn args con_env)+  = do  { let in_scope = substInScopeSet (sc_subst env)++        ; arg_triples <- 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_triples' | isJoinId fn     = arg_triples+                           | otherwise       = dropWhileEnd is_boring arg_triples+              is_boring (interesting, _,_)   = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_triples'+              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 in SpecConstr] at the top++              (qktvs, qids) = partition isTyVar qvars+              qvars'        = scopedSort qktvs ++ map sanitise qids+                -- 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 = filter isCoVar qids+        ; warnPprTrace (not (null bad_covars))+              "SpecConstr: bad covars"+              (ppr bad_covars $$ ppr call) $++          if interesting && null bad_covars+          then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats+                                    , cp_strict_args = concat cbv_ids }+--                  ; pprTraceM "callToPatOut" $+--                    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.++   -- Casts: see Note [SpecConstr and casts]+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+                return (interesting, Cast arg' co, strict_args) }+  where+    ty2 = coercionRKind co++  -- 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 _wf (DataAlt dc) args) <- isValue val_env arg+    -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2)+  , 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)+    -- See Note [Forcing specialisation], point (FS3)+  , 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+++{- 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+-}++{-      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+-}++  -- 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 True (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+  , Just rhs <- maybeUnfoldingTemplate unf  -- Succeds if isCheapUnfolding does+  = isValue env rhs   -- Can't use isEvaldUnfolding because+                      -- we want to consult the `env`+  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 (all exprIsWorkFree args) (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++betterPat :: InScopeSet -> CallPat -> CallPat -> Bool+-- pat1    f @a   (Just @a   (x::a))+--      is better than+-- pat2    f @Int (Just @Int (x::Int))+-- That is, we can instantiate pat1 to get pat2, using only type instantiate+-- See Note [Pattern duplicate elimination]+betterPat is (CP { cp_qvars = vs1, cp_args = as1 })+             (CP { cp_qvars = vs2, cp_args = as2 })+  | equalLength as1 as2+  = case matchExprs ise vs1 as1 as2 of+      Just (_, ms) -> all exprIsTrivial ms+      Nothing      -> False++  | otherwise -- We must handle patterns of unequal length separately (#24282)+  = False  -- For the pattern with more args, the last arg is "interesting"+           -- but the corresponding one on the other is "not interesting";+           -- So we can't get from one to the other with only exprIsTrivial+           -- instantiation.  Example nofib/spectral/ansi, function `loop`:+           --    P1: loop (I# x) (a : b)+           --    P2: loop (I# y)           -- Pattern eta-reduced+           -- Neither is better than the other, in the sense of betterPat+  where+    ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding)++subsumePats :: InScopeSet -> [CallPat] -> [CallPat]+-- Remove any patterns subsumed by others+-- See Note [Pattern duplicate elimination]+-- Other than deleting subsumed patterns, this operation is a no-op;+-- in particular it does not reverse the input.  It should not matter+-- but in #24282 it did; doing it this way keeps the existing behaviour.+subsumePats is pats = foldl add [] pats+  where+    add :: [CallPat] -> CallPat -> [CallPat]+    add []        ci                         = [ci]+    add (ci1:cis) ci2 | betterPat is ci1 ci2 = ci1 : cis+                      | betterPat is ci2 ci1 = ci2 : cis+                      | otherwise            = ci1 : add cis ci2++{-+Note [Pattern duplicate elimination]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider f :: (a,a) -> blah, and two calls+   f @Int  (x,y)+   f @Bool (p,q)++The danger is that we'll generate two *essentially identical* specialisations,+both for pairs, but with different types instantiating `a` (see #24229).++But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises+that argument.  So SpecConstr should never need to specialise f's polymorphic+type arguments.  Even with only one of these calls we should be able to+generalise to the `CallPat`++  cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]++Doing so isn't trivial, though.++For now we content ourselves with a simpler plan: eliminate a call pattern+if another pattern subsumes it; this is done by `subsumePats`.+For example here are two patterns++  cp_qvars = [a, r::a, s::a],  cp_args = [@a (r,s)]+  cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)]++The first can be instantiated to the second, /by instantiating types only/.+This subsumption relationship is checked by `betterPat`.  Note that if+we have++  cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]+  cp_qvars = [],              cp_args = [@Bool (True,False)]++the first does *not* subsume the second; the second is more specific.++In our initial example with `f @Int` and `f @Bool` neither subsumes the other,+so we will get two essentially-identical specialisations. Boo.  We rely on our+crude throttling mechanisms to stop this getting out of control -- with+polymorphic recursion we can generate an infinite number of specialisations.+Example is Data.Sequence.adjustTree, I think.+-}
+ GHC/Core/Opt/Specialise.hs view
@@ -0,0 +1,3736 @@+{-# LANGUAGE MultiWayIf #-}++{-+(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.DynFlags+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.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )+import GHC.Core.Predicate+import GHC.Core.Class( classMethods )+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, exprIsTopLevelBindable+                          , mkCast, exprType, exprIsHNF+                          , stripTicksTop, mkInScopeSetBndrs )+import GHC.Core.FVs+import GHC.Core.Opt.Arity( collectBindersPushingCo )++import GHC.Builtin.Types  ( unboxedUnitTy )++import GHC.Data.Maybe     ( 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+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Error++import GHC.Utils.Error ( mkMCDiagnostic )+import GHC.Utils.Monad    ( foldlM )+import GHC.Utils.Misc+import GHC.Utils.FV+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( partition )+import Data.List.NonEmpty ( NonEmpty (..) )+import GHC.Core.Subst (substTickish)+import GHC.Core.TyCon (tyConClass_maybe)+import GHC.Core.DataCon (dataConTyCon)++{-+************************************************************************+*                                                                      *+\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++Wrinkle (W1): If we specialise an imported Id M.foo, we make a /local/+binding $sfoo.  But specImports may further specialise $sfoo. So we end up+with RULES for both M.foo (imported) and $sfoo (local).  Rules for local+Ids should be attached to the Ids themselves (see GHC.HsToCore+Note [Attach rules to local ids]); so we must partition the rules and+attach the local rules.  That is done in specImports, via addRulesToId.++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.+-}++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 { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds+       ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls++             -- Make a Rec: see Note [Glom the bindings if imported functions are specialised]+             --+             -- wrapDictBinds: don't forget to wrap the specialized bindings with+             --   bindings for the needed dictionaries.+             --   See Note [Wrap bindings returned by specImports]+             --+             -- addRulesToId: see Wrinkle (W1) in Note [Specialising imported functions]+             --               c.f. GHC.HsToCore.addExportFlagsAndRules+       ; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules+             local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals+             final_binds+               | null spec_binds = wrapDictBinds dict_binds []+               | otherwise       = [Rec $ mapFst (addRulesToId local_rule_base) $+                                          flattenBinds                          $+                                          wrapDictBinds dict_binds              $+                                          spec_binds]++       ; return (rules_for_imps, final_binds)+    }++-- | Specialise a set of calls to imported bindings+spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope+                                 ---In-scope set includes the FloatedDictBinds+             -> [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+                                     ---In-scope set includes the FloatedDictBinds+            -> [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+--           [ text "function:" <+> ppr fn+--           , text "good calls:" <+> ppr good_calls+--           , text "existing rules:" <+> ppr (getRules rule_env fn)+--           , text "rhs:" <+> ppr rhs+--           , text "dict_binds:" <+> ppr dict_binds ])++       ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })+            <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs++       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]+             -- After the rules kick in, via fireRewriteRules, 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]+             -- Meanwhile, though, bring the binders into scope++             new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs+             new_env   = env { se_rules = rule_env `addLocalRules` rules1+                             , se_subst = new_subst }+                         `bringFloatedDictsIntoScope` dict_binds1++       -- Now specialise any cascaded calls+--       ; debugTraceMsg (text "specImport 2" <+> vcat+--           [ text "function:" <+> ppr fn+--           , text "rules1:" <+> ppr rules1+--           , text "spec_binds1" <+> ppr spec_binds1+--           , text "dict_binds1" <+> ppr dict_binds1+--           , text "new_calls" <+> ppr new_calls ])++       ; (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.+++************************************************************************+*                                                                      *+\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+       ; (fun_out, uds_fun)   <- specExpr env fun_in+       ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in+       ; let uds_app  = uds_fun `thenUDs` uds_args+             env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app+                -- zapSubst: we have now fully applied the substitution+                -- bringFloatedDictsIntoScope: some dicts may have floated out of+                -- args_in; they should be in scope for fireRewriteRules (#21689)++       -- Try firing rewrite rules+       -- See Note [Fire rules in the specialiser]+       ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out++       -- Make a call record, and return+       ; let uds_call = mkCallUDs env fun_out' args_out'+       ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) }++---------------- 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   -- Substitution is already zapped+                 -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr])+fireRewriteRules env (Var f) args+  | let rules = getRules (se_rules env) f+  , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules+  , let rest_args    = drop (ruleArity rule) args -- See Note [Extra args in the target]+        zapped_subst = se_subst env   -- Just needed for the InScopeSet+        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args)+                       -- simplOptExpr needed because lookupRule returns+                       --   (\x y. rhs) arg1 arg2+  , (fun', args') <- collectArgs expr'+  = fireRewriteRules env fun' 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 }) bp = substTickish subst bp++--------------+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]+    isDictTy (idType case_bndr)+  , 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 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 [tryRules: plan (BEFORE)]+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 [tryRules: plan (BEFORE)] in the Simplifier (partly) 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 = floatifyIdDemandInfo 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.+             -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels++             body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds+                                   `extendInScope` fn3+                                   -- bringFloatedDictsIntoScope: see #23567++       ; (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++             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)+             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]++       ; if float_all && can_float_this_one 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+             -- Bring into scope the binders from the floated dicts+             env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds)++       ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs+                                                    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+          -> [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 `alreadyCovered`++type SpecInfo = ( [CoreRule]       -- Specialisation rules+                , [(Id,CoreExpr)]  -- Specialised definition+                , UsageDetails )   -- Usage details from specialised RHSs++specCalls spec_imp env 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" (vcat+    --  [ text "function" <+> ppr fn+    --  , text "calls:" <+> ppr calls_for_me+    --  , text "subst" <+> ppr (se_subst env) ]) $+    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)+          "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $+          -- 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_active = isActive (beginPhase inl_act) :: Activation -> Bool+         -- is_active: 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.+    is_local  = isLocalId fn+    is_dfun   = isDFunId fn+    dflags    = se_dflags env+    this_mod  = se_module env+    subst     = se_subst env+    in_scope  = Core.substInScopeSet subst+        -- 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]++    -- Copy InlinePragma information from the parent Id.+    -- So if f has INLINE[1] so does spec_fn+    spec_inl_prag+      | not is_local     -- See Note [Specialising imported functions]+      , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal+      = neverInlinePragma+      | otherwise+      = inl_prag++    not_in_scope :: InterestingVarFun+    not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)++    ----------------------------------------------------------+        -- 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++             -- 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 poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args+                 subst'     = subst `Core.extendSubstInScopeList` poly_qvars+                              -- Maybe we should clone the poly_qvars telescope?++             -- Any free Ids will have caused the call to be dropped+           ; massertPpr (all isTyCoVar poly_qvars)+                        (ppr fn $$ ppr all_call_args $$ ppr poly_qvars)++           ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args)+                 <- specHeader subst' rhs_bndrs all_call_args+           ; let all_rule_bndrs = poly_qvars ++ rule_bndrs+                 env' = env { se_subst = subst'' }++           -- Check for (a) usefulness and (b) not already covered+           -- See (SC1) in Note [Specialisations already covered]+           ; let all_rules = rules_acc ++ existing_rules+                 -- all_rules: we look both in the rules_acc (generated by this invocation+                 --   of specCalls), and in existing_rules (passed in to specCalls)+                 already_covered = alreadyCovered env' all_rule_bndrs fn+                                                  rule_lhs_args is_active all_rules++{-         ; pprTrace "spec_call" (vcat+                [ text "fun:       "  <+> ppr fn+                , text "call info: "  <+> ppr _ci+                , text "useful:    "  <+> ppr useful+                , text "already_covered:"  <+> ppr already_covered+                , text "poly_qvars: " <+> ppr poly_qvars+                , text "useful:    "  <+> ppr useful+                , text "all_rule_bndrs:"  <+> ppr all_rule_bndrs+                , text "rule_lhs_args:"  <+> ppr rule_lhs_args+                , text "spec_bndrs:" <+> ppr spec_bndrs+                , text "dx_binds:"   <+> ppr dx_binds+                , text "spec_args: "  <+> ppr spec_args+                , text "rhs_bndrs"    <+> ppr rhs_bndrs+                , text "rhs_body"     <+> ppr rhs_body+                , text "subst''" <+> ppr subst'' ]) $+             return ()+-}++           ; if not useful          -- No useful specialisation+                || already_covered  -- Useful, but done already+             then return spec_acc+             else++        -- Not useless, not already covered: make a specialised binding+        do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs+                 (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs++             -- Run the specialiser on the specialised RHS+           ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body++{-         ; pprTrace "spec_call2" (vcat+                 [ text "fun:" <+> ppr fn+                 , text "rhs_body':" <+> ppr rhs_body' ]) $+             return ()+-}++           -- Make the RHS of the specialised function+           ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'+                 (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds+                 (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1)+                 -- dx_binds comes from the arguments to the call, and so can mention+                 -- poly_qvars but no other local binders+                 spec_rhs = mkLams poly_qvars               $+                            wrapDictBindsE outer_dumped_dbs $+                            mkLams spec_rhs_bndrs           $+                            wrapDictBindsE inner_dumped_dbs rhs_body'+                 rule_rhs_args = poly_qvars ++ spec_bndrs++                 -- 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++                 spec_fn_ty = exprType spec_rhs+                 add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn)+                 (rule_rhs_args1, spec_rhs1, spec_fn_ty1)+                   | add_void_arg = ( voidPrimId : rule_rhs_args+                                    , Lam voidArgId spec_rhs+                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty )+                   | otherwise    = (rule_rhs_args, spec_rhs, spec_fn_ty)++                 --------------------------------------+                 -- 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)+                 simpl_opts = initSimpleOpts dflags+                 wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds+                 spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body+                                          rule_lhs_args fn_unf++                 --------------------------------------+                 -- Adding arity information just propagates it a bit faster+                 --      See Note [Arity decrease] in GHC.Core.Opt.Simplify+                 join_arity_decr = length rule_lhs_args         - length rule_rhs_args1+                 arity_decr      = count isValArg rule_lhs_args - count isId rule_rhs_args1++                 spec_fn_info+                   = vanillaIdInfo `setArityInfo`      max 0 (fn_arity - arity_decr)+                                   `setInlinePragInfo` spec_inl_prag+                                   `setUnfoldingInfo`  spec_unf++                 -- Compute the IdDetails of the specialise Id+                 -- See Note [Transfer IdDetails during specialisation]+                 spec_fn_details+                   = case idDetails fn of+                       JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing+                       DFunId unary        -> DFunId unary+                       _                   -> VanillaId++           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info+           ; 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 all_rule_bndrs rule_lhs_args+                                    (mkVarApps (Var spec_fn) rule_rhs_args1)++                _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type+                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty1+                                       , ppr rhs_bndrs, ppr call_args+                                       , ppr spec_rule+                                       , text "acc" <+> ppr rules_acc+                                       , text "existing" <+> ppr existing_rules+                                       ]++           ; -- pprTrace "spec_call: rule" _rule_trace_doc+             return ( spec_rule            : rules_acc+                    , (spec_fn, spec_rhs1) : pairs_acc+                    , rhs_uds2 `thenUDs` uds_acc+                    ) } }++alreadyCovered :: SpecEnv+               -> [Var] -> Id -> [CoreExpr]   -- LHS of possible new rule+               -> (Activation -> Bool)        -- Which rules are active+               -> [CoreRule] -> Bool+-- Note [Specialisations already covered] esp (SC2)+alreadyCovered env bndrs fn args is_active rules+  = case specLookupRule env fn args is_active rules of+      Nothing             -> False+      Just (rule, _)+        | isAutoRule rule -> -- Discard identical rules+                             -- We know that (fn args) is an instance of RULE+                             -- Check if RULE is an instance of (fn args)+                             ruleLhsIsMoreSpecific in_scope bndrs args rule+        | otherwise       -> True  -- User rules dominate+  where+    in_scope = substInScopeSet (se_subst env)++-- Convenience function for invoking lookupRule from Specialise+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]+specLookupRule :: HasDebugCallStack+               => SpecEnv -> Id -> [CoreExpr]+               -> (Activation -> Bool)  -- Which rules are active+               -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+specLookupRule env fn args is_active rules+  | null rules+  = Nothing    -- Saves building a few thunks in the common case+  | otherwise+  = lookupRule ropts in_scope_env is_active fn args rules+  where+    dflags       = se_dflags env+    in_scope     = substInScopeSet (se_subst env)+    in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)+    ropts        = initRuleOpts dflags++{- Note [Specialising DFuns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DFuns have a special sort of unfolding (DFunUnfolding), and it is+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 [Transfer IdDetails during specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, `newSpecIdSM` comes up with a fresh Id the+specialised RHS will be bound to. It is critical that we get the `IdDetails` of+the specialised Id correct:++* JoinId: We want the specialised Id to be a join point, too.  But+  we have to carefully adjust the arity++* DFunId: It is crucial that we also make the new Id a DFunId.+  - First, because it obviously /is/ a DFun, having a DFunUnfolding and+    all that; see Note [Specialising DFuns]++  - Second, DFuns get very delicate special treatment in the demand analyser;+    see GHC.Core.Opt.DmdAnal.enterDFun.  If the specialised function isn't+    also a DFunId, this special treatment doesn't happen, so the demand+    analyser makes a too-strict DFun, and we get an infinite loop.  See Note+    [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.+    #22549 describes the loop, and (lower down) a case where a /specialised/+    DFun caused a loop.++* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come+  up when specialising imports. We must keep them as VanillaIds because WW+  will detect them as WorkerLikeIds again. That is, unless specialisation+  allows unboxing of all previous CBV args, in which case sticking to+  VanillaIds was the only correct choice to begin with.++* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:+  Never specialised.++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 [Care with unlifted bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22998)+    f x = let x::ByteArray# = <some literal>+              n::Natural    = NB x+          in wombat @192827 (n |> co)+where+  co :: Natural ~ KnownNat 192827+  wombat :: forall (n:Nat). KnownNat n => blah++Left to itself, the specialiser would float the bindings for `x` and `n` to top+level, so we can specialise `wombat`.  But we can't have a top-level ByteArray#+(see Note [Core letrec invariant] in GHC.Core).  Boo.++This is pretty exotic, so we take a simple way out: in specBind (the NonRec+case) do not float the binding itself unless it satisfies exprIsTopLevelBindable.+This is conservative: maybe the RHS of `x` has a free var that would stop it+floating to top level anyway; but that is hard to spot (since we don't know what+the non-top-level in-scope binders are) and rare (since the binding must satisfy+Note [Core let-can-float invariant] in GHC.Core).+++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 @T1 @T2 @T3 7 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+where that `g` is really (Coercion (CoVar g)), since `g` is a+coercion variable and can't appear as (Var g).++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 (Coercion 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.  Wrinkles++(SC1) 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++(SC2) What about two specialisations where the second is an *instance*+   of the first?  It's a bit arbitrary, but here's what we do:+   * If the existing one is user-specified, via a SPECIALISE pragma, we+     suppress the further specialisation.+   * If the existing one is auto-generated, we generate a second RULE+     for the more specialised version.+   The latter is important because we don't want the accidental order+   of calls to determine what specialisations we generate.++(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`.+   See (MP3) in Note [Specialising polymorphic dictionaries]++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 (SpecDict d)  = text "SpecDict" <+> ppr d+  ppr UnspecType    = text "UnspecType"+  ppr UnspecArg     = text "UnspecArg"++specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV+-- Find the free vars of the SpecArgs that are not already in scope+specArgsFVs interesting args+  = filterFV interesting $+    foldr (unionFV . get) emptyFV args+  where+    get :: SpecArg -> FV+    get (SpecType ty)   = tyCoFVsOfType ty+    get (SpecDict dx)   = exprFVs dx+    get UnspecType      = emptyFV+    get UnspecArg       = emptyFV++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+     :: Core.Subst  -- This substitution applies to the [InBndr]+     -> [InBndr]    -- 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++              , Core.Subst   -- Apply this to the body++                -- RULE helpers+                -- `RULE forall rule_bndrs. f rule_es = $sf spec_bndrs`+              , [OutBndr]    -- rule_bndrs: Binders for the RULE+              , [OutExpr]    -- rule_es:    Args for the LHS of the rule++                -- Specialised function helpers+                -- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`+              , [OutBndr]    -- spec_bndrs: Binders for $sf, and args for the RHS+                             --             of the RULE. Subset of rule_bndrs.+              , [DictBind]   -- dx_binds:   Auxiliary dictionary bindings+              , [OutExpr]    -- spec_args:  Specialised arguments for unfolding+                             --             Same length as "Args for LHS of rule"+              )++-- If we run out of binders, stop immediately+-- See Note [Specialisation Must Preserve Sharing]+specHeader subst [] _  = pure (False, subst, [], [], [], [], [])+specHeader subst _  [] = pure (False, subst, [], [], [], [], [])++-- 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 subst (bndr:bndrs) (SpecType ty : args)+  = do { let subst1 = Core.extendTvSubst subst bndr ty+       ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , rule_bs,     Type ty : rule_args+              , spec_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 subst (bndr:bndrs) (UnspecType : args)+  = do { let (subst1, bndr') = Core.substBndr subst bndr+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; let ty_e' = Type (mkTyVarTy bndr')+       ; pure ( useful, subst2+              , bndr' : rule_bs,     ty_e' : rule_es+              , bndr' : spec_bs, dx, ty_e' : spec_args ) }++specHeader subst (bndr:bndrs) (_ : args)+  | isDeadBinder bndr+  , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+  , Just rubbish_lit <- mkLitRubbish (idType bndr')+  = -- See Note [Drop dead args from specialisations]+    do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , bndr' : rule_bs, Var bndr'   : rule_es+              , spec_bs,     dx, rubbish_lit : 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 subst (bndr:bndrs) (SpecDict dict_arg : args)+  = do { -- Make up a fresh binder to use in the RULE+         -- It might turn into a dict binding (via bindAuxiliaryDict) which we+         -- then float, so we use cloneIdBndr to get a completely fresh binder+         us <- getUniqueSupplyM+       ; let (subst1, bndr') = Core.cloneIdBndr subst us (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders]++         -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS+       ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg++       ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args++       ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx }+       ; pure ( True, subst3      -- Ha!  A useful specialisation!+              , bndr' : rule_bs, Var bndr' : rule_es+              , spec_bs,    dx', spec_dict : spec_args ) }++-- Finally, we don't want to specialise on this argument 'i':+-- 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 subst (bndr:bndrs) (UnspecArg : args)+  = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders]+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args++       ; let dummy_arg = varToCoreExpr bndr'+               -- dummy_arg is usually just (Var bndr),+               -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr))+               --     or even Coercion Refl (if t1=t2)+               -- See Note [Evidence foralls]+             bndrs = exprFreeIdsList dummy_arg++       ; pure ( useful, subst2+              , bndrs ++ rule_bs,     dummy_arg : rule_es+              , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) }+++-- | Binds a dictionary argument to a fresh name, to preserve sharing+bindAuxiliaryDict+  :: Subst+  -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression+  -> ( Subst          -- Substitutes for orig_dict_id+     , Maybe DictBind -- Auxiliary dict binding, if any+     , OutExpr)       -- Witnessing expression (always trivial)+bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg++  -- If the dictionary argument is trivial,+  -- don’t bother creating a new dict binding; just substitute+  | exprIsTrivial dict_arg+  , let subst' = Core.extendSubst subst orig_dict_id dict_arg+  = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $+    (subst', Nothing, dict_arg)++  | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding+  , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg++        dict_bind = mkDB (NonRec fresh_dict_id' dict_arg)+        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+  = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $+    (subst', 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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note June 2023: This has proved to be quite a tricky optimisation to get right+see (#23469, #23109, #21229, #23445) so it is now guarded by a flag+`-fpolymorphic-specialisation`.++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)      (d1 :: Monoid (Endo b))+        (f @(Endo (c->c)) (d2 :: 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 use of `removeDupCalls` in `filterCalls`.++      You might wonder if `d2` might be more specialised than `d1`; but no.+      This `removeDupCalls` thing is at the definition site of `f`, and both `d1`+      and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but+      is just as specialised.++      This distinction is sadly lost once we build a RULE, so `alreadyCovered`+      can't be so clever.  E.g if we have an existing RULE+            forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ...+      and a putative new rule+            forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ...+      we /don't/ want the existing rule to subsume the new one.++      So we sadly put up with having two rather different places where we+      eliminate duplicates: `alreadyCovered` and `removeDupCalls`.++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.++* See Note [Weird special case for SpecDict]++* 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].++Note [Weird special case for SpecDict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to specialise for this this call:+   $wsplit @T (mkD @k @(a::k) :: C T)+where+   mkD :: forall k (a::k). C T+is a top-level dictionary-former.  This actually happened in #22459,+because of (MP1) of Note [Specialising polymorphic dictionaries].++How can we specialise $wsplit?  We might try++   RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit++but then in the body of $s$wsplit what will we use for the dictionary+evidence?  We can't use (mkD @k @(a::k)) because k and a aren't in scope.+We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that+is a lot of hard work for a very strange case.++So we simply refrain from specialising in this case; hence the guard+   allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)+in the SpecDict cased of specHeader.++How did this strange polymorphic mkD arise in the first place?+From GHC.Core.Opt.Utils.abstractFloats, which was abstracting+over too many type variables. But that too is now fixed;+see Note [Which type variables to abstract over] in that module.+-}++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 alreadyCovered in specCalls++data CallInfo+  = CI { ci_key  :: [SpecArg]   -- Arguments of the call+                                -- See Note [The (CI-KEY) invariant]++       , 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]+    }++{- Note [The (CI-KEY) invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant (CI-KEY):+   In the `ci_key :: [SpecArg]` field of `CallInfo`,+     * The list is non-empty+     * The least element is always a `SpecDict`++In this way the RULE has as few args as possible, which broadens its+applicability, since rules only fire when saturated.+-}++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 :: SpecEnv -> Id -> [SpecArg] -> UsageDetails+singleCall spec_env id args+  = MkUD {ud_binds = emptyFDBs,+          ud_calls = unitDVarEnv id $ CIS id $+                     unitBag (CI { ci_key  = args+                                 , ci_fvs  = fvVarSet call_fvs }) }+  where+    poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)++    -- With -fpolymorphic-specialisation, keep just local /Ids/+    -- Otherwise, keep /all/ free vars including TyVars+    -- See (MP1) in Note [Specialising polymorphic dictionaries]+    -- But NB: we don't include the 'id' itself.+    call_fvs | poly_spec = specArgsFVs isLocalId args+             | otherwise = specArgsFVs isLocalVar args++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 env 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+             -- Establish (CI-KEY): drop trailing args until we get to a SpecDict++    mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg+    mk_spec_arg (Type ty) (Named bndr)+      |  binderVar bndr `elemVarSet` constrained_tyvars+      = SpecType ty+      | otherwise+      = UnspecType+    mk_spec_arg non_type_arg (Named bndr)+      = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr)++    -- 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 env arg+              -- See Note [Interesting dictionary arguments]+      = SpecDict arg++      | otherwise = UnspecArg++wantCallsFor :: SpecEnv -> Id -> Bool+-- See Note [wantCallsFor]+wantCallsFor _env f+  = case idDetails f of+      RecSelId {}      -> False+      DataConWorkId {} -> False+      DataConWrapId {} -> False+      ClassOpId {}     -> False+      PrimOpId {}      -> False+      FCallId {}       -> False+      TickBoxOpId {}   -> False+      CoVarId {}       -> False++      DFunId {}        -> True+      VanillaId {}     -> True+      JoinId {}        -> True+      WorkerLikeId {}  -> True+      RepPolyId {}     -> True++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- This is a subtle and important function+-- See Note [Interesting dictionary arguments]+interestingDict env (Var v)  -- See (ID3) and (ID5)+  | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)+  -- Might fail for loop breaker dicts but that seems fine.+  = interestingDict env rhs++interestingDict env arg  -- Main Plan: use exprIsConApp_maybe+  | Cast inner_arg _ <- arg  -- See (ID5)+  = if | isConstraintKind $ typeKind $ exprType inner_arg+       -- If coercions were always homo-kinded, we'd know+       -- that this would be the only case+       -> interestingDict env inner_arg++       -- Check for an implicit parameter at the top+       | Just (cls,_) <- getClassPredTys_maybe arg_ty+       , isIPClass cls      -- See (ID5)+       -> False++       -- Otherwise we are unwrapping a unary type class+       | otherwise+       -> exprIsHNF arg   -- See (ID7)++  | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg+  , Just cls <- tyConClass_maybe (dataConTyCon data_con)+  , definitely_not_ip_like       -- See (ID4)+  = if null (classMethods cls)   -- See (ID6)+    then any (interestingDict env) args+    else True++  | otherwise+  = not (exprIsTrivial arg) && definitely_not_ip_like  -- See (ID8)+  where+    arg_ty                  = exprType arg+    definitely_not_ip_like  = not (couldBeIPLike arg_ty)+    in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding++{- 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).++Note [wantCallsFor]+~~~~~~~~~~~~~~~~~~~+`wantCallsFor env f` says whether the Specialiser should collect calls for+function `f`; other thing being equal, the fewer calls we collect the better. It+is False for things we can't specialise:++* ClassOpId: never inline and we don't have a defn to specialise; we specialise+  them through fireRewriteRules.+* PrimOpId: are never overloaded+* Data constructors: we never specialise them++We could reduce the size of the UsageDetails by being less eager about+collecting calls for some 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"?  Our Main Plan is to use `exprIsConApp_maybe` to see+if the argument is a dictionary constructor applied to some arguments, in which+case we can clearly specialise. But there are wrinkles:++(ID1) Note that we look at the argument /term/, not its /type/.  Suppose the+  argument is+         (% d1, d2 %) |> co+  where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.+  Then its type (F Int a) looks very un-informative, but the term is super+  helpful.  See #19747 (where missing this point caused a 70x slow down)+  and #7785.++(ID2) Note that the Main Plan works fine for an argument that is a DFun call,+   e.g.    $fOrdList $dOrdInt+   because `exprIsConApp_maybe` cleverly deals with DFunId applications.  Good!++(ID3) For 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.++(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains+   an implicit parameter, because implicit parameters are emphatically not singleton+   types.  See #25999:+     useImplicit :: (?i :: Int) => Int+     useImplicit = ?i + 1++     foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)+   Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.+   We must not specialise on implicit parameters!  Hence the call to `couldBeIPLike`+   in `definitely_not_ip_like`.++(ID5) Suppose the argument is (e |> co).  Can we rely on `exprIsConApp_maybe` to deal+   with the coercion.  No!  That only works if (co :: C t1 ~ C t2) with the same type+   constructor at the top of both sides.  But see the example in (ID1), where that+   is not true.  For the same reason, we can't rely on `exprIsConApp_maybe` to look+   through unfoldings (because there might be a cast inside), hence dealing with+   expandable unfoldings in `interestingDict` directly.++   For the same reasons as in (ID4), we must take care to not allow an implicit+   parameter to sneak through, so we must not unwrap the newtype cast for the+   unary IP class; hence the `isIPClass` call.  (We don't need to call+   `couldBeIPLike`, as implicit parameters hidden behind a type family are+   detected by the recursive call to `interestingDict` on the argument inside the+   cast.)++(ID6) The Main Plan says that it's worth specialising if the argument is an application+   of a dictionary contructor.  But what if the dictionary has no methods?  Then we+   gain nothing by specialising, unless the /superclasses/ are interesting.   A case+   in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class+   with N superclasses and no methods.++(ID7) A unary (single-method) class is currently represented by (meth |> co).  We+   will unwrap the cast (see (ID5)) and then want to reply "yes" if the method+   has any struture.  We rather arbitrarily use `exprIsHNF` for this.  (We plan a+   new story for unary classes, see #23109, and this special case will become+   irrelevant.)++(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a+   non-trivial argument as interesting. In T19695 we have this:+      askParams :: Monad m => blah+      mhelper   :: MonadIO m => blah+      mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....+   where `$p1` is the superclass selector for `MonadIO`.  Now, if `mhelper` is+   specialised at `Handler` we'll get this call in the specialised `$smhelper`:+            askParams @Handler ($p1 $fMonadIOHandler)+   and we /definitely/ want to specialise that, even though the argument isn't+   visibly a dictionary application.  In fact the specialiser fires the superclass+   selector rule (see Note [Fire rules in the specialiser]), so we get+            askParams @Handler ($cp1MonadIO $fMonadIOIO)+   but it /still/ doesn't look like a dictionary application.++   Conclusion: we optimistically assume that any non-trivial argument is worth+   specialising on.++   So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look+   under type-family casts (ID1) and constraint tuples (ID6).++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+fire (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.)+-}++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" (vcat+                 --    [ text "bndrs" <+> ppr bndrs+                 --    , text "uds" <+> ppr uds+                 --    , text "free_uds" <+> ppr free_uds+                 --    , text "dump-dbs" <+> 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 :: CallInfoSet -> FloatedDictBinds -> [CallInfo]+-- Remove+--   (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries]+--   (b) loopy DFuns: Note [Avoiding loops (DFuns)]+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })+  | isDFunId fn  = filter ok_call de_dupd_calls  -- Deals with (b)+  | otherwise    = de_dupd_calls+  where+    de_dupd_calls = removeDupCalls call_bag -- Deals with (a)++    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++removeDupCalls :: Bag CallInfo -> [CallInfo]+-- Calls involving more generic instances beat more specific ones.+-- See (MP3) in Note [Specialising polymorphic dictionaries]+removeDupCalls 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 ci1 ci2) is True if specialising on ci1 subsumes ci2+-- That is: ci1's types are less specialised than ci2+--          ci1   specialises on the same dict args as ci2+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++    -- If one or the other runs dry, the other must still have a SpecDict+    -- because of the (CI-KEY) invariant.  So neither subsumes the other;+    -- one is more specialised (faster code) but the other is more generally+    -- applicable.+    go  _ _ = False++    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)+    go_arg (SpecDict {})  (SpecDict {})  = True+    go_arg UnspecType     UnspecType     = 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 :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f 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 { (subst', bndrs') <- Core.cloneRecIdBndrsM subst bndrs+       ; let env' = env { se_subst = subst' }+       ; return (env', bndrs') }++newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id+    -- Give the new Id a similar occurrence name to the old one+newSpecIdSM old_name new_ty details info+  = do  { uniq <- getUniqueM+        ; let new_occ  = mkSpecOcc (nameOccName old_name)+              new_name = mkInternalName uniq new_occ  (getSrcSpan old_name)+        ; return (assert (not (isCoVarType new_ty)) $+                  mkLocalVar details new_name ManyTy new_ty info) }++{-+                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.+-}
+ GHC/Core/Opt/StaticArgs.hs view
@@ -0,0 +1,437 @@+++{-+(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 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
+ GHC/Core/Opt/Stats.hs view
@@ -0,0 +1,337 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++-}++{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.Opt.Stats (+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,+    pprSimplCount, plusSimplCount, zeroSimplCount,+    isZeroSimplCount, hasDetailedCounts, Tick(..)+  ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Error++import GHC.Utils.Outputable as Outputable++import GHC.Data.FastString++import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Ord+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import GHC.Utils.Panic (throwGhcException, GhcException(..))++getVerboseSimplStats :: (Bool -> SDoc) -> SDoc+getVerboseSimplStats = getPprDebug          -- For now, anyway++zeroSimplCount     :: Bool -- ^ -ddump-simpl-stats+                   -> SimplCount+isZeroSimplCount   :: SimplCount -> Bool+hasDetailedCounts  :: SimplCount -> Bool+pprSimplCount      :: SimplCount -> SDoc+doSimplTick        :: Int -- ^ History size of the elaborate counter+                   -> Tick -> SimplCount -> SimplCount+doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount+plusSimplCount     :: SimplCount -> SimplCount -> SimplCount++data SimplCount+   = VerySimplCount !Int        -- Used when don't want detailed stats++   | SimplCount {+        ticks   :: !Int,        -- Total ticks+        details :: !TickCounts, -- How many of each type++        n_log   :: !Int,        -- N+        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,+                                --   most recent first+        log2    :: [Tick]       -- Last opt_HistorySize events before that+                                -- Having log1, log2 lets us accumulate the+                                -- recent history reasonably efficiently+     }++type TickCounts = Map Tick Int++simplCountN :: SimplCount -> Int+simplCountN (VerySimplCount n)         = n+simplCountN (SimplCount { ticks = n }) = n++zeroSimplCount dump_simpl_stats+                -- This is where we decide whether to do+                -- the VerySimpl version or the full-stats version+  | dump_simpl_stats+  = SimplCount {ticks = 0, details = Map.empty,+                n_log = 0, log1 = [], log2 = []}+  | otherwise+  = VerySimplCount 0++isZeroSimplCount (VerySimplCount n)         = n==0+isZeroSimplCount (SimplCount { ticks = n }) = n==0++hasDetailedCounts (VerySimplCount {}) = False+hasDetailedCounts (SimplCount {})     = True++doFreeSimplTick tick sc@SimplCount { details = dts }+  = sc { details = dts `addTick` tick }+doFreeSimplTick _ sc = sc++doSimplTick history_size tick+    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })+  | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 }+  | otherwise          = sc1 { n_log = nl+1, log1 = tick : l1 }+  where+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }++doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)+++addTick :: TickCounts -> Tick -> TickCounts+addTick fm tick = MapStrict.insertWith (+) tick 1 fm++plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })+               sc2@(SimplCount { ticks = tks2, details = dts2 })+  = log_base { ticks = tks1 + tks2+             , details = MapStrict.unionWith (+) dts1 dts2 }+  where+        -- A hackish way of getting recent log info+    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2+             | null (log2 sc2) = sc2 { log2 = log1 sc1 }+             | otherwise       = sc2++plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)+plusSimplCount lhs                rhs                =+  throwGhcException . PprProgramError "plusSimplCount" $ vcat+    [ text "lhs"+    , pprSimplCount lhs+    , text "rhs"+    , pprSimplCount rhs+    ]+       -- We use one or the other consistently++pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })+  = vcat [text "Total ticks:    " <+> int tks,+          blankLine,+          pprTickCounts dts,+          getVerboseSimplStats $ \dbg -> if dbg+          then+                vcat [blankLine,+                      text "Log (most recent first)",+                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]+          else Outputable.empty+    ]++{- Note [Which transformations are innocuous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point (Jun 18) I wondered if some transformations (ticks)+might be  "innocuous", in the sense that they do not unlock a later+transformation that does not occur in the same pass.  If so, we could+refrain from bumping the overall tick-count for such innocuous+transformations, and perhaps terminate the simplifier one pass+earlier.++But alas I found that virtually nothing was innocuous!  This Note+just records what I learned, in case anyone wants to try again.++These transformations are not innocuous:++*** NB: I think these ones could be made innocuous+          EtaExpansion+          LetFloatFromLet++LetFloatFromLet+    x = K (let z = e2 in Just z)+  prepareRhs transforms to+    x2 = let z=e2 in Just z+    x  = K xs+  And now more let-floating can happen in the+  next pass, on x2++PreInlineUnconditionally+  Example in spectral/cichelli/Auxil+     hinsert = ...let lo = e in+                  let j = ...lo... in+                  case x of+                    False -> ()+                    True -> case lo of I# lo' ->+                              ...j...+  When we PreInlineUnconditionally j, lo's occ-info changes to once,+  so it can be PreInlineUnconditionally in the next pass, and a+  cascade of further things can happen.++PostInlineUnconditionally+  let x = e in+  let y = ...x.. in+  case .. of { A -> ...x...y...+               B -> ...x...y... }+  Current postinlineUnconditinaly will inline y, and then x; sigh.++  But PostInlineUnconditionally might also unlock subsequent+  transformations for the same reason as PreInlineUnconditionally,+  so it's probably not innocuous anyway.++  One annoying variant is this.  CaseMerge introduces auxiliary bindings+     let b = b' in ...+  This takes another full run of the simplifier to elimiante.  But if+  the PostInlineUnconditionally, replacing b with b', is the only thing+  that happens in a Simplifier run, that probably really is innocuous.+  Perhaps an opportunity here.++KnownBranch, BetaReduction:+  May drop chunks of code, and thereby enable PreInlineUnconditionally+  for some let-binding which now occurs once++EtaExpansion:+  Example in imaginary/digits-of-e1+    fail = \void. e          where e :: IO ()+  --> etaExpandRhs+    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())+  --> Next iteration of simplify+    fail1 = \void. \s. (e |> g) s+    fail = fail1 |> Void# -> sym g+  And now inline 'fail'++CaseMerge:+  case x of y {+    DEFAULT -> case y of z { pi -> ei }+    alts2 }+  ---> CaseMerge+    case x of { pi -> let z = y in ei+              ; alts2 }+  The "let z=y" case-binder-swap gets dealt with in the next pass+-}++pprTickCounts :: Map Tick Int -> SDoc+pprTickCounts counts+  = vcat (map pprTickGroup groups)+  where+    groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag+                                     -- toList returns common tags adjacent+    groups = NE.groupWith (tickToTag . fst) (Map.toList counts)++pprTickGroup :: NonEmpty (Tick, Int) -> SDoc+pprTickGroup group@((tick1,_) :| _)+  = hang (int (sum (fmap snd group)) <+> pprTickType tick1)+       2 (vcat [ int n <+> pprTickCts tick+                                    -- flip as we want largest first+               | (tick,n) <- sortOn (Down . snd) (NE.toList group)])++data Tick  -- See Note [Which transformations are innocuous]+  = PreInlineUnconditionally    Id+  | PostInlineUnconditionally   Id++  | UnfoldingDone               Id+  | RuleFired                   FastString      -- Rule name++  | LetFloatFromLet+  | EtaExpansion                Id      -- LHS binder+  | EtaReduction                Id      -- Binder on outer lambda+  | BetaReduction               Id      -- Lambda binder+++  | CaseOfCase                  Id      -- Bndr on *inner* case+  | KnownBranch                 Id      -- Case binder+  | CaseMerge                   Id      -- Binder on outer case+  | AltMerge                    Id      -- Case binder+  | CaseElim                    Id      -- Case binder+  | CaseIdentity                Id      -- Case binder+  | FillInCaseDefault           Id      -- Case binder++  | SimplifierDone              -- Ticked at each iteration of the simplifier++instance Outputable Tick where+  ppr tick = pprTickType tick <+> pprTickCts tick++instance Eq Tick where+  a == b = case a `cmpTick` b of+           EQ -> True+           _ -> False++instance Ord Tick where+  compare = cmpTick++tickToTag :: Tick -> Int+tickToTag (PreInlineUnconditionally _)  = 0+tickToTag (PostInlineUnconditionally _) = 1+tickToTag (UnfoldingDone _)             = 2+tickToTag (RuleFired _)                 = 3+tickToTag LetFloatFromLet               = 4+tickToTag (EtaExpansion _)              = 5+tickToTag (EtaReduction _)              = 6+tickToTag (BetaReduction _)             = 7+tickToTag (CaseOfCase _)                = 8+tickToTag (KnownBranch _)               = 9+tickToTag (CaseMerge _)                 = 10+tickToTag (CaseElim _)                  = 11+tickToTag (CaseIdentity _)              = 12+tickToTag (FillInCaseDefault _)         = 13+tickToTag SimplifierDone                = 16+tickToTag (AltMerge _)                  = 17++pprTickType :: Tick -> SDoc+pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally"+pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally"+pprTickType (UnfoldingDone _)            = text "UnfoldingDone"+pprTickType (RuleFired _)                = text "RuleFired"+pprTickType LetFloatFromLet              = text "LetFloatFromLet"+pprTickType (EtaExpansion _)             = text "EtaExpansion"+pprTickType (EtaReduction _)             = text "EtaReduction"+pprTickType (BetaReduction _)            = text "BetaReduction"+pprTickType (CaseOfCase _)               = text "CaseOfCase"+pprTickType (KnownBranch _)              = text "KnownBranch"+pprTickType (CaseMerge _)                = text "CaseMerge"+pprTickType (AltMerge _)                 = text "AltMerge"+pprTickType (CaseElim _)                 = text "CaseElim"+pprTickType (CaseIdentity _)             = text "CaseIdentity"+pprTickType (FillInCaseDefault _)        = text "FillInCaseDefault"+pprTickType SimplifierDone               = text "SimplifierDone"++pprTickCts :: Tick -> SDoc+pprTickCts (PreInlineUnconditionally v) = ppr v+pprTickCts (PostInlineUnconditionally v)= ppr v+pprTickCts (UnfoldingDone v)            = ppr v+pprTickCts (RuleFired v)                = ppr v+pprTickCts LetFloatFromLet              = Outputable.empty+pprTickCts (EtaExpansion v)             = ppr v+pprTickCts (EtaReduction v)             = ppr v+pprTickCts (BetaReduction v)            = ppr v+pprTickCts (CaseOfCase v)               = ppr v+pprTickCts (KnownBranch v)              = ppr v+pprTickCts (CaseMerge v)                = ppr v+pprTickCts (AltMerge v)                 = ppr v+pprTickCts (CaseElim v)                 = ppr v+pprTickCts (CaseIdentity v)             = ppr v+pprTickCts (FillInCaseDefault v)        = ppr v+pprTickCts _                            = Outputable.empty++cmpTick :: Tick -> Tick -> Ordering+cmpTick a b = case (tickToTag a `compare` tickToTag b) of+                GT -> GT+                EQ -> cmpEqTick a b+                LT -> LT++cmpEqTick :: Tick -> Tick -> Ordering+cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b+cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b+cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `uniqCompareFS` b+cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b+cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b+cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b+cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b+cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b+cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b+cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b+cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b+cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b+cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b+cmpEqTick _                             _                               = EQ
+ GHC/Core/Opt/WorkWrap.hs view
@@ -0,0 +1,1067 @@+{-+(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.Data.FastString++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.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 $ concatMapM (wwBind ww_opts) 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 ww_arity 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 ww_arity 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 = mkLams arg_vars $+                                  simpleOptExpr (wo_simple_opts ww_opts) body+                  -- Run the simple optimiser on the WW'd body, to get rid of+                  -- junk. Keep all the original `arg_vars` binders though: this+                  -- might be a join point, and we don't want to lose the+                  -- one-shot annotations.  At least I think that's the reason+                  -- (honestly, I have forgottne), but doing it this way+                  -- certainly does no harm and is slightly more efficient.++              , 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+    ww_arity = workWrapArity fn_id rhs+      -- workWrapArity: see (4) in Note [Worker/wrapper arity and join points] in DmdAnal++    (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 $ fsLit "{-# 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 = JoinPoint join_arity+                    | otherwise      = NotJoinPoint+      -- 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 $ fsLit "{-# 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)] }
+ GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -0,0 +1,1870 @@+{-+(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+   , DataConPatContext(..)+   , UnboxingDecision(..), canUnboxArg+   , findTypeShape, IsRecDataConResult(..), isRecDataCon+   , mkAbsentFiller+   , isWorkerSmallEnough, dubiousDataConInstArgTys+   , boringSplit, usefulSplit, workWrapArity+   , canUnboxType, canUnboxTyCon+   )+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.Predicate( isDictTy )+import GHC.Core.Reduction+import GHC.Core.FamInstEnv+import GHC.Core.Predicate( isEqualityClass )+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 Control.Applicative ( (<|>) )+import Control.Monad ( zipWithM )+import Data.List ( unzip4 )++import GHC.Types.RepType+import GHC.Unit.Types+import GHC.Core.TyCo.Rep++{-+************************************************************************+*                                                                      *+\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+           -> Arity          -- ^ Worker/wrapper arity+           -> [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 ww_arity arg_vars res_ty demands res_cpr+  = do  { massertPpr arity_ok+                     (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]+        ; 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) <- cloneBndrsM empty_subst zapped_arg_vars+        ; let 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++    n_dmds = length demands+    arity_ok | isJoinId fun_id = ww_arity <= n_dmds+             | otherwise       = ww_arity == n_dmds++-- | 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.++workWrapArity :: Id -> CoreExpr -> Arity+-- See Note [Worker/wrapper arity and join points] in DmdAnal+workWrapArity fn rhs+  = case idJoinPointHood fn of+      JoinPoint join_arity -> count isId $ fst $ collectNBinders join_arity rhs+      NotJoinPoint         -> idArity fn++{-+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+  =  thunk_problem         -- See Note [Protecting the last value argument]+  || needs_float_barrier   -- See Note [Preserving float barriers]+  where+    -- thunk_problem: see Note [Protecting the last value argument]+    -- For join points we are only worried about (4), not (1-4).+    -- And (4) can't happen if (null work_args)+    --     (We could be more clever, by looking at the result type, but+    --      this approach is simple and conservative.)+    thunk_problem | isJoinId fn_id = no_value_arg && not (null work_args)+                  | otherwise      = no_value_arg+    no_value_arg = not (any isId work_args)++    -- needs_float_barrier: see Note [Preserving float barriers]+    needs_float_barrier = wrap_had_barrier && not work_has_barrier+    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++-- | Inserts a `Void#` arg as the last argument.+-- Why last? See Note [Worker/wrapper needs to add void arg last]+addVoidWorkerArg :: [Var] -> [StrictnessMark]+                 -> ( [Var]     -- Lambda bound args+                    , [Var]     -- Args at call site+                    , [StrictnessMark]) -- str semantics for the worker args+addVoidWorkerArg work_args str_marks+  = ( work_args ++ [voidArgId]+    , work_args ++ [voidPrimId]+    , str_marks ++ [NotMarkedStrict] )++{-+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.  Here are several 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.++4) It can create a worker of ill-kinded type (#22275).  Consider+     f :: forall r (a :: TYPE r). () -> a+     f x = f x+   Here `x` is absent, but if we simply drop it we'd end up with+     $wf :: forall r (a :: TYPE r). a+   But alas $wf's type is ill-kinded: the kind of (/\r (a::TYPE r).a)+   is (TYPE r), which mentions the bound variable `r`.  See also+   Note [Worker/wrapper needs to add void arg last]++See also Note [Preserving float barriers]++NB: Of these, only (1-3) don't apply to a join point, which can be+unlifted even if the RHS is not ok-for-speculation.++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#+p  * \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 [Worker/wrapper needs to add void arg last]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider point (4) of Note [Protecting the last value argument]++  f :: forall r (a :: TYPE r). () -> a+  f x = f x++As pointed out in (4) we need to add a void argument.  But if we add+it /first/ we'd get++  $wf :: Void# -> forall r (a :: TYPE r). a+  $wf = ...++But alas $wf's type is /still/ still-kinded, just as before in (4).+Solution is simple: put the void argument /last/:++  $wf :: forall r (a :: TYPE r). Void# -> a+  $wf = ...++c.f Note [SpecConstr void argument insertion] in GHC.Core.Opt.SpecConstr++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  -- INVARIANT: canUnboxTyCon is true of this DataCon's tycon+  , 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.++instance Outputable i => Outputable (UnboxingDecision i) where+  ppr DontUnbox  = text "DontUnbox"+  ppr DropAbsent = text "DropAbsent"+  ppr (DoUnbox i) = text "DoUnbox" <> braces (ppr i)++-- | 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] <- canUnboxTyCon tc  -- tc is never a newtype+  , 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 <- canUnboxTyCon 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 (CPR1) in Note [Which types are unboxed?]+                                -- and GHC.Core.Opt.CprAnal.argCprType+                                -- where we also check this.+  , null (dataConTheta dc) -- no constraints;+                           -- See (CPR2) in Note [Which types are unboxed?]+  = 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++++canUnboxType :: HasDebugCallStack => Type -> Maybe [DataCon]+canUnboxType arg_ty = case tyConAppTyCon_maybe arg_ty of+                        Just tc -> canUnboxTyCon tc+                        Nothing -> Nothing++canUnboxTyCon :: HasDebugCallStack => TyCon -> Maybe [DataCon]+-- True for+--   boxed algebraic datatypes+--   unboxed tuples and sums+--+-- False for+--   class dictionaries, except equality classes and tuples+--               See Note [Do not unbox class dictionaries]+--+-- Precondition: tc is not a newtype+canUnboxTyCon tc+  | Just cls <- tyConClass_maybe tc+  , not (isEqualityClass cls)+  = Nothing     -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]++  | otherwise+  = assertPpr (not (isNewTyCon tc)) (ppr tc) $  -- Check precondition+    tyConDataCons_maybe tc++{- 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.++3. #18421 found that unboxing a dictionary can also make the worker less likely+   to inline; the inlining heuristics seem to prefer to inline a function+   applied to a dictionary over a function applied to a bunch of functions.++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.++Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either.  We used to+  have a special case to unbox tuple dictionaries (#23398), but it ultimately+  turned out to be a very bad idea (see !19747#note_626297).   In summary:++  - If w/w unboxes tuple dictionaries we get things like+         case d of CTuple2 d1 d2 -> blah+    rather than+         let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah+    The latter works much better with the specialiser: when `d` is instantiated+    to some useful dictionary the `sc_sel1 d` selection can fire.++   - The attempt to deal with unpacking dictionaries with `case` led to+     significant extra complexity in the type-class specialiser (#26158) that is+     rendered unnecessary if we only take do superclass selection with superclass+     selectors, never with `case` expressions.++     Even with that extra complexity, specialisation was /still/ sometimes worse,+     and sometimes /tremendously/ worse (a factor of 70x); see #19747.++   - Suppose f :: forall a. (% Eq a, Show a %) => blah+     The specialiser is perfectly capable of specialising a call like+             f @Int (% dEqInt, dShowInt %)+     so the tuple doesn't get in the way.++   - It's simpler and more uniform.  There is nothing special about constraint+     tuples; anyone can write   class (C1 a, C2 a) => D a  where {}++Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,+  for (~), (~~), and Coercible (#23398).  Their payload is a single unboxed+  coercion.  We never want to specialise on `(t1 ~ t2)`.  All that would do is+  to make a copy of the function's RHS with a particular coercion.  Unlike+  normal class methods, that does not unlock any new optimisation+  opportunities in the specialised RHS.++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 (#18982)+     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+       * nor does it bind constraints (equalities or dictionaries)+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'.++     (CPR1).  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..) #)++     (CPR2) we don't allow constraints for CPR W/W, because an unboxed tuple+     contains types of kind `TYPE rr`, but not of kind `CONSTRAINT rr`.+     This is annoying; there is no real reason for this except that we don't+     have TYPE/CONSTAINT polymorphism.  See Note [TYPE and CONSTRAINT]+     in GHC.Builtin.Types.Prim.++The respective tests are in 'canUnboxArg' and+'canUnboxResult', respectively.++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 [EPT enforcement] 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.EnforceEpt.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 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'. See (AF1) in Note [Absent fillers]+  -- We want to use this case if possible, because we get a nice runtime panic message+  -- if we are wrong (like we were in #11126).  Otherwise we fall through to the+  -- less-desirable mkLitRubbish case.+  | mightBeLiftedType arg_ty+  , not (isDictTy arg_ty)                 -- See (AF4) in Note [Absent fillers]+  , not (isStrictDmd (idDemandInfo arg))  -- See (AF2)+  , not (isMarkedStrict str)              --    in Note [Absent fillers]+  = Just (mkAbsentErrorApp arg_ty msg)++  -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`+  -- See Note [Absent fillers]+  -- (AF3): mkLitRubbish returns Nothing if the representation is not+  --        monomorphic, in which case we can't make a filler+  | otherwise+  = mkLitRubbish arg_ty++  where+    arg_ty = idType 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:++(AF1) 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.++(AF2) 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.++(AF3) 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'.++(AF4) Consider (#24934)+         f :: (a~b) => blah {-# INLINE f #-}+         f d x = case eq_sel d of co -> body+     In #24934 it turned out that `co` was unused; and we discarded the+     entire case-scrutinisation via the `exprOkToDiscard` test in+     `GHC.Core.Opt.Simplify.Iteration.rebuildCase`.  So now `d` is absent.+     But in the /unfolding/ for some reason we did not discard the `case`;+     so when we inline `f` we end up evaluating that `d` argument.  So we had+     better not replace it with an error thunk!++     The root of it is this: `exprOkToDiscard` assumes that a dictionary is+     non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace+     the (a~b) dictionary with an error thunk, breaking the invariant that every+     dictionary is non-bottom.  (If -XDictsStrict is on, the invariant is even+     more important.)++     Simple solution: never use an error thunk for a dictionary; instead fall+     through to mkRubbishLit.  (The only downside is that we lose the compiler+     debugging advantages of (AF1).)++     This is quite delicate.++While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging+experience, (AF3) 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 this function \"dubious\"; only use it where type variables+-- aren't substituted for!  Why may the data con bind existentials?+--    See Note [Which types are unboxed?]+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs        = dataConUnivTyVars dc+    ex_tvs          = dataConExTyCoVars dc+    univ_subst      = zipTvSubst univ_tvs tc_args+    (full_subst, _) = substTyVarBndrs univ_subst ex_tvs+    arg_tys         = map (substTy full_subst . scaledThing) $+                      dataConRepArgTys dc+    -- NB: use substTyVarBndrs on ex_tvs to ensure that we+    --     substitute in their kinds.  For example (#22849)+    -- Consider data T a where+    --            MkT :: forall k (t::k->*) (ix::k). t ix -> T @k a+    -- Then dubiousDataConInstArgTys MkT [Type, Foo] should return+    --        [Foo (ix::Type)], not [Foo (ix::k)]!++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++       | not (isNewTyCon tc)+       , Just con <- tyConSingleDataCon_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) $+      case coreFullView ty of+        TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args+          -- See Note [Detecting recursive data constructors], points (B) and (C)++        ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'+          -- See Note [Detecting recursive data constructors], point (A)++        CastTy ty' _ -> go_arg_ty fuel visited_tcs ty'++        AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a+          -- See Note [Detecting recursive data constructors], point (D)++        FunTy{} -> NonRecursiveOrUnsure+          -- See Note [Detecting recursive data constructors], point (1)++        -- (TyVarTy{} | LitTy{} | CastTy{})+        _ -> 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.+-}
+ GHC/Core/PatSyn.hs view
@@ -0,0 +1,521 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998++\section[PatSyn]{@PatSyn@: Pattern synonyms}+-}++++module GHC.Core.PatSyn (+        -- * Main data types+        PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,++        -- ** Type deconstruction+        patSynName, patSynArity, patSynVisArity,+        patSynIsInfix, patSynResultType,+        isVanillaPatSyn,+        patSynArgs,+        patSynMatcher, patSynBuilder,+        patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders,+        patSynSig, patSynSigBndr,+        patSynInstArgTys, patSynInstResTy, patSynFieldLabels,+        patSynFieldType,++        pprPatSynType+    ) where++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.TyCo.Ppr+import GHC.Types.Name+import GHC.Types.Unique+import GHC.Types.Basic+import GHC.Types.Var+import GHC.Types.FieldLabel++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import qualified Data.Data as Data+import Data.Function+import Data.List (find)++{-+************************************************************************+*                                                                      *+\subsection{Pattern synonyms}+*                                                                      *+************************************************************************+-}++-- | Pattern Synonym+--+-- See Note [Pattern synonym representation]+-- See Note [Pattern synonym signature contexts]+data PatSyn+  = MkPatSyn {+        psName        :: Name,+        psUnique      :: Unique,       -- Cached from Name++        psArgs        :: [FRRType],    -- ^ Argument types+        psArity       :: Arity,        -- == length psArgs+        psInfix       :: Bool,         -- True <=> declared infix+        psFieldLabels :: [FieldLabel], -- List of fields for a+                                       -- record pattern synonym+                                       -- INVARIANT: either empty if no+                                       -- record pat syn or same length as+                                       -- psArgs++        -- Universally-quantified type variables+        psUnivTyVars  :: [InvisTVBinder],++        -- Required dictionaries (may mention psUnivTyVars)+        psReqTheta    :: ThetaType,++        -- Existentially-quantified type vars+        psExTyVars    :: [InvisTVBinder],++        -- Provided dictionaries (may mention psUnivTyVars or psExTyVars)+        psProvTheta   :: ThetaType,++        -- Result type+        psResultTy   :: Type,  -- Mentions only psUnivTyVars+                               -- See Note [Pattern synonym result type]++        -- See Note [Matchers and builders for pattern synonyms]+        -- See Note [Keep Ids out of PatSyn]+        psMatcher     :: PatSynMatcher,+        psBuilder     :: PatSynBuilder+  }++type PatSynMatcher = (Name, Type, Bool)+     -- Matcher function.+     -- If Bool is True then prov_theta and arg_tys are empty+     -- and type is+     --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.+     --                          req_theta+     --                       => res_ty+     --                       -> (forall ex_tvs. Void# -> r)+     --                       -> (Void# -> r)+     --                       -> r+     --+     -- Otherwise type is+     --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.+     --                          req_theta+     --                       => res_ty+     --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)+     --                       -> (Void# -> r)+     --                       -> r++type PatSynBuilder = Maybe (Name, Type, Bool)+     -- Nothing  => uni-directional pattern synonym+     -- Just (builder, is_unlifted) => bi-directional+     -- Builder function, of type+     --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)+     --                       =>  arg_tys -> res_ty+     -- See Note [Builder for pattern synonyms with unboxed type]++{- Note [Pattern synonym signature contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a pattern synonym signature we write+   pattern P :: req => prov => t1 -> ... tn -> res_ty++Note that the "required" context comes first, then the "provided"+context.  Moreover, the "required" context must not mention+existentially-bound type variables; that is, ones not mentioned in+res_ty.  See lots of discussion in #10928.++If there is no "provided" context, you can omit it; but you+can't omit the "required" part (unless you omit both).++Example 1:+      pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)+      pattern P1 x = Just (3,x)++  We require (Num a, Eq a) to match the 3; there is no provided+  context.++Example 2:+      data T2 where+        MkT2 :: (Num a, Eq a) => a -> a -> T2++      pattern P2 :: () => (Num a, Eq a) => a -> T2+      pattern P2 x = MkT2 3 x++  When we match against P2 we get a Num dictionary provided.+  We can use that to check the match against 3.++Example 3:+      pattern P3 :: Eq a => a -> b -> T3 b++   This signature is illegal because the (Eq a) is a required+   constraint, but it mentions the existentially-bound variable 'a'.+   You can see it's existential because it doesn't appear in the+   result type (T3 b).++Note [Pattern synonym result type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a b = MkT b a++   pattern P :: a -> T [a] Bool+   pattern P x = MkT True [x]++P's psResultTy is (T a Bool), and it really only matches values of+type (T [a] Bool).  For example, this is ill-typed++   f :: T p q -> String+   f (P x) = "urk"++This is different to the situation with GADTs:++   data S a where+     MkS :: Int -> S Bool++Now MkS (and pattern synonyms coming from MkS) can match a+value of type (S a), not just (S Bool); we get type refinement.++That in turn means that if you have a pattern++   P x :: T [ty] Bool++it's not entirely straightforward to work out the instantiation of+P's universal tyvars. You have to /match/+  the type of the pattern, (T [ty] Bool)+against+  the psResultTy for the pattern synonym, T [a] Bool+to get the instantiation a := ty.++This is very unlike DataCons, where univ tyvars match 1-1 the+arguments of the TyCon.++Side note: I (SG) get the impression that instantiated return types should+generate a *required* constraint for pattern synonyms, rather than a *provided*+constraint like it's the case for GADTs. For example, I'd expect these+declarations to have identical semantics:++    pattern Just42 :: Maybe Int+    pattern Just42 = Just 42++    pattern Just'42 :: (a ~ Int) => Maybe a+    pattern Just'42 = Just 42++The latter generates the proper required constraint, the former does not.+Also rather different to GADTs is the fact that Just42 doesn't have any+universally quantified type variables, whereas Just'42 or MkS above has.++Note [Keep Ids out of PatSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We carefully arrange that PatSyn does not contain the Ids for the matcher+and builder.  We want PatSyn, like TyCon and DataCon, to be completely+immutable. But, the matcher and builder are relatively sophisticated+functions, and we want to get their final IdInfo in the same way as+any other Id, so we'd have to update the Ids in the PatSyn too.++Rather than try to tidy PatSyns (which is easy to forget and is a bit+tricky, see #19074), it seems cleaner to make them entirely immutable,+like TyCons and Classes.  To that end PatSynBuilder and PatSynMatcher+contain Names not Ids. Which, it turns out, is absolutely fine.++c.f. DefMethInfo in Class, which contains the Name, but not the Id,+of the default method.++Note [Pattern synonym representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym declaration++        pattern P x = MkT [x] (Just 42)++where+        data T a where+              MkT :: (Show a, Ord b) => [b] -> a -> T a++so pattern P has type++        b -> T (Maybe t)++with the following typeclass constraints:++        requires: (Eq t, Num t)+        provides: (Show (Maybe t), Ord b)++In this case, the fields of MkPatSyn will be set as follows:++  psArgs       = [b]+  psArity      = 1+  psInfix      = False++  psUnivTyVars = [t]+  psExTyVars   = [b]+  psProvTheta  = (Show (Maybe t), Ord b)+  psReqTheta   = (Eq t, Num t)+  psResultTy  = T (Maybe t)++Note [Matchers and builders for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For each pattern synonym P, we generate++  * a "matcher" function, used to desugar uses of P in patterns,+    which implements pattern matching++  * A "builder" function (for bidirectional pattern synonyms only),+    used to desugar uses of P in expressions, which constructs P-values.++For the above example, the matcher function has type:++        $mP :: forall (r :: ?) t. (Eq t, Num t)+            => T (Maybe t)+            -> (forall b. (Show (Maybe t), Ord b) => b -> r)+            -> (Void# -> r)+            -> r++with the following implementation:++        $mP @r @t $dEq $dNum scrut cont fail+          = case scrut of+              MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x+              _                                 -> fail Void#++Notice that the return type 'r' has an open kind, so that it can+be instantiated by an unboxed type; for example where we see+     f (P x) = 3#++The extra Void# argument for the failure continuation is needed so that+it is lazy even when the result type is unboxed.++For the same reason, if the pattern has no arguments, an extra Void#+argument is added to the success continuation as well.++For *bidirectional* pattern synonyms, we also generate a "builder"+function which implements the pattern synonym in an expression+context. For our running example, it will be:++        $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b)+            => b -> T (Maybe t)+        $bP x = MkT [x] (Just 42)++NB: the existential/universal and required/provided split does not+apply to the builder since you are only putting stuff in, not getting+stuff out.++Injectivity of bidirectional pattern synonyms is checked in+tcPatToExpr which walks the pattern and returns its corresponding+expression when available.++Note [Builder for pattern synonyms with unboxed type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For bidirectional pattern synonyms that have no arguments and have an+unboxed type, we add an extra Void# argument to the builder, else it+would be a top-level declaration with an unboxed type.++        pattern P = 0#++        $bP :: Void# -> Int#+        $bP _ = 0#++This means that when typechecking an occurrence of P in an expression,+we must remember that the builder has this void argument. This is+done by GHC.Tc.TyCl.PatSyn.patSynBuilderOcc.++Note [Pattern synonyms and the data type Type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type of a pattern synonym is of the form (See Note+[Pattern synonym signatures] in GHC.Tc.Gen.Sig):++    forall univ_tvs. req => forall ex_tvs. prov => ...++We cannot in general represent this by a value of type Type:++ - if ex_tvs is empty, then req and prov cannot be distinguished from+   each other+ - if req is empty, then univ_tvs and ex_tvs cannot be distinguished+   from each other, and moreover, prov is seen as the "required" context+   (as it is the only context)+++************************************************************************+*                                                                      *+\subsection{Instances}+*                                                                      *+************************************************************************+-}++instance Eq PatSyn where+    (==) = (==) `on` getUnique+    (/=) = (/=) `on` getUnique++instance Uniquable PatSyn where+    getUnique = psUnique++instance NamedThing PatSyn where+    getName = patSynName++instance Outputable PatSyn where+    ppr = ppr . getName++instance OutputableBndr PatSyn where+    pprInfixOcc = pprInfixName . getName+    pprPrefixOcc = pprPrefixName . getName++instance Data.Data PatSyn where+    -- don't traverse?+    toConstr _   = abstractConstr "PatSyn"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "PatSyn"++{-+************************************************************************+*                                                                      *+\subsection{Construction}+*                                                                      *+************************************************************************+-}++-- | Build a new pattern synonym+mkPatSyn :: Name+         -> Bool                 -- ^ Is the pattern synonym declared infix?+         -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type+                                         -- variables and required dicts+         -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type+                                         -- variables and provided dicts+         -> [FRRType]            -- ^ Original arguments+         -> Type                 -- ^ Original result type+         -> PatSynMatcher        -- ^ Matcher+         -> PatSynBuilder        -- ^ Builder+         -> [FieldLabel]         -- ^ Names of fields for+                                 --   a record pattern synonym+         -> PatSyn+ -- NB: The univ and ex vars are both in PiTyVarBinder form and TyVar form for+ -- convenience. All the TyBinders should be Named!+mkPatSyn name declared_infix+         (univ_tvs, req_theta)+         (ex_tvs, prov_theta)+         orig_args+         orig_res_ty+         matcher builder field_labels+    = MkPatSyn {psName = name, psUnique = getUnique name,+                psUnivTyVars = univ_tvs,+                psExTyVars = ex_tvs,+                psProvTheta = prov_theta, psReqTheta = req_theta,+                psInfix = declared_infix,+                psArgs = orig_args,+                psArity = length orig_args,+                psResultTy = orig_res_ty,+                psMatcher = matcher,+                psBuilder = builder,+                psFieldLabels = field_labels+                }++-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification+patSynName :: PatSyn -> Name+patSynName = psName++-- | Should the 'PatSyn' be presented infix?+patSynIsInfix :: PatSyn -> Bool+patSynIsInfix = psInfix++-- | Arity of the pattern synonym+patSynArity :: PatSyn -> Arity+patSynArity = psArity++-- | Number of visible arguments of the pattern synonym+patSynVisArity :: PatSyn -> VisArity+patSynVisArity ps = n_of_required_ty_args + n_of_val_args+  where+    n_of_val_args = psArity ps+    n_of_required_ty_args = 0   -- no visible forall in pattern synonyms yet (#23704)++-- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)?+isVanillaPatSyn :: PatSyn -> Bool+isVanillaPatSyn ps = null (psExTyVars ps) && null (psProvTheta ps)++patSynArgs :: PatSyn -> [Type]+patSynArgs = psArgs++patSynFieldLabels :: PatSyn -> [FieldLabel]+patSynFieldLabels = psFieldLabels++-- | Extract the type for any given labelled field of the 'DataCon'+patSynFieldType :: PatSyn -> FieldLabelString -> Type+patSynFieldType ps label+  = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of+      Just (_, ty) -> ty+      Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)++patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder]+patSynUnivTyVarBinders = psUnivTyVars++patSynExTyVars :: PatSyn -> [TyVar]+patSynExTyVars ps = binderVars (psExTyVars ps)++patSynExTyVarBinders :: PatSyn -> [InvisTVBinder]+patSynExTyVarBinders = psExTyVars++patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type)+patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs+                        , psProvTheta = prov, psReqTheta = req+                        , psArgs = arg_tys, psResultTy = res_ty })+  = (univ_tvs, req, ex_tvs, prov, map unrestricted arg_tys, res_ty)++patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], Type)+patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps+               in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty)++patSynMatcher :: PatSyn -> PatSynMatcher+patSynMatcher = psMatcher++patSynBuilder :: PatSyn -> PatSynBuilder+patSynBuilder = psBuilder++patSynResultType :: PatSyn -> Type+patSynResultType = psResultTy++patSynInstArgTys :: PatSyn -> [Type] -> [Type]+-- Return the types of the argument patterns+-- e.g.  data D a = forall b. MkD a b (b->a)+--       pattern P f x y = MkD (x,True) y f+--          D :: forall a. forall b. a -> b -> (b->a) -> D a+--          P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c+--   patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb]+-- NB: the inst_tys should be both universal and existential+patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                           , psExTyVars = ex_tvs, psArgs = arg_tys })+                 inst_tys+  = assertPpr (tyvars `equalLength` inst_tys)+              (text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys) $+    map (substTyWith tyvars inst_tys) arg_tys+  where+    tyvars = binderVars (univ_tvs ++ ex_tvs)++patSynInstResTy :: PatSyn -> [Type] -> Type+-- Return the type of whole pattern+-- E.g.  pattern P x y = Just (x,x,y)+--         P :: a -> b -> Just (a,a,b)+--         (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool)+-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars+patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs+                          , psResultTy = res_ty })+                inst_tys+  = assertPpr (univ_tvs `equalLength` inst_tys)+              (text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys) $+    substTyWith (binderVars univ_tvs) inst_tys res_ty++-- | Print the type of a pattern synonym. The foralls are printed explicitly+pprPatSynType :: PatSyn -> SDoc+pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs,  psReqTheta  = req_theta+                        , psExTyVars   = ex_tvs,    psProvTheta = prov_theta+                        , psArgs       = orig_args, psResultTy = orig_res_ty })+  = sep [ pprForAll $ tyVarSpecToBinders univ_tvs+        , pprThetaArrowTy req_theta+        , ppWhen insert_empty_ctxt $ parens empty <+> darrow+        , pprType sigma_ty ]+  where+    sigma_ty = mkInvisForAllTys ex_tvs $+               mkInvisFunTys prov_theta $+               mkVisFunTysMany orig_args orig_res_ty+    insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
+ GHC/Core/Ppr.hs view
@@ -0,0 +1,711 @@+{-# LANGUAGE LambdaCase #-}++{-+   these are needed for the Outputable instance for GenTickish,+   since we need XTickishId to be Outputable. This should immediately+   resolve to something like Id.+ -}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++Printing of Core syntax+-}++module GHC.Core.Ppr (+        pprCoreExpr, pprParendExpr,+        pprCoreBinding, pprCoreBindings, pprCoreAlt,+        pprCoreBindingWithSize, pprCoreBindingsWithSize,+        pprCoreBinder, pprCoreBinders, pprId, pprIds,+        pprRule, pprRules, pprOptCo,+        pprOcc, pprOccWithTick+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.Stats (exprStats)+import GHC.Types.Fixity (LexicalFixity(..))+import GHC.Types.Literal( pprLiteral )+import GHC.Types.Name( pprInfixName, pprPrefixName )+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.TyCo.Ppr+import GHC.Core.Coercion+import GHC.Types.Basic+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.SrcLoc ( pprUserRealSpan )+import GHC.Types.Tickish++{-+************************************************************************+*                                                                      *+\subsection{Public interfaces for Core printing (excluding instances)}+*                                                                      *+************************************************************************++@pprParendCoreExpr@ puts parens around non-atomic Core expressions.+-}++pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc+pprCoreBinding  :: OutputableBndr b => Bind b  -> SDoc+pprCoreExpr     :: OutputableBndr b => Expr b  -> SDoc+pprParendExpr   :: OutputableBndr b => Expr b  -> SDoc++pprCoreBindings = pprTopBinds noAnn+pprCoreBinding  = pprTopBind noAnn++pprCoreBindingsWithSize :: [CoreBind] -> SDoc+pprCoreBindingWithSize  :: CoreBind  -> SDoc++pprCoreBindingsWithSize = pprTopBinds sizeAnn+pprCoreBindingWithSize = pprTopBind sizeAnn++instance OutputableBndr b => Outputable (Bind b) where+    ppr bind = ppr_bind noAnn bind++instance OutputableBndr b => Outputable (Expr b) where+    ppr expr = pprCoreExpr expr++instance OutputableBndr b => Outputable (Alt b) where+    ppr expr = pprCoreAlt expr++{-+************************************************************************+*                                                                      *+\subsection{The guts}+*                                                                      *+************************************************************************+-}++-- | A function to produce an annotation for a given right-hand-side+type Annotation b = Expr b -> SDoc++-- | Annotate with the size of the right-hand-side+sizeAnn :: CoreExpr -> SDoc+sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)++-- | No annotation+noAnn :: Expr b -> SDoc+noAnn _ = empty++pprTopBinds :: OutputableBndr a+            => Annotation a -- ^ generate an annotation to place before the+                            -- binding+            -> [Bind a]     -- ^ bindings to show+            -> SDoc         -- ^ the pretty result+pprTopBinds ann binds = vcat (map (pprTopBind ann) binds)++pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc+pprTopBind ann (NonRec binder expr)+ = ppr_binding ann (binder,expr) $$ blankLine++pprTopBind _ (Rec [])+  = text "Rec { }"+pprTopBind ann (Rec (b:bs))+  = vcat [text "Rec {",+          ppr_binding ann b,+          vcat [blankLine $$ ppr_binding ann b | b <- bs],+          text "end Rec }",+          blankLine]++ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc++ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr)+ppr_bind ann (Rec binds)           = vcat (map pp binds)+                                    where+                                      pp bind = ppr_binding ann bind <> semi++ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc+ppr_binding ann (val_bdr, expr)+  = vcat [ ann expr+         , ppUnlessOption sdocSuppressTypeSignatures+             (pprBndr LetBind val_bdr)+         , pp_bind+         ]+  where+    pp_val_bdr = pprPrefixOcc val_bdr++    pp_bind = case bndrIsJoin_maybe val_bdr of+                NotJoinPoint -> pp_normal_bind+                JoinPoint ar -> pp_join_bind ar++    pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)++      -- For a join point of join arity n, we want to print j = \x1 ... xn -> e+      -- as "j x1 ... xn = e" to differentiate when a join point returns a+      -- lambda (the first rendering looks like a nullary join point returning+      -- an n-argument function).+    pp_join_bind join_arity+      | bndrs `lengthAtLeast` join_arity+      = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))+           2 (equals <+> pprCoreExpr rhs)+      | otherwise -- Yikes!  A join-binding with too few lambda+                  -- Lint will complain, but we don't want to crash+                  -- the pretty-printer else we can't see what's wrong+                  -- So refer to printing  j = e+      = pp_normal_bind+      where+        (bndrs, body)     = collectBinders expr+        (lhs_bndrs, rest) = splitAt join_arity bndrs+        rhs               = mkLams rest body++pprParendExpr expr = ppr_expr parens expr+pprCoreExpr   expr = ppr_expr noParens expr++noParens :: SDoc -> SDoc+noParens pp = pp++pprOptCo :: Coercion -> SDoc+-- Print a coercion optionally; i.e. honouring -dsuppress-coercions+pprOptCo co = sdocOption sdocSuppressCoercions $ \case+              True  -> angleBrackets (text "Co:" <> int (coercionSize co)) <+> dcolon <+> co_type+              False -> parens $ sep [ppr co, dcolon <+> co_type]+    where+      co_type = sdocOption sdocSuppressCoercionTypes $ \case+          True -> text "..."+          False -> ppr (coercionType co)++ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc+ppr_id_occ add_par id+  | isJoinId id = add_par ((text "jump") <+> pp_id)+  | otherwise   = pp_id+  where+    pp_id = ppr id  -- We could use pprPrefixOcc to print (+) etc, but this is+                    -- Core where we don't print things infix anyway, so doing+                    -- so just adds extra redundant parens++ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc+        -- The function adds parens in context that need+        -- an atomic value (e.g. function args)++ppr_expr add_par (Var id)      = ppr_id_occ add_par id+ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird+ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)+ppr_expr add_par (Lit lit)     = pprLiteral add_par lit++ppr_expr add_par (Cast expr co)+  = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co]++ppr_expr add_par expr@(Lam _ _)+  = let+        (bndrs, body) = collectBinders expr+    in+    add_par $+    hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)+         2 (pprCoreExpr body)++ppr_expr add_par expr@(App {})+  = sdocOption sdocSuppressTypeApplications $ \supp_ty_app ->+    case collectArgs expr of { (fun, args) ->+    let+        pp_args     = sep (map pprArg args)+        val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples+        pp_tup_args = pprWithCommas pprCoreExpr val_args+        args'+          | supp_ty_app = val_args+          | otherwise   = args+        parens+          | null args' = id+          | otherwise  = add_par+    in+    case fun of+        Var f -> case isDataConWorkId_maybe f of+                        -- Notice that we print the *worker*+                        -- for tuples in paren'd format.+                   Just dc | saturated+                           , Just sort <- tyConTuple_maybe tc+                           -> tupleParens sort pp_tup_args+                           where+                             tc        = dataConTyCon dc+                             saturated = val_args `lengthIs` idArity f++                   _ -> parens (hang fun_doc 2 pp_args)+                   where+                     fun_doc = ppr_id_occ noParens f++        _ -> parens (hang (pprParendExpr fun) 2 pp_args)+    }++ppr_expr add_par (Case expr _ ty []) -- Empty Case+  = add_par $ sep [text "case"+                      <+> pprCoreExpr expr+                      <+> whenPprDebug (text "return" <+> ppr ty),+                    text "of {}"]++ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case+  = sdocOption sdocPrintCaseAsLet $ \case+      True -> add_par $  -- See Note [Print case as let]+               sep [ sep [ text "let! {"+                           <+> ppr_case_pat con args+                           <+> text "~"+                           <+> ppr_bndr var+                         , text "<-" <+> ppr_expr id expr+                           <+> text "} in" ]+                   , pprCoreExpr rhs+                   ]+      False -> add_par $+                sep [sep [sep [ text "case" <+> pprCoreExpr expr+                              , whenPprDebug (text "return" <+> ppr ty)+                              , text "of" <+> ppr_bndr var+                              ]+                         , char '{' <+> ppr_case_pat con args <+> arrow+                         ]+                     , pprCoreExpr rhs+                     , char '}'+                     ]+  where+    ppr_bndr = pprBndr CaseBind++ppr_expr add_par (Case expr var ty alts) -- Multi alt Case+  = add_par $+    sep [sep [text "case"+                <+> pprCoreExpr expr+                <+> whenPprDebug (text "return" <+> ppr ty),+              text "of" <+> ppr_bndr var <+> char '{'],+         nest 2 (vcat (punctuate semi (map pprCoreAlt alts))),+         char '}'+    ]+  where+    ppr_bndr = pprBndr CaseBind+++-- special cases: let ... in let ...+-- ("disgusting" SLPJ)++{-+ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)+  = add_par $+    vcat [+      hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals],+      nest 2 (pprCoreExpr rhs),+      text "} in",+      pprCoreExpr body ]++ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))+  = add_par+    (hang (text "let {")+          2 (hsep [ppr_binding (val_bdr,rhs),+                   text "} in"])+     $$+     pprCoreExpr expr)+-}+++-- General case (recursive case, too)+ppr_expr add_par (Let bind expr)+  = add_par $+    sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),+         pprCoreExpr expr]+  where+    keyword (NonRec b _)+     | isJoinPoint (bndrIsJoin_maybe b) = text "join"+     | otherwise                        = text "let"+    keyword (Rec pairs)+     | ((b,_):_) <- pairs+     , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"+     | otherwise                        = text "letrec"++ppr_expr add_par (Tick tickish expr)+  = sdocOption sdocSuppressTicks $ \case+      -- Only hide non-runtime relevant ticks.+      True+        | not (tickishIsCode tickish) -> ppr_expr add_par expr+      _ -> add_par (sep [ppr tickish, pprCoreExpr expr])++pprCoreAlt :: OutputableBndr a => Alt a -> SDoc+pprCoreAlt (Alt con args rhs)+  = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)++ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc+ppr_case_pat (DataAlt dc) args+  | Just sort <- tyConTuple_maybe tc+  = tupleParens sort (pprWithCommas ppr_bndr args)+  where+    ppr_bndr = pprBndr CasePatBind+    tc = dataConTyCon dc++ppr_case_pat con args+  = ppr con <+> (fsep (map ppr_bndr args))+  where+    ppr_bndr = pprBndr CasePatBind+++-- | Pretty print the argument in a function application.+pprArg :: OutputableBndr a => Expr a -> SDoc+pprArg (Type ty)+ = ppUnlessOption sdocSuppressTypeApplications+      (text "@" <> pprParendType ty)+pprArg (Coercion co) = text "@~" <> pprOptCo co+pprArg expr          = pprParendExpr expr++{-+Note [Print case as let]+~~~~~~~~~~~~~~~~~~~~~~~~+Single-branch case expressions are very common:+   case x of y { I# x' ->+   case p of q { I# p' -> ... } }+These are, in effect, just strict let's, with pattern matching.+With -dppr-case-as-let we print them as such:+   let! { I# x' ~ y <- x } in+   let! { I# p' ~ q <- p } in ...+++Other printing bits-and-bobs used with the general @pprCoreBinding@+and @pprCoreExpr@ functions.+++Note [Binding-site specific printing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust+the information printed.++Let-bound binders are printed with their full type and idInfo.++Case-bound variables (both the case binder and pattern variables) are printed+without a type and without their unfolding.++Furthermore, a dead case-binder is completely ignored, while otherwise, dead+binders are printed as "_".+-}++-- These instances are sadly orphans++instance OutputableBndr Var where+  pprBndr = pprCoreBinder+  pprInfixOcc  = pprInfixName  . varName+  pprPrefixOcc = pprPrefixName . varName+  bndrIsJoin_maybe = idJoinPointHood++instance Outputable b => OutputableBndr (TaggedBndr b) where+  pprBndr _    b = ppr b   -- Simple+  pprInfixOcc  b = ppr b+  pprPrefixOcc b = ppr b+  bndrIsJoin_maybe (TB b _) = idJoinPointHood b++pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc+pprOcc Infix  = pprInfixOcc+pprOcc Prefix = pprPrefixOcc++pprOccWithTick :: OutputableBndr a => LexicalFixity -> PromotionFlag -> a -> SDoc+pprOccWithTick fixity prom op+  | isPromoted prom+  = quote (pprOcc fixity op)+  | otherwise+  = pprOcc fixity op++pprCoreBinder :: BindingSite -> Var -> SDoc+pprCoreBinder LetBind binder+  | isTyVar binder = pprKindedTyVarBndr binder+  | otherwise      = pprTypedLetBinder binder $$+                     ppIdInfo binder (idInfo binder)++-- Lambda bound type variables are preceded by "@"+pprCoreBinder bind_site bndr+  = getPprDebug $ \debug ->+    pprTypedLamBinder bind_site debug bndr++pprCoreBinders :: [Var] -> SDoc+-- Print as lambda-binders, i.e. with their type+pprCoreBinders vs = sep (map (pprCoreBinder LambdaBind) vs)++pprUntypedBinder :: Var -> SDoc+pprUntypedBinder binder+  | isTyVar binder = text "@" <> ppr binder    -- NB: don't print kind+  | otherwise      = pprIdBndr binder++pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc+-- For lambda and case binders, show the unfolding info (usually none)+pprTypedLamBinder bind_site debug_on var+  = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->+    case () of+    _+      | not debug_on            -- Show case-bound wild binders only if debug is on+      , CaseBind <- bind_site+      , isDeadBinder var        -> empty++      | not debug_on            -- Even dead binders can be one-shot+      , isDeadBinder var        -> char '_' <+> ppWhen (isId var)+                                                (pprIdBndrInfo (idInfo var))++      | not debug_on            -- No parens, no kind info+      , CaseBind <- bind_site   -> pprUntypedBinder var++      | not debug_on+      , CasePatBind <- bind_site    -> pprUntypedBinder var++      | suppress_sigs -> pprUntypedBinder var++      | isTyVar var  -> parens (pprKindedTyVarBndr var)++      | otherwise    -> parens (hang (pprIdBndr var)+                                   2 (vcat [ dcolon <+> pprType (idType var)+                                           , pp_unf]))+  where+    unf_info = realUnfoldingInfo (idInfo var)+    pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info+           | otherwise                 = empty++pprTypedLetBinder :: Var -> SDoc+-- Print binder with a type or kind signature (not paren'd)+pprTypedLetBinder binder+  = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->+    case () of+    _+      | isTyVar binder -> pprKindedTyVarBndr binder+      | suppress_sigs  -> pprIdBndr binder+      | otherwise      -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))++pprKindedTyVarBndr :: TyVar -> SDoc+-- Print a type variable binder with its kind (but not if *)+pprKindedTyVarBndr tyvar+  = text "@" <> pprTyVar tyvar++-- pprId x prints x :: ty+pprId :: Id -> SDoc+pprId x = ppr x <+> dcolon <+> ppr (idType x)++pprIds :: [Id] -> SDoc+pprIds xs = sep (map pprId xs)++-- pprIdBndr does *not* print the type+-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness+pprIdBndr :: Id -> SDoc+pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)++pprIdBndrInfo :: IdInfo -> SDoc+pprIdBndrInfo info+  = ppUnlessOption sdocSuppressIdInfo+      (info `seq` doc) -- The seq is useful for poking on black holes+  where+    prag_info = inlinePragInfo info+    occ_info  = occInfo info+    dmd_info  = demandInfo info+    lbv_info  = oneShotInfo info++    has_prag  = not (isDefaultInlinePragma prag_info)+    has_occ   = not (isNoOccInfo occ_info)+    has_dmd   = not $ isTopDmd dmd_info+    has_lbv   = not (hasNoOneShotInfo lbv_info)++    doc = showAttributes+          [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info)+          , (has_occ,  text "Occ=" <> ppr occ_info)+          , (has_dmd,  text "Dmd=" <> ppr dmd_info)+          , (has_lbv , text "OS=" <> ppr lbv_info)+          ]++instance Outputable IdInfo where+  ppr info = showAttributes+    [ (has_prag,         text "InlPrag=" <> pprInlineDebug prag_info)+    , (has_occ,          text "Occ=" <> ppr occ_info)+    , (has_dmd,          text "Dmd=" <> ppr dmd_info)+    , (has_lbv ,         text "OS=" <> ppr lbv_info)+    , (has_arity,        text "Arity=" <> int arity)+    , (has_called_arity, text "CallArity=" <> int called_arity)+    , (has_caf_info,     text "Caf=" <> ppr caf_info)+    , (has_str_info,     text "Str=" <> pprStrictness str_info)+    , (has_unf,          text "Unf=" <> ppr unf_info)+    , (has_rules,        text "RULES:" <+> vcat (map pprRule rules))+    ]+    where+      prag_info = inlinePragInfo info+      has_prag  = not (isDefaultInlinePragma prag_info)++      occ_info  = occInfo info+      has_occ   = not (isManyOccs occ_info)++      dmd_info  = demandInfo info+      has_dmd   = not $ isTopDmd dmd_info++      lbv_info  = oneShotInfo info+      has_lbv   = not (hasNoOneShotInfo lbv_info)++      arity = arityInfo info+      has_arity = arity /= 0++      called_arity = callArityInfo info+      has_called_arity = called_arity /= 0++      caf_info = cafInfo info+      has_caf_info = not (mayHaveCafRefs caf_info)++      str_info = dmdSigInfo info+      has_str_info = not (isNopSig str_info)++      unf_info = realUnfoldingInfo info+      has_unf = hasSomeUnfolding unf_info++      rules = ruleInfoRules (ruleInfo info)+      has_rules = not (null rules)++{-+-----------------------------------------------------+--      IdDetails and IdInfo+-----------------------------------------------------+-}++ppIdInfo :: Id -> IdInfo -> SDoc+ppIdInfo id info+  = ppUnlessOption sdocSuppressIdInfo $+    showAttributes+    [ (True, pp_scope <> ppr (idDetails id))+    , (has_arity,        text "Arity=" <> int arity)+    , (has_called_arity, text "CallArity=" <> int called_arity)+    , (has_caf_info,     text "Caf=" <> ppr caf_info)+    , (has_str_info,     text "Str=" <> pprStrictness str_info)+    , (has_cpr_info,     text "Cpr=" <> ppr cpr_info)+    , (has_unf,          text "Unf=" <> ppr unf_info)+    , (not (null rules), text "RULES:" <+> vcat (map pprRule rules))+    ]   -- Inline pragma, occ, demand, one-shot info+        -- printed out with all binders (when debug is on);+        -- see GHC.Core.Ppr.pprIdBndr+  where+    pp_scope | isGlobalId id   = text "GblId"+             | isExportedId id = text "LclIdX"+             | otherwise       = text "LclId"++    arity = arityInfo info+    has_arity = arity /= 0++    called_arity = callArityInfo info+    has_called_arity = called_arity /= 0++    caf_info = cafInfo info+    has_caf_info = not (mayHaveCafRefs caf_info)++    str_info = dmdSigInfo info+    has_str_info = not (isNopSig str_info)++    cpr_info = cprSigInfo info+    has_cpr_info = cpr_info /= topCprSig++    unf_info = realUnfoldingInfo info+    has_unf = hasSomeUnfolding unf_info++    rules = ruleInfoRules (ruleInfo info)++showAttributes :: [(Bool,SDoc)] -> SDoc+showAttributes stuff+  | null docs = empty+  | otherwise = brackets (sep (punctuate comma docs))+  where+    docs = [d | (True,d) <- stuff]++{-+-----------------------------------------------------+--      Unfolding and UnfoldingGuidance+-----------------------------------------------------+-}++instance Outputable UnfoldingGuidance where+    ppr UnfNever  = text "NEVER"+    ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok })+      = text "ALWAYS_IF" <>+        parens (text "arity="     <> int arity    <> comma <>+                text "unsat_ok="  <> ppr unsat_ok <> comma <>+                text "boring_ok=" <> ppr boring_ok)+    ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount })+      = hsep [ text "IF_ARGS",+               brackets (hsep (map int cs)),+               int size,+               int discount ]++instance Outputable Unfolding where+  ppr NoUnfolding                = text "No unfolding"+  ppr BootUnfolding              = text "No unfolding (from boot)"+  ppr (OtherCon cs)              = text "OtherCon" <+> ppr cs+  ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args })+       = hang (text "DFun:" <+> char '\\'+                <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow)+            2 (ppr con <+> sep (map ppr args))+  ppr (CoreUnfolding { uf_src = src+                     , uf_tmpl=rhs, uf_is_top=top+                     , uf_cache=cache, uf_guidance=g })+        = text "Unf" <> braces (pp_info $$ pp_rhs)+    where+      pp_info = fsep $ punctuate comma+                [ text "Src="        <> ppr src+                , text "TopLvl="     <> ppr top+                , ppr cache+                , text "Guidance="   <> ppr g ]+      pp_tmpl = ppUnlessOption sdocSuppressUnfoldings+                  (text "Tmpl=" <+> ppr rhs)+      pp_rhs | isStableSource src = pp_tmpl+             | otherwise          = empty+            -- Don't print the RHS or we get a quadratic+            -- blowup in the size of the printout!++instance Outputable UnfoldingCache where+    ppr (UnfoldingCache { uf_is_value = hnf, uf_is_conlike = conlike+                        , uf_is_work_free = wf, uf_expandable = exp })+        = fsep $ punctuate comma+          [ text "Value="      <> ppr hnf+          , text "ConLike="    <> ppr conlike+          , text "WorkFree="   <> ppr wf+          , text "Expandable=" <> ppr exp ]++{-+-----------------------------------------------------+--      Rules+-----------------------------------------------------+-}++instance Outputable CoreRule where+   ppr = pprRule++pprRules :: [CoreRule] -> SDoc+pprRules rules = vcat (map pprRule rules)++pprRule :: CoreRule -> SDoc+pprRule (BuiltinRule { ru_fn = fn, ru_name = name})+  = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name)++pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,+                ru_bndrs = tpl_vars, ru_args = tpl_args,+                ru_rhs = rhs })+  = hang (doubleQuotes (ftext name) <+> ppr act)+       4 (sep [text "forall" <+> pprCoreBinders tpl_vars <> dot,+               nest 2 (ppr fn <+> sep (map pprArg tpl_args)),+               nest 2 (text "=" <+> pprCoreExpr rhs)+            ])++{-+-----------------------------------------------------+--      Tickish+-----------------------------------------------------+-}++instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where+  ppr (HpcTick modl ix) =+      hcat [text "hpc<",+            ppr modl, comma,+            ppr ix,+            text ">"]+  ppr (Breakpoint _ext bid vars) =+      hcat [text "break<",+            ppr (bi_tick_mod bid), comma,+            ppr (bi_tick_index bid),+            text ">",+            parens (hcat (punctuate comma (map ppr vars)))]+  ppr (ProfNote { profNoteCC = cc,+                  profNoteCount = tick,+                  profNoteScope = scope }) =+      case (tick,scope) of+         (True,True)  -> hcat [text "scctick<", ppr cc, char '>']+         (True,False) -> hcat [text "tick<",    ppr cc, char '>']+         _            -> hcat [text "scc<",     ppr cc, char '>']+  ppr (SourceNote span _) =+      hcat [ text "src<", pprUserRealSpan True span, char '>']
+ GHC/Core/Ppr.hs-boot view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.Core.Ppr where++import {-# SOURCE #-} GHC.Core+import {-# SOURCE #-} GHC.Types.Var (Var)+import GHC.Utils.Outputable (OutputableBndr, Outputable)++instance OutputableBndr b => Outputable (Expr b)++instance OutputableBndr Var
+ GHC/Core/Predicate.hs view
@@ -0,0 +1,812 @@+{-# LANGUAGE DerivingStrategies #-}++{-++Describes predicates as they are considered by the solver.++-}++module GHC.Core.Predicate (+  Pred(..), classifyPredType,+  isPredTy, isSimplePredTy,++  -- Equality predicates+  EqRel(..), eqRelRole,+  isEqPred, isReprEqPred, isEqClassPred, isCoVarType,+  getEqPredTys, getEqPredTys_maybe, getEqPredRole,+  predTypeEqRel, pprPredType,+  mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole,++  -- Class predicates+  mkClassPred, isDictTy, typeDeterminesValue,+  isClassPred, isEqualityClass, isCTupleClass, isUnaryClass,+  getClassPredTys, getClassPredTys_maybe,+  classMethodTy, classMethodInstTy,++  -- Implicit parameters+  couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, decomposeIPPred,+  isCallStackTy, isCallStackPred, isCallStackPredTy,+  isExceptionContextPred, isExceptionContextTy,+  isIPPred_maybe,++  -- Evidence variables+  DictId, isEvId, isDictId,++  -- * Well-scoped free variables+  scopedSort, tyCoVarsOfTypeWellScoped,+  tyCoVarsOfTypesWellScoped,++  -- Equality left-hand sides+  CanEqLHS(..), canEqLHS_maybe, canTyFamEqLHS_maybe,+  canEqLHSKind, canEqLHSType, eqCanEqLHS++  ) where++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Class+import GHC.Core.TyCo.Compare( tcEqTyConApps )+import GHC.Core.TyCo.FVs( tyCoVarsOfTypeList, tyCoVarsOfTypesList )+import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk+import GHC.Types.Name( getOccName )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.Multiplicity ( scaledThing )++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Data.FastString+++{- *********************************************************************+*                                                                      *+*                   Pred and PredType                                  *+*                                                                      *+********************************************************************* -}++{- Note [Types for coercions, predicates, and evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "predicate" or "predicate type",+    type synonym `PredType`+    returns True to `isPredTy`+is any type of kind (CONSTRAINT r) for some `r`.++  (a) A "class predicate" (aka dictionary type) is the type of a (boxed)+      type-class dictionary+        Test: isDictTy+        Binders: DictIds+        Kind: Constraint+        Examples: (Eq a), and (a ~ b)++  (b) An "equality predicate" is a primitive, unboxed equalities+        Test: isEqPred+        Binders: CoVars (can appear in coercions)+        Kind: CONSTRAINT (TupleRep [])+        Examples: (t1 ~# t2) or (t1 ~R# t2)++  (c) A "simple predicate type" is either a class predicate or an equality predicate+        Test: isSimplePredTy+        Kind: Constraint or CONSTRAINT (TupleRep [])+        Examples: all coercion types and dictionary types++  (d) A "forall-predicate" is the type of a possibly-polymorphic function+      returning a predicate; e.g.+           forall a. Eq a => Eq [a]++  (e) An "irred predicate" is any other type of kind (CONSTRAINT r),+      typically something like `c` or `c Int`, for some suitably-kinded `c`+++* Predicates are classified by `classifyPredType`.++* Equality types and dictionary types are mutually exclusive.++* Predicates are the things solved by the constraint solver; and+  /evidence terms/ witness those solutions.  An /evidence variable/+  (or EvId) has a type that is a PredType.++* Generally speaking, the /type/ of a predicate determines its /value/;+  that is, predicates are singleton types.  The big exception is implicit+  parameters.  See Note [Type determines value]++* In a FunTy { ft_af = af }, where af = FTF_C_T or FTF_C_C,+  the argument type is always a Predicate type.+-}++-- | A predicate in the solver. The solver tries to prove Wanted predicates+-- from Given ones.+data Pred++  -- | A typeclass predicate.+  = ClassPred Class [Type]++  -- | A type equality predicate, (t1 ~#N t2) or (t1 ~#R t2)+  | EqPred EqRel Type Type++  -- | An irreducible predicate.+  | IrredPred PredType++  -- | A quantified predicate.+  --+  -- See Note [Quantified constraints] in GHC.Tc.Solver.Solve+  | ForAllPred [TyVar] [PredType] PredType++  -- NB: There is no TuplePred case+  --     Tuple predicates like (Eq a, Ord b) are just treated+  --     as ClassPred, as if we had a tuple class with two superclasses+  --        class (c1, c2) => CTuple2 c1 c2++classifyPredType :: HasDebugCallStack => PredType -> Pred+-- Precondition: the argument is a predicate type, with kind (CONSTRAINT _)+classifyPredType ev_ty+  = assertPpr (isPredTy ev_ty) (ppr ev_ty) $+    case splitTyConApp_maybe ev_ty of+      Just (tc, [_, _, ty1, ty2])+        | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2+        | tc `hasKey` eqPrimTyConKey     -> EqPred NomEq  ty1 ty2++      Just (tc, tys)+        | Just clas <- tyConClass_maybe tc+        -> ClassPred clas tys++      _ | (tvs, rho) <- splitForAllTyCoVars ev_ty+        , (theta, pred) <- splitFunTys rho+        , not (null tvs && null theta)+        -> ForAllPred tvs (map scaledThing theta) pred++        | otherwise+        -> IrredPred ev_ty++isSimplePredTy :: HasDebugCallStack => Type -> Bool+-- Return True for (t1 ~# t2) regardless of role, and (C tys)+-- /Not/ true of quantified-predicate type like (forall a. Eq a => Eq [a])+-- Precondition: expects a type that classifies values (i.e. not a type constructor)+-- See Note [Types for coercions, predicates, and evidence]+isSimplePredTy ty+  = case tyConAppTyCon_maybe ty of+       Nothing -> False+       Just tc -> isClassTyCon tc ||+                  tc `hasKey` eqPrimTyConKey ||+                  tc `hasKey` eqReprPrimTyConKey++isPredTy :: Type -> Bool+-- True of all types of kind (CONSTRAINT r) for some `r`+-- See Note [Types for coercions, predicates, and evidence]+--+-- In particular it is True of+--    - the constraints handled by the constraint solver,+--      including quantified constraints+--    - dictionary functions (forall a. Eq a => Eq [a])+isPredTy ty = case typeTypeOrConstraint ty of+                        TypeLike       -> False+                        ConstraintLike -> True++typeDeterminesValue :: PredType -> Bool+-- ^ Is the type *guaranteed* to determine the value?+-- Might say No even if the type does determine the value.+-- See Note [Type determines value]+typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)+++{-+Note [Evidence for quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The superclass mechanism in GHC.Tc.Solver.Dict.makeSuperClasses risks+taking a quantified constraint like+   (forall a. C a => a ~ b)+and generate superclass evidence+   (forall a. C a => a ~# b)++This is a funny thing: neither isPredTy nor isCoVarType are true+of it.  So we are careful not to generate it in the first place:+see Note [Equality superclasses in quantified constraints]+in GHC.Tc.Solver.Dict.+-}++-- --------------------- Equality predicates ---------------------------------++-- | Does this type classify a core (unlifted) Coercion?+-- At either role nominal or representational+--    (t1 ~# t2) or (t1 ~R# t2)+-- See Note [Types for coercions, predicates, and evidence] in "GHC.Core.TyCo.Rep"+isEqPred :: PredType -> Bool+-- True of (s ~# t) (s ~R# t)+-- NB: but NOT true of (s ~ t) or (s ~~ t) or (Coecible s t)+isEqPred ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey+  | otherwise+  = False++isCoVarType :: Type -> Bool+-- Just a synonym for isEqPred+isCoVarType = isEqPred++isReprEqPred :: PredType -> Bool+-- True of (s ~R# t)+isReprEqPred ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` eqReprPrimTyConKey+  | otherwise+  = False++-- --------------------- Class predicates ---------------------------------++mkClassPred :: Class -> [Type] -> PredType+mkClassPred clas tys = mkTyConApp (classTyCon clas) tys++isClassPred :: PredType -> Bool+isClassPred ty = case tyConAppTyCon_maybe ty of+    Just tc -> isClassTyCon tc+    _       -> False++isDictTy :: Type -> Bool+isDictTy = isClassPred++isEqClassPred :: PredType -> Bool+isEqClassPred ty  -- True of (s ~ t) and (s ~~ t)+                  -- ToDo: should we check saturation?+  | Just tc <- tyConAppTyCon_maybe ty+  , Just cls <- tyConClass_maybe tc+  = isEqualityClass cls+  | otherwise+  = False++isEqualityClass :: Class -> Bool+-- True of (~), (~~), and Coercible+-- These all have a single primitive-equality superclass, either (~N# or ~R#)+isEqualityClass cls+  = cls `hasKey` heqTyConKey+    || cls `hasKey` eqTyConKey+    || cls `hasKey` coercibleTyConKey++isCTupleClass :: Class -> Bool+isCTupleClass cls = isTupleTyCon (classTyCon cls)++isUnaryClass :: Class -> Bool+isUnaryClass cls = isUnaryClassTyCon (classTyCon cls)++getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])+getClassPredTys ty = case getClassPredTys_maybe ty of+        Just (clas, tys) -> (clas, tys)+        Nothing          -> pprPanic "getClassPredTys" (ppr ty)++getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])+getClassPredTys_maybe ty = case splitTyConApp_maybe ty of+        Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)+        _ -> Nothing++classMethodTy :: Id -> Type+-- Takes a class selector op :: forall a. C a => meth_ty+-- and returns the type of its method, meth_ty+-- The selector can be a superclass selector, in which case+-- you get back a superclass+classMethodTy sel_id+  = funResultTy $        -- meth_ty+    dropForAlls $        -- C a => meth_ty+    varType sel_id        -- forall a. C n => meth_ty++classMethodInstTy :: Id -> [Type] -> Type+-- Takes a class selector op :: forall a b. C a b => meth_ty+-- and the types [ty1, ty2] at which it is instantiated,+-- returns the instantiated type of its method, meth_ty[t1/a,t2/b]+-- The selector can be a superclass selector, in which case+-- you get back a superclass+classMethodInstTy sel_id arg_tys+  = funResultTy $+    piResultTys (varType sel_id) arg_tys++{- Note [Type determines value]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only specialise on non-impicit-parameter predicates, because these+are the ones whose *type* determines their *value*.  In particular,+with implicit params, the type args *don't* say what the value of the+implicit param is!  See #7101.++So we treat implicit params just like ordinary arguments for the+purposes of specialisation.  Note that we still want to specialise+functions with implicit params if they have *other* dicts which are+class params; see #17930.++It's also not always possible to infer that a type determines the value+if type families are in play. See #19747 for one such example.++-}++-- --------------------- Equality predicates ---------------------------------++-- | A choice of equality relation. This is separate from the type 'Role'+-- because 'Phantom' does not define a (non-trivial) equality relation.+data EqRel = NomEq | ReprEq+  deriving (Eq, Ord)++instance Outputable EqRel where+  ppr NomEq  = text "nominal equality"+  ppr ReprEq = text "representational equality"++eqRelRole :: EqRel -> Role+eqRelRole NomEq  = Nominal+eqRelRole ReprEq = Representational++-- | Creates a primitive nominal type equality predicate.+--      t1 ~# t2+-- Invariant: the types are not Coercions+mkNomEqPred :: Type -> Type -> Type+mkNomEqPred ty1 ty2+  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Creates a primitive representational type equality predicate.+--      t1 ~R# t2+-- Invariant: the types are not Coercions+mkReprEqPred :: Type -> Type -> Type+mkReprEqPred ty1  ty2+  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]+  where+    k1 = typeKind ty1+    k2 = typeKind ty2++-- | Makes a lifted equality predicate at the given role+mkEqPred :: EqRel -> Type -> Type -> PredType+mkEqPred NomEq  = mkNomEqPred+mkEqPred ReprEq = mkReprEqPred++-- | Makes a lifted equality predicate at the given role+mkEqPredRole :: Role -> Type -> Type -> PredType+mkEqPredRole Nominal          = mkNomEqPred+mkEqPredRole Representational = mkReprEqPred+mkEqPredRole Phantom          = panic "mkEqPred phantom"++getEqPredTys :: PredType -> (Type, Type)+getEqPredTys ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        |  tc `hasKey` eqPrimTyConKey+        || tc `hasKey` eqReprPrimTyConKey+        -> (ty1, ty2)+      _ -> pprPanic "getEqPredTys" (ppr ty)++getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type)+getEqPredTys_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, [_, _, ty1, ty2])+        | tc `hasKey` eqPrimTyConKey     -> Just (Nominal, ty1, ty2)+        | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2)+      _ -> Nothing++getEqPredRole :: PredType -> Role+-- Precondition: the PredType is (s ~#N t) or (s ~#R t)+getEqPredRole ty = eqRelRole (predTypeEqRel ty)++-- | Get the equality relation relevant for a pred type+-- Returns NomEq for dictionary predicates, etc+predTypeEqRel :: PredType -> EqRel+predTypeEqRel ty+  | isReprEqPred ty = ReprEq+  | otherwise       = NomEq++pprPredType :: PredType -> SDoc+-- Special case for (t1 ~# t2) and (t1 ~R# t2)+pprPredType pred+  = case classifyPredType pred of+      EqPred eq_rel t1 t2 -> sep [ ppr t1, ppr (getOccName eq_tc) <+> ppr t2 ]+         where+           eq_tc = case eq_rel of+                     NomEq  -> eqPrimTyCon+                     ReprEq -> eqReprPrimTyCon+      _ -> ppr pred++{- *********************************************************************+*                                                                      *+              Implicit parameters+*                                                                      *+********************************************************************* -}++-- --------------------- Nomal implicit-parameter predicates ---------------++isIPTyCon :: TyCon -> Bool+isIPTyCon tc = tc `hasKey` ipClassKey+  -- Class and its corresponding TyCon have the same Unique++isIPClass :: Class -> Bool+isIPClass cls = cls `hasKey` ipClassKey++-- | Decomposes a predicate if it is an implicit parameter. Does not look in+-- superclasses. See also [Local implicit parameters].+isIPPred_maybe :: Class -> [Type] -> Maybe (Type, Type)+isIPPred_maybe cls tys+  | isIPClass cls+  , [t1,t2] <- tys+  = Just (t1,t2)+  | otherwise+  = Nothing++-- | Take a type (IP sym ty), where IP is the built in IP class+-- and return (ip, MkIP, [sym,ty]), where+--    `ip` is the class-op for class IP+--    `MkIP` is the data constructor for class IP+decomposeIPPred :: Type -> (Id, [Type])+decomposeIPPred ty+  | Just (cls, tys) <- getClassPredTys_maybe ty+  , [ip_op] <- classMethods cls+  = assertPpr (isIPClass cls && isUnaryClass cls) (ppr ty) $+    (ip_op, tys)+  | otherwise = pprPanic "decomposeIP" (ppr ty)++-- --------------------- ExceptionContext predicates --------------------------++-- | Is a 'PredType' an @ExceptionContext@ implicit parameter?+--+-- If so, return the name of the parameter.+isExceptionContextPred :: Class -> [Type] -> Maybe FastString+isExceptionContextPred cls tys+  | [ty1, ty2] <- tys+  , isIPClass cls+  , isExceptionContextTy ty2+  = isStrLitTy ty1+  | otherwise+  = Nothing++-- | Is a type an 'ExceptionContext'?+isExceptionContextTy :: Type -> Bool+isExceptionContextTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` exceptionContextTyConKey+  | otherwise+  = False++-- --------------------- CallStack predicates ---------------------------------++isCallStackPredTy :: Type -> Bool+-- True of HasCallStack, or IP "blah" CallStack+isCallStackPredTy ty+  | Just (tc, tys) <- splitTyConApp_maybe ty+  , Just cls <- tyConClass_maybe tc+  , Just {} <- isCallStackPred cls tys+  = True+  | otherwise+  = False++-- | Is a 'PredType' a 'CallStack' implicit parameter?+--+-- If so, return the name of the parameter.+isCallStackPred :: Class -> [Type] -> Maybe FastString+isCallStackPred cls tys+  | [ty1, ty2] <- tys+  , isIPClass cls+  , isCallStackTy ty2+  = isStrLitTy ty1+  | otherwise+  = Nothing++-- | Is a type a 'CallStack'?+isCallStackTy :: Type -> Bool+isCallStackTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` callStackTyConKey+  | otherwise+  = False++-- --------------------- couldBeIPLike and mightMentionIP  --------------------------+--                 See Note [Local implicit parameters]++couldBeIPLike :: Type -> Bool+-- Is `pred`, or any of its superclasses, an implicit parameter?+-- See Note [Local implicit parameters]+couldBeIPLike pred+  = might_mention_ip1 initIPRecTc (const True) (const True) pred++mightMentionIP :: (Type -> Bool) -- ^ predicate on the string+               -> (Type -> Bool) -- ^ predicate on the type+               -> Class+               -> [Type] -> Bool+-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:+--+--    - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@+--      are both @True@,+--    - or any superclass of @cls tys@ has this property.+--+-- See Note [Local implicit parameters]+mightMentionIP = might_mention_ip initIPRecTc++might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool+might_mention_ip rec_clss str_cond ty_cond cls tys+  | Just (str_ty, ty) <- isIPPred_maybe cls tys+  = str_cond str_ty && ty_cond ty+  | otherwise+  = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)+       | sc_sel_id <- classSCSelIds cls ]+++might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool+might_mention_ip1 rec_clss str_cond ty_cond ty+  | Just (cls, tys) <- getClassPredTys_maybe ty+  , let tc = classTyCon cls+  , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss+                      else checkRecTc rec_clss tc+  = might_mention_ip rec_clss' str_cond ty_cond cls tys+  | otherwise+  = False -- Includes things like (D []) where D is+          -- a Constraint-ranged family; #7785++initIPRecTc :: RecTcChecker+initIPRecTc = setRecTcMaxBound 1 initRecTc++{- Note [Local implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in+GHC.Tc.Solver.Dict.++The function couldBeIPLike tells if this predicate, or any of its+superclasses, is an implicit parameter.++Why are implicit parameters special?  Unlike normal classes, we can+have local instances for implicit parameters, in the form of+   let ?x = True in ...+So in various places we must be careful not to assume that any value+of the right type will do; we must carefully look for the innermost binding.+So couldBeIPLike checks whether this is an implicit parameter, or has+a superclass that is an implicit parameter.++Several wrinkles++* We must be careful with superclasses, as #18649 showed.  Haskell+  doesn't allow an implicit parameter as a superclass+    class (?x::a) => C a where ...+  but with a constraint tuple we might have+     (% Eq a, ?x::Int %)+  and /its/ superclasses, namely (Eq a) and (?x::Int), /do/ include an+  implicit parameter.++  With ConstraintKinds this can apply to /any/ class, e.g.+     class sc => C sc where ...+  Then (C (?x::Int)) has (?x::Int) as a superclass.  So we must+  instantiate and check each superclass, one by one, in+  hasIPSuperClasses.++* With -XUndecidableSuperClasses, the superclass hunt can go on forever,+  so we need a RecTcChecker to cut it off.++* Another apparent additional complexity involves type families. For+  example, 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 umbrella 'otherwise' case in is_ip_like_pred.  See #7785.++Small worries (Sept 20):+* I don't see what stops us having that 'type instance'. Indeed I+  think nothing does.+* I'm a little concerned about type variables; such a variable might+  be instantiated to an implicit parameter.  I don't think this+  matters in the cases for which couldBeIPLike is used, and it's pretty+  obscure anyway.+* The superclass hunt stops when it encounters the same class again,+  but in principle we could have the same class, differently instantiated,+  and the second time it could have an implicit parameter+I'm going to treat these as problems for another day. They are all exotic.++Note [Using typesAreApart when calling mightMentionIP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call 'mightMentionIP' in two situations:++  (1) to check that a predicate does not contain any implicit parameters+      IP str ty, for a fixed literal str and any type ty,+  (2) to check that a predicate does not contain any HasCallStack or+      HasExceptionContext constraints.++In both of these cases, we want to be sure, so we should be conservative:++  For (1), the predicate might contain an implicit parameter IP Str a, where+  Str is a type family such as:++    type family MyStr where MyStr = "abc"++  To safeguard against this (niche) situation, instead of doing a simple+  type equality check, we use 'typesAreApart'. This allows us to recognise+  that 'IP MyStr a' contains an implicit parameter of the form 'IP "abc" ty'.++  For (2), we similarly might have++    type family MyCallStack where MyCallStack = CallStack++  Again, here we use 'typesAreApart'. This allows us to see that++    (?foo :: MyCallStack)++  is indeed a CallStack constraint, hidden under a type family.+-}++{- *********************************************************************+*                                                                      *+              Evidence variables+*                                                                      *+********************************************************************* -}++isEvId :: Var -> Bool+isEvId var = isPredTy (varType var)++isDictId :: Id -> Bool+isDictId id = isDictTy (varType id)+++{- *********************************************************************+*                                                                      *+                 scopedSort++       This function lives here becuase it uses isEvId+*                                                                      *+********************************************************************* -}++{- Note [ScopedSort]+~~~~~~~~~~~~~~~~~~~~+Consider++  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()++This function type is implicitly generalised over [a, b, k, k2]. These+variables will be Specified; that is, they will be available for visible+type application. This is because they are written in the type signature+by the user.++However, we must ask: what order will they appear in? In cases without+dependency, this is easy: we just use the lexical left-to-right ordering+of first occurrence. With dependency, we cannot get off the hook so+easily.++We thus state:++ * These variables appear in the order as given by ScopedSort, where+   the input to ScopedSort is the left-to-right order of first occurrence.++Note that this applies only to *implicit* quantification, without a+`forall`. If the user writes a `forall`, then we just use the order given.++ScopedSort is defined thusly (as proposed in #15743):+  * Work left-to-right through the input list, with a cursor.+  * If variable v at the cursor is depended on by any earlier variable w,+    move v immediately before the leftmost such w.++INVARIANT: The prefix of variables before the cursor form a valid telescope.++Note that ScopedSort makes sense only after type inference is done and all+types/kinds are fully settled and zonked.++-}++-- | Do a topological sort on a list of tyvars,+--   so that binders occur before occurrences+-- E.g. given  @[ a::k, k::Type, b::k ]@+-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@.+--+-- This is a deterministic sorting operation+-- (that is, doesn't depend on Uniques).+--+-- It is also meant to be stable: that is, variables should not+-- be reordered unnecessarily. This is specified in Note [ScopedSort]+-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"++scopedSort :: [Var] -> [Var]+scopedSort = go [] []+  where+    go :: [Var] -- already sorted, in reverse order+       -> [TyCoVarSet] -- each set contains all the variables which must be placed+                       -- before the tv corresponding to the set; they are accumulations+                       -- of the fvs in the sorted Var's types++                       -- This list is in 1-to-1 correspondence with the sorted Vars+                       -- INVARIANT:+                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)+                       -- That is, each set in the list is a superset of all later sets.++       -> [Var] -- yet to be sorted+       -> [Var]+    go acc _fv_list [] = reverse acc+    go acc  fv_list (tv:tvs)+      = go acc' fv_list' tvs+      where+        (acc', fv_list') = insert tv acc fv_list++    insert :: Var           -- var to insert+           -> [Var]         -- sorted list, in reverse order+           -> [TyCoVarSet]  -- list of fvs, as above+           -> ([Var], [TyCoVarSet])   -- augmented lists+    -- Generally we put the new Var at the front of the accumulating list+    -- (leading to a stable sort) unless there is are reason to put it later.+    insert v []     []         = ([v], [tyCoVarsOfType (varType v)])+    insert v (a:as) (fvs:fvss)+      | (isTyVar v && isId a) ||          -- TyVars precede Ids+        (isEvId v && isId a && not (isEvId a)) || -- DictIds precede non-DictIds+        (v `elemVarSet` fvs)+          -- (a) put Ids after TyVars, and (b) respect dependencies+      , (as', fvss') <- insert v as fvss+      = (a:as', fvs `unionVarSet` fv_v : fvss')++      | otherwise  -- Put `v` at the front+      = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss)+      where+        fv_v = tyCoVarsOfType (varType v)++       -- lists not in correspondence+    insert _ _ _ = panic "scopedSort"++-- | Get the free vars of a type in scoped order+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList++-- | Get the free vars of types in scoped order+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList+++{- *********************************************************************+*                                                                      *+*                   Equality left-hand sides+*                                                                      *+********************************************************************* -}++-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or /exactly-saturated/ type family application.+data CanEqLHS+  = TyVarLHS TyVar+  | TyFamLHS TyCon  -- ^ TyCon of the family+             [Type]   -- ^ Arguments, /exactly saturating/ the family++instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)++-----------------------------------+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated+-- type family application?+-- Does not look through type synonyms.+canEqLHS_maybe :: Type -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- getTyVar_maybe xi+  = Just $ TyVarLHS tv++  | otherwise+  = canTyFamEqLHS_maybe xi++canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS+canTyFamEqLHS_maybe xi+  | Just (tc, args) <- tcSplitTyConApp_maybe xi+  , isTypeFamilyTyCon tc+  , args `lengthIs` tyConArity tc+  = Just $ TyFamLHS tc args++  | otherwise+  = Nothing++-- | Convert a 'CanEqLHS' back into a 'Type'+canEqLHSType :: CanEqLHS -> Type+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> Kind+canEqLHSKind (TyVarLHS tv) = tyVarKind tv+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args++-- | Are two 'CanEqLHS's equal?+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2+eqCanEqLHS _ _ = False+
+ GHC/Core/Reduction.hs view
@@ -0,0 +1,875 @@++module GHC.Core.Reduction+  (+     -- * Reductions+     Reduction(..), ReductionN, ReductionR, HetReduction(..),+     Reductions(..),+     mkReduction, mkReductions, mkHetReduction, coercionRedn,+     reductionOriginalType,+     downgradeRedn, mkSubRedn,+     mkTransRedn, mkCoherenceRightRedn, mkCoherenceRightMRedn,+     mkCastRedn1, mkCastRedn2,+     mkReflRedn, mkGReflRightRedn, mkGReflRightMRedn,+     mkGReflLeftRedn, mkGReflLeftMRedn,+     mkAppRedn, mkAppRedns, mkFunRedn,+     mkForAllRedn, mkHomoForAllRedn, mkTyConAppRedn, mkClassPredRedn,+     mkProofIrrelRedn, mkReflCoRedn,+     homogeniseHetRedn,+     unzipRedns,++     -- * Rewriting type arguments+     ArgsReductions(..),+     simplifyArgsWorker++  ) where++import GHC.Prelude++import GHC.Core.Class      ( Class(classTyCon) )+import GHC.Core.Coercion+import GHC.Core.Predicate  ( mkClassPred )+import GHC.Core.TyCon      ( TyCon )+import GHC.Core.Type++import GHC.Data.Pair       ( Pair(Pair) )+import GHC.Data.List.Infinite ( Infinite (..) )+import qualified GHC.Data.List.Infinite as Inf++import GHC.Types.Var       ( VarBndr(..), setTyVarKind )+import GHC.Types.Var.Env   ( mkInScopeSet )+import GHC.Types.Var.Set   ( TyCoVarSet )++import GHC.Utils.Misc      ( HasDebugCallStack, equalLength )+import GHC.Utils.Outputable+import GHC.Utils.Panic     ( assertPpr )++{-+%************************************************************************+%*                                                                      *+      Reductions+%*                                                                      *+%************************************************************************++Note [The Reduction type]+~~~~~~~~~~~~~~~~~~~~~~~~~+Many functions in the type-checker rewrite a type, using Given type equalitie+or type-family reductions, and return a Reduction, which is just a pair of the+coercion and the RHS type of the coercion:+  data Reduction = Reduction Coercion !Type++The order of the arguments to the constructor serves as a reminder+of what the Type is.  In+    Reduction co ty+`ty` appears to the right of `co`, reminding us that we must have:+    co :: unrewritten_ty ~ ty++Example functions that use this datatype:+   GHC.Core.FamInstEnv.topNormaliseType_maybe+     :: FamInstEnvs -> Type -> Maybe Reduction+   GHC.Tc.Solver.Rewrite.rewrite+     :: CtEvidence -> TcType -> TcS Reduction++Having Reduction as a data type, with a strict Type field, rather than using+a pair (Coercion,Type) gives several advantages (see #20161)+* The strictness in Type improved performance in rewriting of type families+  (around 2.5% improvement in T9872),+* Compared to the situation before, it gives improved consistency around+  orientation of rewritings, as a Reduction is always left-to-right+  (the coercion's RHS type is always the type stored in the 'Reduction').+  No more 'mkSymCo's needed to convert between left-to-right and right-to-left.++One could imagine storing the LHS type of the coercion in the Reduction as well,+but in fact `reductionOriginalType` is very seldom used, so it's not worth it.+-}++-- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@.+-- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@+-- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined+-- by the context. That is, the LHS type of the coercion is the original type+-- @ty_in@, while its RHS type is the rewritten type @ty_out@.+--+-- A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction',+-- which separately stores the kind coercion.+--+-- See Note [The Reduction type].+data Reduction =+  Reduction+    { reductionCoercion    :: Coercion+    , reductionReducedType :: !Type+    }+-- N.B. the 'Coercion' field must be lazy: see for instance GHC.Tc.Solver.Rewrite.rewrite_tyvar2+-- which returns an error in the 'Coercion' field when dealing with a Derived constraint+-- (which is OK as this Coercion gets ignored later).+-- We might want to revisit the strictness once Deriveds are removed.++-- | Stores a heterogeneous reduction.+--+-- The stored kind coercion must relate the kinds of the+-- stored reduction. That is, in @HetReduction (Reduction co xi) kco@,+-- we must have:+--+-- >  co :: ty ~ xi+-- > kco :: typeKind ty ~ typeKind xi+data HetReduction =+  HetReduction+    Reduction+    MCoercionN+  -- N.B. strictness annotations don't seem to make a difference here++-- | Create a heterogeneous reduction.+--+-- Pre-condition: the provided kind coercion (second argument)+-- relates the kinds of the stored reduction.+-- That is, if the coercion stored in the 'Reduction' is of the form+--+-- > co :: ty ~ xi+--+-- Then the kind coercion supplied must be of the form:+--+-- > kco :: typeKind ty ~ typeKind xi+mkHetReduction :: Reduction  -- ^ heterogeneous reduction+               -> MCoercionN -- ^ kind coercion+               -> HetReduction+mkHetReduction redn mco = HetReduction redn mco+{-# INLINE mkHetReduction #-}++-- | Homogenise a heterogeneous reduction.+--+-- Given @HetReduction (Reduction co xi) kco@, with+--+-- >  co :: ty ~ xi+-- > kco :: typeKind(ty) ~ typeKind(xi)+--+-- this returns the homogeneous reduction:+--+-- > hco :: ty ~ ( xi |> sym kco )+homogeniseHetRedn :: Role -> HetReduction -> Reduction+homogeniseHetRedn role (HetReduction redn kco)+  = mkCoherenceRightMRedn role redn (mkSymMCo kco)+{-# INLINE homogeniseHetRedn #-}++-- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type.+--+-- Pre-condition: the RHS type of the coercion matches the provided type+-- (perhaps up to zonking).+--+-- Use 'coercionRedn' when you only have the coercion.+mkReduction :: Coercion -> Type -> Reduction+mkReduction co ty = Reduction co ty+{-# INLINE mkReduction #-}++instance Outputable Reduction where+  ppr redn =+    braces $ vcat+      [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn)+      , text " reductionReducedType:" <+> ppr (reductionReducedType redn)+      , text "    reductionCoercion:" <+> ppr (reductionCoercion redn)+      ]++-- | A 'Reduction' in which the 'Coercion' has 'Nominal' role.+type ReductionN = Reduction++-- | A 'Reduction' in which the 'Coercion' has 'Representational' role.+type ReductionR = Reduction++-- | Get the original, unreduced type corresponding to a 'Reduction'.+--+-- This is obtained by computing the LHS kind of the stored coercion,+-- which may be slow.+reductionOriginalType :: Reduction -> Type+reductionOriginalType = coercionLKind . reductionCoercion+{-# INLINE reductionOriginalType #-}++-- | Turn a 'Coercion' into a 'Reduction'+-- by inspecting the RHS type of the coercion.+--+-- Prefer using 'mkReduction' when you already know+-- the RHS type of the coercion, to avoid computing it anew.+coercionRedn :: Coercion -> Reduction+coercionRedn co = Reduction co (coercionRKind co)+{-# INLINE coercionRedn #-}++-- | Downgrade the role of the coercion stored in the 'Reduction'.+downgradeRedn :: Role -- ^ desired role+              -> Role -- ^ current role+              -> Reduction+              -> Reduction+downgradeRedn new_role old_role redn@(Reduction co _)+  = redn { reductionCoercion = downgradeRole new_role old_role co }+{-# INLINE downgradeRedn #-}++-- | Downgrade the role of the coercion stored in the 'Reduction',+-- from 'Nominal' to 'Representational'.+mkSubRedn :: Reduction -> Reduction+mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co }+{-# INLINE mkSubRedn #-}++-- | Compose a reduction with a coercion on the left.+--+-- Pre-condition: the provided coercion's RHS type must match the LHS type+-- of the coercion that is stored in the reduction.+mkTransRedn :: Coercion -> Reduction -> Reduction+mkTransRedn co1 redn@(Reduction co2 _)+  = redn { reductionCoercion = co1 `mkTransCo` co2 }+{-# INLINE mkTransRedn #-}++-- | The reflexive reduction.+mkReflRedn :: Role -> Type -> Reduction+mkReflRedn r ty = mkReduction (mkReflCo r ty) ty++-- | Create a 'Reduction' from a kind cast, in which+-- the casted type is the rewritten type.+--+-- Given @ty :: k1@, @mco :: k1 ~ k2@,+-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@+-- at the given 'Role'.+mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction+mkGReflRightRedn role ty co+  = mkReduction+      (mkGReflRightCo role ty co)+      (mkCastTy ty co)+{-# INLINE mkGReflRightRedn #-}++-- | Create a 'Reduction' from a kind cast, in which+-- the casted type is the rewritten type.+--+-- Given @ty :: k1@, @mco :: k1 ~ k2@,+-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@+-- at the given 'Role'.+mkGReflRightMRedn :: Role -> Type -> MCoercionN -> Reduction+mkGReflRightMRedn role ty mco+  = mkReduction+      (mkGReflRightMCo role ty mco)+      (mkCastTyMCo ty mco)+{-# INLINE mkGReflRightMRedn #-}++-- | Create a 'Reduction' from a kind cast, in which+-- the casted type is the original (non-rewritten) type.+--+-- Given @ty :: k1@, @mco :: k1 ~ k2@,+-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@+-- at the given 'Role'.+mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction+mkGReflLeftRedn role ty co+  = mkReduction+      (mkGReflLeftCo role ty co)+      ty+{-# INLINE mkGReflLeftRedn #-}++-- | Create a 'Reduction' from a kind cast, in which+-- the casted type is the original (non-rewritten) type.+--+-- Given @ty :: k1@, @mco :: k1 ~ k2@,+-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@+-- at the given 'Role'.+mkGReflLeftMRedn :: Role -> Type -> MCoercionN -> Reduction+mkGReflLeftMRedn role ty mco+  = mkReduction+      (mkGReflLeftMCo role ty mco)+      ty+{-# INLINE mkGReflLeftMRedn #-}++-- | Apply a cast to the result of a 'Reduction'.+--+-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @kco@+-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@+-- of the given 'Role' (which must match the role of the coercion stored+-- in the 'Reduction' argument).+mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction+mkCoherenceRightRedn r (Reduction co1 ty2) kco+  = mkReduction+      (mkCoherenceRightCo r ty2 kco co1)+      (mkCastTy ty2 kco)+{-# INLINE mkCoherenceRightRedn #-}++-- | Apply a cast to the result of a 'Reduction', using an 'MCoercionN'.+--+-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @mco@+-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@+-- of the given 'Role' (which must match the role of the coercion stored+-- in the 'Reduction' argument).+mkCoherenceRightMRedn :: Role -> Reduction -> MCoercionN -> Reduction+mkCoherenceRightMRedn r (Reduction co1 ty2) kco+  = mkReduction+      (mkCoherenceRightMCo r ty2 kco co1)+      (mkCastTyMCo ty2 kco)+{-# INLINE mkCoherenceRightMRedn #-}++-- | Apply a cast to a 'Reduction', casting both the original and the reduced type.+--+-- Given @cast_co@ and 'Reduction' @ty ~co~> xi@, this function returns+-- the 'Reduction' @(ty |> cast_co) ~return_co~> (xi |> cast_co)@+-- of the given 'Role' (which must match the role of the coercion stored+-- in the 'Reduction' argument).+--+-- Pre-condition: the 'Type' passed in is the same as the LHS type+-- of the coercion stored in the 'Reduction'.+mkCastRedn1 :: Role+            -> Type      -- ^ original type+            -> CoercionN -- ^ coercion to cast with+            -> Reduction -- ^ rewritten type, with rewriting coercion+            -> Reduction+mkCastRedn1 r ty cast_co (Reduction co xi)+  -- co :: ty ~r ty'+  -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co)+  = mkReduction+      (castCoercionKind1 co r ty xi cast_co)+      (mkCastTy xi cast_co)+{-# INLINE mkCastRedn1 #-}++-- | Apply casts on both sides of a 'Reduction' (of the given 'Role').+--+-- Use 'mkCastRedn1' when you want to cast both the original and reduced types+-- in a 'Reduction' using the same coercion.+--+-- Pre-condition: the 'Type' passed in is the same as the LHS type+-- of the coercion stored in the 'Reduction'.+mkCastRedn2 :: Role+            -> Type      -- ^ original type+            -> CoercionN -- ^ coercion to cast with on the left+            -> Reduction -- ^ rewritten type, with rewriting coercion+            -> CoercionN -- ^ coercion to cast with on the right+            -> Reduction+mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co'+  = mkReduction+      (castCoercionKind2 nco r ty nty cast_co cast_co')+      (mkCastTy nty cast_co')+{-# INLINE mkCastRedn2 #-}++-- | Apply one 'Reduction' to another.+--+-- Combines 'mkAppCo' and 'mkAppTy`.+mkAppRedn :: Reduction -> Reduction -> Reduction+mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2)+  = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2)+{-# INLINE mkAppRedn #-}++-- | Create a function 'Reduction'.+--+-- Combines 'mkFunCo' and 'mkFunTy'.+mkFunRedn :: Role+          -> FunTyFlag+          -> ReductionN -- ^ multiplicity reduction+          -> Reduction  -- ^ argument reduction+          -> Reduction  -- ^ result reduction+          -> Reduction+mkFunRedn r af+  (Reduction w_co w_ty)+  (Reduction arg_co arg_ty)+  (Reduction res_co res_ty)+    = mkReduction+        (mkFunCo r af w_co arg_co res_co)+        (mkFunTy   af w_ty arg_ty res_ty)+{-# INLINE mkFunRedn #-}++-- | Create a 'Reduction' associated to a Π type,+-- from a kind 'Reduction' and a body 'Reduction'.+--+-- Combines 'mkForAllCo' and 'mkForAllTy'.+mkForAllRedn :: ForAllTyFlag+             -> TyVar+             -> ReductionN -- ^ kind reduction+             -> Reduction  -- ^ body reduction+             -> Reduction+mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)+  = mkReduction+      (mkForAllCo tv1 vis vis h co)+      (mkForAllTy (Bndr tv2 vis) ty)+  where+    tv2 = setTyVarKind tv1 ki'+{-# INLINE mkForAllRedn #-}++-- | Create a 'Reduction' of a quantified type from a+-- 'Reduction' of the body.+--+-- Combines 'mkHomoForAllCos' and 'mkForAllTys'.+mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction+mkHomoForAllRedn bndrs (Reduction co ty)+  = mkReduction+      (mkHomoForAllCos bndrs co)+      (mkForAllTys bndrs ty)+{-# INLINE mkHomoForAllRedn #-}++-- | Create a 'Reduction' from a coercion between coercions.+--+-- Combines 'mkProofIrrelCo' and 'mkCoercionTy'.+mkProofIrrelRedn :: Role      -- ^ role of the created coercion, "r"+                 -> CoercionN -- ^ co :: phi1 ~N phi2+                 -> Coercion  -- ^ g1 :: phi1+                 -> Coercion  -- ^ g2 :: phi2+                 -> Reduction -- ^ res_co :: g1 ~r g2+mkProofIrrelRedn role co g1 g2+  = mkReduction+      (mkProofIrrelCo role co g1 g2)+      (mkCoercionTy g2)+{-# INLINE mkProofIrrelRedn #-}++-- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion',+-- with the specified 'Role'.+mkReflCoRedn :: Role -> Coercion -> Reduction+mkReflCoRedn role co+  = mkReduction+      (mkReflCo role co_ty)+      co_ty+  where+    co_ty = mkCoercionTy co+{-# INLINE mkReflCoRedn #-}++-- | A collection of 'Reduction's where the coercions and the types are stored separately.+--+-- Use 'unzipRedns' to obtain 'Reductions' from a list of 'Reduction's.+--+-- This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn',+-- which expect separate types and coercions.+--+-- Invariant: the two stored lists are of the same length,+-- and the RHS type of each coercion is the corresponding type.+data Reductions = Reductions [Coercion] [Type]++-- | Create 'Reductions' from individual lists of coercions and types.+--+-- The lists should be of the same length, and the RHS type of each coercion+-- should match the specified type in the other list.+mkReductions :: [Coercion] -> [Type] -> Reductions+mkReductions cos tys = Reductions cos tys+{-# INLINE mkReductions #-}++-- | Combines 'mkAppCos' and 'mkAppTys'.+mkAppRedns :: Reduction -> Reductions -> Reduction+mkAppRedns (Reduction co ty) (Reductions cos tys)+  = mkReduction (mkAppCos co cos) (mkAppTys ty tys)+{-# INLINE mkAppRedns #-}++-- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`.+mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction+mkTyConAppRedn role tc (Reductions cos tys)+  = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys)+{-# INLINE mkTyConAppRedn #-}++-- | Reduce the arguments of a 'Class' 'TyCon'.+mkClassPredRedn :: Class -> Reductions -> Reduction+mkClassPredRedn cls (Reductions cos tys)+  = mkReduction+      (mkTyConAppCo Nominal (classTyCon cls) cos)+      (mkClassPred cls tys)+{-# INLINE mkClassPredRedn #-}++-- | Obtain 'Reductions' from a list of 'Reduction's by unzipping.+unzipRedns :: [Reduction] -> Reductions+unzipRedns = foldr accRedn (Reductions [] [])+  where+    accRedn :: Reduction -> Reductions -> Reductions+    accRedn (Reduction co xi) (Reductions cos xis)+      = Reductions (co:cos) (xi:xis)+{-# INLINE unzipRedns #-}+-- NB: this function is currently used in two locations:+--+-- - GHC.Tc.Gen.Foreign.normaliseFfiType', with one call of the form:+--+--   unzipRedns <$> zipWithM f tys roles+--+-- - GHC.Tc.Solver.Monad.breakTyEqCycle_maybe, with two calls of the form:+--+--   unzipRedns <$> mapM f tys+--+-- It is possible to write 'mapAndUnzipM' functions to handle these cases,+-- but the above locations aren't performance critical, so it was deemed+-- to not be worth it.++{-+%************************************************************************+%*                                                                      *+       Simplifying types+%*                                                                      *+%************************************************************************++The function below morally belongs in GHC.Tc.Solver.Rewrite, but it is used also in+FamInstEnv, and so lives here.++Note [simplifyArgsWorker]+~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant (F2) of Note [Rewriting] in GHC.Tc.Solver.Rewrite says that+rewriting is homogeneous.+This causes some trouble when rewriting a function applied to a telescope+of arguments, perhaps with dependency. For example, suppose++  type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k]++and we wish to rewrite the args of (with kind applications explicit)++  F @a @b (Just @a c) (Right @a @b d) False++where all variables are skolems and++  a :: Type+  b :: Type+  c :: a+  d :: b++  [G] aco :: a ~ fa+  [G] bco :: b ~ fb+  [G] cco :: c ~ fc+  [G] dco :: d ~ fd++The first step is to rewrite all the arguments. This is done before calling+simplifyArgsWorker. We start from++  a+  b+  Just @a c+  Right @a @b d+  False++and get left-to-right reductions whose coercions are as follows:++  co1 :: a ~ fa+  co2 :: b ~ fb+  co3 :: (Just @a c) ~ (Just @fa (fc |> aco) |> co6)+  co4 :: (Right @a @b d) ~ (Right @fa @fb (fd |> bco) |> co7)+  co5 :: False ~ False++where+  co6 = Maybe (sym aco) :: Maybe fa ~ Maybe a+  co7 = Either (sym aco) (sym bco) :: Either fa fb ~ Either a b++We now process the rewritten args in left-to-right order. The first two args+need no further processing. But now consider the third argument. Let f3 = the rewritten+result, Just fa (fc |> aco) |> co6.+This f3 rewritten argument has kind (Maybe a), due to homogeneity of rewriting (F2).+And yet, when we build the application (F @fa @fb ...), we need this+argument to have kind (Maybe fa), not (Maybe a). We must cast this argument.+The coercion to use is determined by the kind of F:+we see in F's kind that the third argument has kind Maybe j.+Critically, we also know that the argument corresponding to j+(in our example, a) rewrote with a coercion co1. We can thus know the+coercion needed for the 3rd argument is (Maybe co1), thus building+(f3 |> Maybe co1)++More generally, we must use the Lifting Lemma, as implemented in+Coercion.liftCoSubst. As we work left-to-right, any variable that is a+dependent parameter (j and k, in our example) gets mapped in a lifting context+to the coercion that is output from rewriting the corresponding argument (co1+and co2, in our example). Then, after rewriting later arguments, we lift the+kind of these arguments in the lifting context that we've be building up.+This coercion is then used to keep the result of rewriting well-kinded.++Working through our example, this is what happens:++  1. Extend the (empty) LC with [j |-> co1]. No new casting must be done,+     because the binder associated with the first argument has a closed type (no+     variables).++  2. Extend the LC with [k |-> co2]. No casting to do.++  3. Lifting the kind (Maybe j) with our LC+     yields co8 :: Maybe a ~ Maybe fa. Use (f3 |> co8) as the argument to F.++  4. Lifting the kind (Either j k) with our LC+     yields co9 :: Either a b ~ Either fa fb. Use (f4 |> co9) as the 4th+     argument to F, where f4 is the rewritten form of argument 4, written above.++  5. We lift Bool with our LC, getting <Bool>; casting has no effect.++We're now almost done, but the new application++  F @fa @fb (f3 |> co8) (f4 |> co9) False++has the wrong kind. Its kind is [fb], instead of the original [b].+So we must use our LC one last time to lift the result kind [k],+getting res_co :: [fb] ~ [b], and we cast our result.++Accordingly, the final result is++  F+    @fa+    @fb+    (Just @fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco)))+    (Right @fa @fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco)))+    False+  |> [sym bco]++The res_co (in this case, [sym bco]) is the third component of the+tuple returned by simplifyArgsWorker.++Note [Last case in simplifyArgsWorker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In writing simplifyArgsWorker's `go`, we know here that args cannot be empty,+because that case is first. We've run out of+binders. But perhaps inner_ki is a tyvar that has been instantiated with a+Π-type.++Here is an example.++  a :: forall (k :: Type). k -> k+  Proxy :: forall j. j -> Type+  type family Star+  axStar :: Star ~ Type+  type family NoWay :: Bool+  axNoWay :: NoWay ~ False+  bo :: Type+  [G] bc :: bo ~ Bool   (in inert set)++  co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)+  co = forall (j :: sym axStar). (<j> -> sym axStar)++  We are rewriting:+  a (forall (j :: Star). (j |> axStar) -> Star)   -- 1+    (Proxy |> co)                                 -- 2+    (bo |> sym axStar)                            -- 3+    (NoWay |> sym bc)                             -- 4+      :: Star++First, we rewrite all the arguments (before simplifyArgsWorker), like so:++    co1 :: (forall (j :: Star). (j |> axStar) -> Star) ~ (forall j. j -> Type) -- 1+    co2 :: (Proxy |> co) ~ (Proxy |> co)                                       -- 2+    co3 :: (bo |> sym axStar) ~ (Bool |> sym axStar)                           -- 3+    co4 :: (NoWay |> sym bc) ~ (False |> sym bc)                               -- 4++Then we do the process described in Note [simplifyArgsWorker].++1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we+   don't use it. But we do build a lifting context [k -> co1] (where co1 is a+   result of rewriting an argument, written above).++2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> co1).+   This is not a dependent argument, so we don't extend the lifting context.++Now we need to deal with argument (3).+The way we normally proceed is to lift the kind of the binder, to see whether+it's dependent.+But here, the remainder of the kind of `a` that we're left with+after processing two arguments is just `k`.++The way forward is look up k in the lifting context, getting co1. If we're at+all well-typed, co1 will be a coercion between Π-types, with at least one binder.+So, let's decompose co1 with decomposePiCos. This decomposition needs arguments to use+to instantiate any kind parameters. Look at the type of co1. If we just+decomposed it, we would end up with coercions whose types include j, which is+out of scope here. Accordingly, decomposePiCos takes a list of types whose+kinds are the *unrewritten* types in the decomposed coercion. (See comments on+decomposePiCos.) Because the rewritten types have unrewritten kinds (because+rewriting is homogeneous), passing the list of rewritten types to decomposePiCos+just won't do: later arguments' kinds won't be as expected. So we need to get+the *unrewritten* types to pass to decomposePiCos. We can do this easily enough+by taking the kind of the argument coercions, passed in originally.++(Alternative 1: We could re-engineer decomposePiCos to deal with this situation.+But that function is already gnarly, and other call sites of decomposePiCos+would suffer from the change, even though they are much more common than this one.)++(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its+behavior into simplifyArgsWorker. This would work, I think, but then all of the+complication of decomposePiCos would end up layered on top of all the complication+here. Please, no.)++(Alternative 3: We could pass the unrewritten arguments into simplifyArgsWorker+so that we don't have to recreate them. But that would complicate the interface+of this function to handle a very dark, dark corner case. Better to keep our+demons to ourselves here instead of exposing them to callers. This decision is+easily reversed if there is ever any performance trouble due to the call of+coercionKind.)++So we now call++  decomposePiCos co1+                 (Pair (forall (j :: Star). (j |> axStar) -> Star) (forall j. j -> Type))+                 [bo |> sym axStar, NoWay |> sym bc]++to get++  co5 :: Star ~ Type+  co6 :: (j |> axStar) ~ (j |> co5), substituted to+                              (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5)+                           == bo ~ bo+  res_co :: Type ~ Star++We then use these casts on (the rewritten) (3) and (4) to get++  (Bool |> sym axStar |> co5 :: Type)   -- (C3)+  (False |> sym bc |> co6    :: bo)     -- (C4)++We can simplify to++  Bool                        -- (C3)+  (False |> sym bc :: bo)     -- (C4)++Of course, we still must do the processing in Note [simplifyArgsWorker] to finish+the job. We thus want to recur. Our new function kind is the left-hand type of+co1 (gotten, recall, by lifting the variable k that was the return kind of the+original function). Why the left-hand type (as opposed to the right-hand type)?+Because we have casted all the arguments according to decomposePiCos, which gets+us from the right-hand type to the left-hand one. We thus recur with that new+function kind, zapping our lifting context, because we have essentially applied+it.++This recursive call returns ([Bool, False], [...], Refl). The Bool and False+are the correct arguments we wish to return. But we must be careful about the+result coercion: our new, rewritten application will have kind Type, but we+want to make sure that the result coercion casts this back to Star. (Why?+Because we started with an application of kind Star, and rewriting is homogeneous.)++So, we have to twiddle the result coercion appropriately.++Let's check whether this is well-typed. We know++  a :: forall (k :: Type). k -> k++  a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type++  a (forall j. j -> Type)+    Proxy+      :: forall j. j -> Type++  a (forall j. j -> Type)+    Proxy+    Bool+      :: Bool -> Type++  a (forall j. j -> Type)+    Proxy+    Bool+    False+      :: Type++  a (forall j. j -> Type)+    Proxy+    Bool+    False+     |> res_co+     :: Star++as desired.++Whew.++Historical note: I (Richard E) once thought that the final part of the kind+had to be a variable k (as in the example above). But it might not be: it could+be an application of a variable. Here is the example:++  let f :: forall (a :: Type) (b :: a -> Type). b (Any @a)+      k :: Type+      x :: k++  rewrite (f @Type @((->) k) x)++After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)`+is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.++-}++-- | Stores 'Reductions' as well as a kind coercion.+--+-- Used when rewriting arguments to a type function @f@.+--+-- Invariant:+--   when the stored reductions are of the form+--     co_i :: ty_i ~ xi_i,+--   the kind coercion is of the form+--      kco :: typeKind (f ty_1 ... ty_n) ~ typeKind (f xi_1 ... xi_n)+--+-- The type function @f@ depends on context.+data ArgsReductions =+  ArgsReductions+    {-# UNPACK #-} !Reductions+    !MCoercionN+  -- The strictness annotations and UNPACK pragma here are crucial+  -- to getting good performance in simplifyArgsWorker's tight loop.++-- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv.+-- See Note [simplifyArgsWorker]+{-# INLINE simplifyArgsWorker #-}+-- NB. INLINE yields a ~1% decrease in allocations in T9872d compared to INLINEABLE+-- This function is only called in two locations, so the amount of code duplication+-- should be rather reasonable despite the size of the function.+simplifyArgsWorker :: HasDebugCallStack+                   => [PiTyBinder] -> Kind+                       -- the binders & result kind (not a Π-type) of the function applied to the args+                       -- list of binders can be shorter or longer than the list of args+                   -> TyCoVarSet   -- free vars of the args+                   -> Infinite Role-- list of roles, r+                   -> [Reduction]  -- rewritten type arguments, arg_i+                                   -- each comes with the coercion used to rewrite it,+                                   -- arg_co_i :: ty_i ~ arg_i+                   -> ArgsReductions+-- Returns ArgsReductions (Reductions cos xis) res_co, where co_i :: ty_i ~ xi_i,+-- and res_co :: kind (f ty_1 ... ty_n) ~ kind (f xi_1 ... xi_n), where f is the function+-- that we are applying.+-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),+-- then (f ty_1 ... ty_n) is well kinded. Note that (f arg_1 ... arg_n) might *not* be well-kinded.+-- Massaging the arg_i in order to make the function application well-kinded is what this+-- function is all about. That is, (f xi_1 ... xi_n), where xi_i are the returned arguments,+-- *is* well kinded.+simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs+                   orig_roles orig_simplified_args+  = go orig_lc+       orig_ki_binders orig_inner_ki+       orig_roles orig_simplified_args+  where+    orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs++    go :: LiftingContext  -- mapping from tyvars to rewriting coercions+       -> [PiTyBinder]    -- Unsubsted binders of function's kind+       -> Kind            -- Unsubsted result kind of function (not a Pi-type)+       -> Infinite Role   -- Roles at which to rewrite these ...+       -> [Reduction]     -- rewritten arguments, with their rewriting coercions+       -> ArgsReductions+    go !lc binders inner_ki _ []+        -- The !lc makes the function strict in the lifting context+        -- which means GHC can unbox that pair.  A modest win.+      = ArgsReductions+          (mkReductions [] [])+          kind_co+      where+        final_kind = mkPiTys binders inner_ki+        kind_co | noFreeVarsOfType final_kind = MRefl+                | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind++    go lc (binder:binders) inner_ki (Inf role roles) (arg_redn:arg_redns)+      =  -- We rewrite an argument ty with arg_redn = Reduction arg_co arg+         -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),+         -- typeKind(ty) = typeKind(arg).+         -- However, it is possible that arg will be used as an argument to a function+         -- whose kind is different, if earlier arguments have been rewritten.+         -- We thus need to compose the reduction with a kind coercion to ensure+         -- well-kindedness (see the call to mkCoherenceRightRedn below).+         --+         -- The bangs here have been observed to improve performance+         -- significantly in optimized builds; see #18502+         let !kind_co = liftCoSubst Nominal lc (piTyBinderType binder)+             !(Reduction casted_co casted_xi)+                      = mkCoherenceRightRedn role arg_redn kind_co+         -- now, extend the lifting context with the new binding+             !new_lc | Just tv <- namedPiTyBinder_maybe binder+                     = extendLiftingContextAndInScope lc tv casted_co+                     | otherwise+                     = lc+             !(ArgsReductions (Reductions cos xis) final_kind_co)+               = go new_lc binders inner_ki roles arg_redns+         in ArgsReductions+              (Reductions (casted_co:cos) (casted_xi:xis))+              final_kind_co++    -- See Note [Last case in simplifyArgsWorker]+    go lc [] inner_ki roles arg_redns+      = let co1 = liftCoSubst Nominal lc inner_ki+            co1_kind              = coercionKind co1+            unrewritten_tys       = map reductionOriginalType arg_redns+            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys+            casted_args           = assertPpr (equalLength arg_redns arg_cos)+                                              (ppr arg_redns $$ ppr arg_cos)+                                  $ zipWith3 mkCoherenceRightRedn (Inf.toList roles) arg_redns arg_cos+               -- In general decomposePiCos can return fewer cos than tys,+               -- but not here; because we're well typed, there will be enough+               -- binders. Note that decomposePiCos does substitutions, so even+               -- if the original substitution results in something ending with+               -- ... -> k, that k will be substituted to perhaps reveal more+               -- binders.+            zapped_lc             = zapLiftingContext lc+            Pair rewritten_kind _ = co1_kind+            (bndrs, new_inner)    = splitPiTys rewritten_kind++            ArgsReductions redns_out res_co_out+              = go zapped_lc bndrs new_inner roles casted_args+        in+          ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)
+ GHC/Core/RoughMap.hs view
@@ -0,0 +1,546 @@+-- | 'RoughMap' is an approximate finite map data structure keyed on+-- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's+-- (e.g. an instance head).+module GHC.Core.RoughMap+  ( -- * RoughMatchTc+    RoughMatchTc(..)+  , isRoughWildcard+  , typeToRoughMatchTc+  , RoughMatchLookupTc(..)+  , typeToRoughMatchLookupTc+  , roughMatchTcToLookup+  , roughMatchTcs+  , roughMatchTcsLookup+  , instanceCantMatch++    -- * RoughMap+  , RoughMap+  , emptyRM+  , lookupRM+  , lookupRM'+  , insertRM+  , filterRM+  , filterMatchingRM+  , elemsRM+  , sizeRM+  , foldRM+  , unionRM+  ) where++import GHC.Prelude++import GHC.Data.Bag+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Utils.Outputable+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName )++import Control.Monad (join)+import Data.Data (Data)+import GHC.Utils.Panic++{-+Note [RoughMap]+~~~~~~~~~~~~~~~+We often want to compute whether one type matches another. That is, given+`ty1` and `ty2`, we want to know whether `ty1` is a substitution instance of `ty2`.++We can bail out early by taking advantage of the following observation:++  If `ty2` is headed by a generative type constructor, say `tc`,+  but `ty1` is not headed by that same type constructor,+  then `ty1` does not match `ty2`.++The idea is that we can use a `RoughMap` as a pre-filter, to produce a+short-list of candidates to examine more closely.++This means we can avoid computing a full substitution if we represent types+as applications of known generative type constructors. So, after type synonym+expansion, we classify application heads into two categories ('RoughMatchTc')++  - `RM_KnownTc tc`: the head is the generative type constructor `tc`,+  - `RM_Wildcard`: anything else.++A (RoughMap val) is semantically a list of (key,[val]) pairs, where+   key :: [RoughMatchTc]+So, writing # for `OtherTc`, and Int for `KnownTc "Int"`, we might have+    [ ([#, Int, Maybe, #, Int], v1)+    , ([Int, #, List], v2 ]++This map is stored as a trie, so looking up a key is very fast.+See Note [Matching a RoughMap] and Note [Simple Matching Semantics] for details on+lookup.++We lookup a key of type [RoughMatchLookupTc], and return the list of all values whose+keys "match":++Given the above map, here are the results of some lookups:+   Lookup key       Result+   -------------------------+   [Int, Int]       [v1,v2] -- Matches because the prefix of both entries matches+   [Int,Int,List]   [v2]+   [Bool]           []++Notice that a single key can map to /multiple/ values.  E.g. if we started+with (Maybe Int, val1) and (Maybe Bool, val2), we'd generate a RoughMap+that is semantically the list   [( Maybe, [val1,val2] )]++Note [RoughMap and beta reduction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is one tricky case we have to account for when matching a rough map due+to Note [Eta reduction for data families] in `GHC.Core.Coercion.Axiom`:+Consider that the user has written a program containing a data family:++> data family Fam a b+> data instance Fam Int a = SomeType  -- known henceforth as FamIntInst++The LHS of this instance will be eta reduced, as described in Note [Eta+reduction for data families]. Consequently, we will end up with a `FamInst`+with `fi_tcs = [KnownTc Int]`. Naturally, we need RoughMap to return this+instance when queried for an instance with template, e.g., `[KnownTc Fam,+KnownTc Int, KnownTc Char]`.++This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics].+As soon as the lookup key runs out, the remaining instances might match.++This only matters for the data-family case of a FamInstEnv (see Note [Over-saturated matches]+in GHC.Core.FamInstEnv; it's irrelevantfor ClsInstEnv and for type-family instances.+But we use RoughMaps for all cases, so we are conservative.++Note [Matching a RoughMap]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The /lookup key/ into a rough map (RoughMatchLookupTc) is slightly+different to the /insertion key/ (RoughMatchTc).  Like the insertion+key each lookup argument is classified to a simpler key which+describes what could match that position. There are three+possibilities:++* RML_KnownTc Name: The argument is headed by a known type+  constructor.  Example: 'Bool' is classified as 'RML_KnownTc Bool'+  and '[Int]' is classified as `RML_KnownTc []`++* RML_NoKnownTc: The argument is definitely not headed by any known+  type constructor.  Example: For instance matching 'a[sk], a[tau]' and 'F a[sk], F a[tau]'+  are classified as 'RML_NoKnownTc', for family instance matching no examples.++* RML_WildCard: The argument could match anything, we don't know+  enough about it. For instance matching no examples, for type family matching,+  things to do with variables.++The interesting case for instance matching is the second case, because it does not appear in+an insertion key. The second case arises in two situations:++1. The head of the application is a type variable. The type variable definitely+   doesn't match with any of the KnownTC instances so we can discard them all. For example:+    Show a[sk] or Show (a[sk] b[sk]). One place constraints like this arise is when+    typechecking derived instances.++2. The head of the application is a known type family.+   For example: F a[sk]. The application of F is stuck, and because+   F is a type family it won't match any KnownTC instance so it's safe to discard+   all these instances.++Of course, these two cases can still match instances of the form `forall a . Show a =>`,+and those instances are retained as they are classified as RM_WildCard instances.++Note [Matches vs Unifiers]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The lookupRM' function returns a pair of potential /matches/ and potential /unifiers/.+The potential matches is likely to be much smaller than the bag of potential unifiers due+to the reasoning about rigid type variables described in Note [Matching a RoughMap].+On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify+with any instance (depending on the substitution of said rigid variable) so they can't be discounted+from the list of potential unifiers. This is achieved by the RML_NoKnownTC case continuing+the lookup for unifiers by replacing RML_NoKnownTC with RML_LookupOtherTC.++This distinction between matches and unifiers is also important for type families.+During normal type family lookup, we care about matches and when checking for consistency+we care about the unifiers. This is evident in the code as `lookup_fam_inst_env` is+parameterised over a lookup function which either performs matching checking or unification+checking.++In addition to this, we only care whether there are zero or non-zero potential+unifiers, even if we have many candidates, the search can stop before consulting+each candidate. We only need the full list of unifiers when displaying error messages.+Therefore the list is computed lazily so much work can be avoided constructing the+list in the first place.++Note [Simple Matching Semantics]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose `rm` is a RoughMap representing a set of (key,vals) pairs,+  where key::[RoughMapTc] and val::a.+Suppose I look up a key lk :: [RoughMapLookupTc] in `rm`+Then I get back (matches, unifiers) where+   matches  = [ vals | (key,vals) <- rm, key `mightMatch` lk ]+   unifiers = [ vals | (key,vals) <- rm, key `mightUnify` lk ]++Where mightMatch is defined like this:++  mightMatch :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool+  mightMatch []  []    = True   -- A perfectly sized match might match+  mightMatch key []    = True   -- A shorter lookup key matches everything+  mightMatch []  (_:_) = True   -- If the lookup key is longer, then still might match+                                -- Note [RoughMap and beta reduction]+  mightMatch (k:ks) (lk:lks) =+    = case (k,lk) of+         -- Standard case, matching on a specific known TyCon.+         (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightMatch ks lks+         -- For example, if the key for 'Show Bool' is [RM_KnownTc Show, RM_KnownTc Bool]+         ---and we match against (Show a[sk]) [RM_KnownTc Show, RML_NoKnownTc]+         -- then Show Bool can never match Show a[sk] so return False.+         (RM_KnownTc _, RML_NoKnownTc)   -> False+         -- Wildcard cases don't inform us anything about the match.+         (RM_WildCard, _ )    -> mightMatch ks lks+         (_, RML_WildCard)    -> mightMatch ks lks++  -- Might unify is very similar to mightMatch apart from RML_NoKnownTc may+  -- unify with any instance.+  mightUnify :: [RoughMapTc] -> [RoughMapLookupTc] -> Bool+  mightUnify []  []    = True   -- A perfectly sized match might unify+  mightUnify key []    = True   -- A shorter lookup key matches everything+  mightUnify []  (_:_) = True+  mightUnify (k:ks) (lk:lks) =+    = case (k,lk) of+         (RM_KnownTc n1, RML_KnownTc n2) -> n1==n2 && mightUnify ks lks+         (RM_KnownTc _, RML_NoKnownTc)   -> mightUnify (k:ks) (RML_WildCard:lks)+         (RM_WildCard, _ )    -> mightUnify ks lks+         (_, RML_WildCard)    -> mightUnify ks lks+++The guarantee that RoughMap provides is that++if+   insert_ty `tcMatchTy` lookup_ty+then definitely+   typeToRoughMatchTc insert_ty `mightMatch` typeToRoughMatchLookupTc lookup_ty+but not vice versa++this statement encodes the intuition that the RoughMap is used as a quick pre-filter+to remove instances from the matching pool. The contrapositive states that if the+RoughMap reports that the instance doesn't match then `tcMatchTy` will report that the+types don't match as well.++-}++{- *********************************************************************+*                                                                      *+                Rough matching+*                                                                      *+********************************************************************* -}++{- Note [Rough matching in class and family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  instance C (Maybe [Tree a]) Bool+and suppose we are looking up+     C Bool Bool++We can very quickly rule the instance out, because the first+argument is headed by Maybe, whereas in the constraint we are looking+up has first argument headed by Bool.  These "headed by" TyCons are+called the "rough match TyCons" of the constraint or instance.+They are used for a quick filter, to check when an instance cannot+possibly match.++The main motivation is to avoid sucking in whole instance+declarations that are utterly useless.  See GHC.Core.InstEnv+Note [ClsInst laziness and the rough-match fields].++INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon,+like Maybe or Either, including a newtype or a data family, both of+which are generative. It replies True to `isGenerativeTyCon tc Nominal`.++But it is never+    - A type synonym+      E.g. Int and (S Bool) might match+           if (S Bool) is a synonym for Int++    - A type family (#19336)+      E.g.   (Just a) and (F a) might match if (F a) reduces to (Just a)+             albeit perhaps only after 'a' is instantiated.+-}+++-- Key for insertion into a RoughMap+data RoughMatchTc+  = RM_KnownTc Name  -- INVARIANT: Name refers to a TyCon tc that responds+                     -- true to `isGenerativeTyCon tc Nominal`. See+                     -- Note [Rough matching in class and family instances]+  | RM_WildCard      -- e.g. type variable at the head+  deriving( Data )++-- Key for lookup into a RoughMap+-- See Note [Matching a RoughMap]+data RoughMatchLookupTc+  = RML_KnownTc Name -- ^ The position only matches the specified KnownTc+  | RML_NoKnownTc    -- ^ The position definitely doesn't match any KnownTc+  | RML_WildCard     -- ^ The position can match anything+  deriving ( Data )++instance Outputable RoughMatchLookupTc where+    ppr (RML_KnownTc nm) = text "RML_KnownTc" <+> ppr nm+    ppr RML_NoKnownTc = text "RML_NoKnownTC"+    ppr RML_WildCard = text "_"++instance Outputable RoughMatchTc where+    ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm+    ppr RM_WildCard = text "OtherTc"++instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool+-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot+-- possibly be instantiated to actual, nor vice versa;+-- False is non-committal+instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as+instanceCantMatch _         _         =  False  -- Safe++itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool+itemCantMatch (RM_KnownTc t) (RM_KnownTc a) = t /= a+itemCantMatch _              _              = False++roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc+roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n+roughMatchTcToLookup RM_WildCard = RML_WildCard++isRoughWildcard :: RoughMatchTc -> Bool+isRoughWildcard RM_WildCard  = True+isRoughWildcard (RM_KnownTc {}) = False++roughMatchTcs :: [Type] -> [RoughMatchTc]+roughMatchTcs tys = map typeToRoughMatchTc tys++roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]+roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys++typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc+typeToRoughMatchLookupTc ty+  -- Expand synonyms first, as explained in Note [Rough matching in class and family instances].+  -- Failing to do so led to #22985.+  | Just ty' <- coreView ty+  = typeToRoughMatchLookupTc ty'+  | CastTy ty' _ <- ty+  = typeToRoughMatchLookupTc ty'+  | otherwise+  = case splitAppTys ty of+        -- Case 1: Head of application is a type variable, does not match any KnownTc.+        (TyVarTy {}, _) -> RML_NoKnownTc++        (TyConApp tc _, _)+          -- Case 2: Head of application is a known type constructor, hence KnownTc.+          | not (isTypeFamilyTyCon tc) -> RML_KnownTc $! roughMatchTyConName tc+          -- Case 3: Head is a type family so it's stuck and therefore doesn't match+          -- any KnownTc+          | isTypeFamilyTyCon tc -> RML_NoKnownTc++        -- Fallthrough: Otherwise, anything might match this position+        _ -> RML_WildCard++typeToRoughMatchTc :: Type -> RoughMatchTc+typeToRoughMatchTc ty+  | Just (ty', _) <- splitCastTy_maybe ty   = typeToRoughMatchTc ty'+  | Just (tc,_)   <- splitTyConApp_maybe ty+  , not (isTypeFamilyTyCon tc)              = RM_KnownTc $! roughMatchTyConName tc+    -- See Note [Rough matching in class and family instances]+  | otherwise                               = RM_WildCard++roughMatchTyConName :: TyCon -> Name+roughMatchTyConName tc+  | tc_name == cONSTRAINTTyConName+  = tYPETyConName  -- TYPE and CONSTRAINT are not apart, so they must use+                   -- the same rough-map key. We arbitrarily use TYPE.+                   -- See Note [Type and Constraint are not apart]+                   -- wrinkle (W1) in GHC.Builtin.Types.Prim+  | otherwise+  = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name+  where+    tc_name = tyConName tc+++-- | Trie of @[RoughMatchTc]@+--+-- *Examples*+-- @+-- insert [OtherTc] 1+-- insert [OtherTc] 2+-- lookup [OtherTc] == [1,2]+-- @+data RoughMap a+  = RMEmpty -- An optimised (finite) form of emptyRM+            -- Invariant: Empty RoughMaps are always represented with RMEmpty++  | RM { rm_empty :: Bag a+           -- Keyed by an empty [RoughMapTc]++       , rm_known :: DNameEnv (RoughMap a)+           -- Keyed by (RM_KnownTc tc : rm_tcs)+           -- DNameEnv: see Note [InstEnv determinism] in GHC.Core.InstEnv++       , rm_wild :: RoughMap a }+           -- Keyed by (RM_WildCard : rm_tcs)+  deriving (Functor)++instance Outputable a => Outputable (RoughMap a) where+  ppr (RM empty known unknown) =+      vcat [text "RM"+           , nest 2 (vcat [ text "Empty:" <+> ppr empty+                          , text "Known:" <+> ppr known+                          , text "Unknown:" <+> ppr unknown])]+  ppr RMEmpty = text "{}"++emptyRM :: RoughMap a+emptyRM = RMEmpty++-- | Order of result is deterministic.+lookupRM :: [RoughMatchLookupTc] -> RoughMap a -> [a]+lookupRM tcs rm = bagToList (fst $ lookupRM' tcs rm)+++-- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists+-- we find in 'rm_empty', which would otherwise be necessary due to '++' if we+-- returned a list. We use a list for unifiers because the tail is computed lazily and+-- we often only care about the first couple of potential unifiers. Constructing a+-- bag forces the tail which performs much too much work.+--+-- See Note [Matching a RoughMap]+-- See Note [Matches vs Unifiers]+lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches+                                                   , [a]) -- Potential unifiers+lookupRM' _ RMEmpty   -- The RoughMap is empty+  = (emptyBag, [])++lookupRM' [] rm       -- See Note [Simple Matching Semantics] about why+  = (listToBag m, m)  -- we return everything when the lookup key runs out+  where+    m = elemsRM rm++lookupRM' (RML_KnownTc tc : tcs) rm  =+  let (common_m, common_u) = lookupRM' tcs (rm_wild rm)+      (m, u) = maybe (emptyBag, []) (lookupRM' tcs) (lookupDNameEnv (rm_known rm) tc)+  in ( rm_empty rm `unionBags` common_m `unionBags` m+     , bagToList (rm_empty rm) ++ common_u ++ u)++-- A RML_NoKnownTC does **not** match any KnownTC but can unify+lookupRM' (RML_NoKnownTc : tcs) rm =+  let (u_m, _u_u) = lookupRM' tcs (rm_wild rm)+  in ( rm_empty rm `unionBags` u_m -- Definitely don't match+     , snd $ lookupRM' (RML_WildCard : tcs) rm) -- But could unify..++lookupRM' (RML_WildCard : tcs)    rm  =+--  pprTrace "RM wild" (ppr tcs $$ ppr (eltsDNameEnv (rm_known rm))) $+  let (m, u)     = foldDNameEnv add_one (emptyBag, []) (rm_known rm)+      (u_m, u_u) = lookupRM' tcs (rm_wild rm)+  in ( rm_empty rm `unionBags` u_m `unionBags` m+     , bagToList (rm_empty rm) ++ u_u ++ u )+  where+     add_one :: RoughMap a -> (Bag a, [a]) -> (Bag a, [a])+     add_one rm ~(m2, u2) = (m1 `unionBags` m2, u1 ++ u2)+                          where+                            (m1,u1) = lookupRM' tcs rm++unionRM :: RoughMap a -> RoughMap a -> RoughMap a+unionRM RMEmpty a = a+unionRM a RMEmpty = a+unionRM a b =+  RM { rm_empty = rm_empty a `unionBags` rm_empty b+     , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b)+     , rm_wild = rm_wild a `unionRM` rm_wild b+     }+++insertRM :: [RoughMatchTc] -> a -> RoughMap a -> RoughMap a+insertRM k v RMEmpty =+    insertRM k v $ RM { rm_empty = emptyBag+                      , rm_known = emptyDNameEnv+                      , rm_wild = emptyRM }+insertRM [] v rm@(RM {}) =+    -- See Note [Simple Matching Semantics]+    rm { rm_empty = v `consBag` rm_empty rm }++insertRM (RM_KnownTc k : ks) v rm@(RM {}) =+    rm { rm_known = alterDNameEnv f (rm_known rm) k }+  where+    f Nothing  = Just $ (insertRM ks v emptyRM)+    f (Just m) = Just $ (insertRM ks v m)++insertRM (RM_WildCard : ks) v rm@(RM {}) =+    rm { rm_wild = insertRM ks v (rm_wild rm) }++filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a+filterRM _ RMEmpty = RMEmpty+filterRM pred rm =+    normalise $ RM {+      rm_empty = filterBag pred (rm_empty rm),+      rm_known = mapDNameEnv (filterRM pred) (rm_known rm),+      rm_wild = filterRM pred (rm_wild rm)+    }++-- | Place a 'RoughMap' in normal form, turning all empty 'RM's into+-- 'RMEmpty's. Necessary after removing items.+normalise :: RoughMap a -> RoughMap a+normalise RMEmpty = RMEmpty+normalise (RM empty known RMEmpty)+  | isEmptyBag empty+  , isEmptyDNameEnv known = RMEmpty+normalise rm = rm++-- | Filter all elements that might match a particular key with the given+-- predicate.+filterMatchingRM :: (a -> Bool) -> [RoughMatchTc] -> RoughMap a -> RoughMap a+filterMatchingRM _    _  RMEmpty = RMEmpty+filterMatchingRM pred [] rm      = filterRM pred rm+filterMatchingRM pred (RM_KnownTc tc : tcs) rm =+    normalise $ RM {+      rm_empty = filterBag pred (rm_empty rm),+      rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc,+      rm_wild = filterMatchingRM pred tcs (rm_wild rm)+    }+filterMatchingRM pred (RM_WildCard : tcs) rm =+    normalise $ RM {+      rm_empty = filterBag pred (rm_empty rm),+      rm_known = mapDNameEnv (filterMatchingRM pred tcs) (rm_known rm),+      rm_wild = filterMatchingRM pred tcs (rm_wild rm)+    }++dropEmpty :: RoughMap a -> Maybe (RoughMap a)+dropEmpty RMEmpty = Nothing+dropEmpty rm = Just rm++elemsRM :: RoughMap a -> [a]+elemsRM = foldRM (:) []++foldRM :: (a -> b -> b) -> b -> RoughMap a -> b+foldRM f = go+  where+    -- N.B. local worker ensures that the loop can be specialised to the fold+    -- function.+    go z RMEmpty = z+    go z (RM{ rm_wild = unk, rm_known = known, rm_empty = empty}) =+      foldr+        f+        (foldDNameEnv+           (flip go)+           (go z unk)+           known+        )+        empty++nonDetStrictFoldRM :: (b -> a -> b) -> b -> RoughMap a -> b+nonDetStrictFoldRM f = go+  where+    -- N.B. local worker ensures that the loop can be specialised to the fold+    -- function.+    go !z RMEmpty = z+    go  z rm@(RM{}) =+      foldl'+        f+        (nonDetStrictFoldDNameEnv+           (flip go)+           (go z (rm_wild rm))+           (rm_known rm)+        )+        (rm_empty rm)++sizeRM :: RoughMap a -> Int+sizeRM = nonDetStrictFoldRM (\acc _ -> acc + 1) 0
+ GHC/Core/Rules.hs view
@@ -0,0 +1,2027 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[CoreRules]{Rewrite rules}+-}+++-- | Functions for collecting together and applying rewrite rules to a module.+-- The 'CoreRule' datatype itself is declared elsewhere.+module GHC.Core.Rules (+        -- ** Looking up rules+        lookupRule, matchExprs, ruleLhsIsMoreSpecific,++        -- ** RuleBase, RuleEnv+        RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,+        updExternalPackageRules, addLocalRules, updLocalRules,+        emptyRuleBase, mkRuleBase, extendRuleBaseList,+        pprRuleBase,++        -- ** Checking rule applications+        ruleCheckProgram,++        -- ** Manipulating 'RuleInfo' rules+        extendRuleInfo, addRuleInfo,+        addIdSpecialisations, addRulesToId,++        -- ** RuleBase and RuleEnv++        -- * Misc. CoreRule helpers+        rulesOfBinds, getRules, pprRulesForUser,++        -- * Making rules+        mkRule, mkSpecRule, roughTopNames,+        ruleIsOrphan++    ) where++import GHC.Prelude++import GHC.Unit.Module   ( Module )+import GHC.Unit.Module.Env+import GHC.Unit.Module.ModGuts( ModGuts(..) )+import GHC.Unit.Module.Deps( Dependencies(..) )++import GHC.Driver.DynFlags( DynFlags )+import GHC.Driver.Ppr( showSDoc )++import GHC.Core         -- All of it+import GHC.Core.Subst+import GHC.Core.SimpleOpt ( exprIsLambda_maybe )+import GHC.Core.FVs       ( exprFreeVars, bindFreeVars+                          , rulesFreeVarsDSet, orphNamesOfExprs )+import GHC.Core.Utils     ( exprType, mkTick, mkTicks+                          , stripTicksTopT, stripTicksTopE+                          , isJoinBind, mkCastMCo )+import GHC.Core.Ppr       ( pprRules )+import GHC.Core.Unify as Unify ( ruleMatchTyKiX )+import GHC.Core.Type as Type+   ( Type, extendTvSubst, extendCvSubst+   , substTy, getTyVar_maybe )+import GHC.Core.TyCo.Ppr( pprParendType )+import GHC.Core.Coercion as Coercion+import GHC.Core.Tidy     ( tidyRules )+import GHC.Core.Map.Expr ( eqCoreExpr )+import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )+import GHC.Core.Make     ( mkCoreLams )+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )++import GHC.Tc.Utils.TcType  ( tcSplitTyConApp_maybe )+import GHC.Builtin.Types    ( anyTypeOfKind )++import GHC.Types.Id+import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name    ( Name, NamedThing(..), nameIsLocalOrFrom )+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Name.Occurrence( occNameFS )+import GHC.Types.Unique.FM+import GHC.Types.Tickish+import GHC.Types.Basic++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.Bag+import GHC.Data.List.SetOps( hasNoDups )++import GHC.Utils.FV( filterFV, fvVarSet )+import GHC.Utils.Misc as Utils+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)++import Data.List (sortBy, mapAccumL, isPrefixOf)+import Data.Function    ( on )+import Control.Monad    ( guard )++{-+Note [Overall plumbing for rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* After the desugarer:+   - The ModGuts initially contains mg_rules :: [CoreRule] of+     locally-declared rules for imported Ids.+   - Locally-declared rules for locally-declared Ids are attached to+     the IdInfo for that Id.  See Note [Attach rules to local ids] in+     GHC.HsToCore.Binds++* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to+  mg_rules, so that the ModGuts has *all* the locally-declared rules.++* The HomePackageTable contains a ModDetails for each home package+  module.  Each contains md_rules :: [CoreRule] of rules declared in+  that module.  The HomePackageTable grows as ghc --make does its+  up-sweep.  In batch mode (ghc -c), the HPT is empty; all imported modules+  are treated by the "external" route, discussed next, regardless of+  which package they come from.++* The ExternalPackageState has a single eps_rule_base :: RuleBase for+  Ids in other packages.  This RuleBase simply grow monotonically, as+  ghc --make compiles one module after another.++  During simplification, interface files may get demand-loaded,+  as the simplifier explores the unfoldings for Ids it has in+  its hand.  (Via an unsafePerformIO; the EPS is really a cache.)+  That in turn may make the EPS rule-base grow.  In contrast, the+  HPT never grows in this way.++* The result of all this is that during Core-to-Core optimisation+  there are four sources of rules:++    (a) Rules in the IdInfo of the Id they are a rule for.  These are+        easy: fast to look up, and if you apply a substitution then+        it'll be applied to the IdInfo as a matter of course.++    (b) Rules declared in this module for imported Ids, kept in the+        ModGuts. If you do a substitution, you'd better apply the+        substitution to these.  There are seldom many of these.++    (c) Rules declared in the HomePackageTable.  These never change.++    (d) Rules in the ExternalPackageTable. These can grow in response+        to lazy demand-loading of interfaces.++* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad.+  The HomePackageTable doesn't have a single RuleBase because technically+  we should only be able to "see" rules "below" this module; so we+  generate a RuleBase for (c) by combining rules from all the modules+  "below" us.  That's why we can't just select the home-package RuleBase+  from HscEnv.++  [NB: we are inconsistent here.  We should do the same for external+  packages, but we don't.  Same for type-class instances.]++* So in the outer simplifier loop (simplifyPgmIO), we combine (b & c) into a single+  RuleBase, reading+     (b) from the ModGuts,+     (c) from the GHC.Core.Opt.Monad, and+  just before doing rule matching we read+     (d) from its mutable variable+  and combine it with the results from (b & c).++  In a single simplifier run new rules can be added into the EPS so it matters+  to keep an up-to-date view of which rules have been loaded. For examples of+  where this went wrong and caused cryptic performance regressions+  see T19790 and !6735.+++************************************************************************+*                                                                      *+\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}+*                                                                      *+************************************************************************++A CoreRule holds details of one rule for an Id, which+includes its specialisations.++For example, if a rule for f is+   RULE "f" forall @a @b d. f @(List a) @b d = f' a b++then when we find an application of f to matching types, we simply replace+it by the matching RHS:+        f (List Int) Bool dict ===>  f' Int Bool+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+Rule contains a template for the result of the specialisation.+-}++mkRule :: Module -> Bool -> Bool -> RuleName -> Activation+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule+-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being+-- compiled. See also 'GHC.Core.CoreRule'+mkRule this_mod is_auto is_local name act fn bndrs args rhs+  = Rule { ru_name   = name+         , ru_act    = act+         , ru_fn     = fn+         , ru_bndrs  = bndrs+         , ru_args   = args+         , ru_rhs    = occurAnalyseExpr rhs+                       -- See Note [OccInfo in unfoldings and rules]+         , ru_rough  = roughTopNames args+         , ru_origin = this_mod+         , ru_orphan = orph+         , ru_auto   = is_auto+         , ru_local  = is_local }+  where+        -- Compute orphanhood.  See Note [Orphans] in GHC.Core.InstEnv+        -- A rule is an orphan only if none of the variables+        -- mentioned on its left-hand side are locally defined+    lhs_names = extendNameSet (orphNamesOfExprs args) fn++        -- Since rules get eventually attached to one of the free names+        -- from the definition when compiling the ABI hash, we should make+        -- it deterministic. This chooses the one with minimal OccName+        -- as opposed to uniq value.+    local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names+    orph = chooseOrphanAnchor local_lhs_names++--------------+mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc+           -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule+-- Make a specialisation rule, for Specialise or SpecConstr+mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs+  = case idJoinPointHood fn of+      JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule+      NotJoinPoint         -> rule+  where+    rule = mkRule this_mod is_auto is_local+                  rule_name+                  inl_act       -- Note [Auto-specialisation and RULES]+                  (idName fn)+                  bndrs args rhs++    is_local = isLocalId fn+    rule_name = mkSpecRuleName dflags herald fn args++mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString+mkSpecRuleName dflags herald fn args+  = mkFastString $ showSDoc dflags $+    herald <+> ftext (occNameFS (getOccName fn))+                     -- This name ends up in interface files, so use occNameFS.+                     -- Otherwise uniques end up there, making builds+                     -- less deterministic (See #4012 comment:61 ff)+           <+> hsep (mapMaybe ppr_call_key_ty args)+  where+    ppr_call_key_ty :: CoreExpr -> Maybe SDoc+    ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of+                                  Just {} -> Just (text "@_")+                                  Nothing -> Just $ char '@' <> pprParendType ty+    ppr_call_key_ty _ = Nothing+++--------------+roughTopNames :: [CoreExpr] -> [Maybe Name]+-- ^ Find the \"top\" free names of several expressions.+-- Such names are either:+--+-- 1. The function finally being applied to in an application chain+--    (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or+--+-- 2. The 'TyCon' if the expression is a 'Type'+--+-- This is used for the fast-match-check for rules;+--      if the top names don't match, the rest can't+roughTopNames args = map roughTopName args++roughTopName :: CoreExpr -> Maybe Name+roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of+                               Just (tc,_) -> Just (getName tc)+                               Nothing     -> Nothing+roughTopName (Coercion _) = Nothing+roughTopName (App f _) = roughTopName f+roughTopName (Var f)   | isGlobalId f   -- Note [Care with roughTopName]+                       , isDataConWorkId f || idArity f > 0+                       = Just (idName f)+roughTopName (Tick t e) | tickishFloatable t+                        = roughTopName e+roughTopName _ = Nothing++ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@+-- definitely can't match @tpl@ by instantiating @tpl@.+-- It's only a one-way match; unlike instance matching we+-- don't consider unification.+--+-- Notice that [_$_]+--      @ruleCantMatch [Nothing] [Just n2] = False@+--      Reason: a template variable can be instantiated by a constant+-- Also:+--      @ruleCantMatch [Just n1] [Nothing] = False@+--      Reason: a local variable @v@ in the actuals might [_$_]++ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as+ruleCantMatch (_       : ts) (_       : as) = ruleCantMatch ts as+ruleCantMatch _              _              = False++{-+Note [Care with roughTopName]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+    module M where { x = a:b }+    module N where { ...f x...+                     RULE f (p:q) = ... }+You'd expect the rule to match, because the matcher can+look through the unfolding of 'x'.  So we must avoid roughTopName+returning 'M.x' for the call (f x), or else it'll say "can't match"+and we won't even try!!++However, suppose we have+         RULE g (M.h x) = ...+         foo = ...(g (M.k v))....+where k is a *function* exported by M.  We never really match+functions (lambdas) except by name, so in this case it seems like+a good idea to treat 'M.k' as a roughTopName of the call.+-}++pprRulesForUser :: [CoreRule] -> SDoc+-- (a) tidy the rules+-- (b) sort them into order based on the rule name+-- (c) suppress uniques (unless -dppr-debug is on)+-- This combination makes the output stable so we can use in testing+-- It's here rather than in GHC.Core.Ppr because it calls tidyRules+pprRulesForUser rules+  = withPprStyle defaultUserStyle $+    pprRules $+    sortBy (lexicalCompareFS `on` ruleName) $+    tidyRules emptyTidyEnv rules++{-+************************************************************************+*                                                                      *+                RuleInfo: the rules in an IdInfo+*                                                                      *+************************************************************************+-}++extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo+extendRuleInfo (RuleInfo rs1 fvs1) rs2+  = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)++addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo+addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)+  = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)++addIdSpecialisations :: Id -> [CoreRule] -> Id+addIdSpecialisations id rules+  | null rules+  = id+  | otherwise+  = setIdSpecialisation id $+    extendRuleInfo (idSpecialisation id) rules++addRulesToId :: RuleBase -> Id -> Id+-- Add rules in the RuleBase to the rules in the Id+addRulesToId rule_base bndr+  | Just rules <- lookupNameEnv rule_base (idName bndr)+  = bndr `addIdSpecialisations` rules+  | otherwise+  = bndr++-- | Gather all the rules for locally bound identifiers from the supplied bindings+rulesOfBinds :: [CoreBind] -> [CoreRule]+rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds+++{-+************************************************************************+*                                                                      *+                RuleBase+*                                                                      *+************************************************************************+-}++-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules+type RuleBase = NameEnv [CoreRule]+        -- The rules are unordered;+        -- we sort out any overlaps on lookup++emptyRuleBase :: RuleBase+emptyRuleBase = emptyNameEnv++mkRuleBase :: [CoreRule] -> RuleBase+mkRuleBase rules = extendRuleBaseList emptyRuleBase rules++extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase+extendRuleBaseList rule_base new_guys+  = foldl' extendRuleBase rule_base new_guys++extendRuleBase :: RuleBase -> CoreRule -> RuleBase+extendRuleBase rule_base rule+  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule++pprRuleBase :: RuleBase -> SDoc+pprRuleBase rules = pprUFM rules $ \rss ->+  vcat [ pprRules (tidyRules emptyTidyEnv rs)+       | rs <- rss ]++-- | A full rule environment which we can apply rules from.  Like a 'RuleBase',+-- but it also includes the set of visible orphans we use to filter out orphan+-- rules which are not visible (even though we can see them...)+-- See Note [Orphans] in GHC.Core+data RuleEnv+    = RuleEnv { re_local_rules   :: !RuleBase -- Rules from this module+              , re_home_rules    :: !RuleBase -- Rule from the home package+                                              --   (excl this module)+              , re_eps_rules     :: !RuleBase -- Rules from other packages+                                              --   see Note [External package rules]+              , re_visible_orphs :: !ModuleSet+              }++mkRuleEnv :: ModGuts -> RuleBase -> RuleBase -> RuleEnv+mkRuleEnv (ModGuts { mg_module = this_mod+                   , mg_deps   = deps+                   , mg_rules  = local_rules })+          eps_rules hpt_rules+  = RuleEnv { re_local_rules   = mkRuleBase local_rules+            , re_home_rules    = hpt_rules+            , re_eps_rules     = eps_rules+            , re_visible_orphs = mkModuleSet vis_orphs }+  where+    vis_orphs = this_mod : dep_orphs deps++updExternalPackageRules :: RuleEnv -> RuleBase -> RuleEnv+-- Completely over-ride the external rules in RuleEnv+updExternalPackageRules rule_env eps_rules+  = rule_env { re_eps_rules = eps_rules }++updLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv+-- Completely over-ride the local rules in RuleEnv+updLocalRules rule_env local_rules+  = rule_env { re_local_rules = mkRuleBase local_rules }++addLocalRules :: RuleEnv -> [CoreRule] -> RuleEnv+-- Add new local rules+addLocalRules rule_env rules+  = rule_env { re_local_rules = extendRuleBaseList (re_local_rules rule_env) rules }++emptyRuleEnv :: RuleEnv+emptyRuleEnv = RuleEnv { re_local_rules   = emptyNameEnv+                       , re_home_rules    = emptyNameEnv+                       , re_eps_rules     = emptyNameEnv+                       , re_visible_orphs = emptyModuleSet }++getRules :: RuleEnv -> Id -> [CoreRule]+-- Given a RuleEnv and an Id, find the visible rules for that Id+-- See Note [Where rules are found]+--+-- This function is quite heavily used, so it's worth trying to make it efficient+getRules (RuleEnv { re_local_rules   = local_rule_base+                  , re_home_rules    = home_rule_base+                  , re_eps_rules     = eps_rule_base+                  , re_visible_orphs = orphs }) fn++  | Just {} <- isDataConId_maybe fn   -- Short cut for data constructor workers+  = []                                -- and wrappers, which never have any rules++  | Just export_flag <- isLocalId_maybe fn+  = -- LocalIds can't have rules in the local_rule_base (used for imported fns)+    -- nor external packages; but there can (just) be rules in another module+    -- in the home package, if it is exported+    case export_flag of+      NotExported -> idCoreRules fn+      Exported -> case get home_rule_base of+          []           -> idCoreRules fn+          home_rules   -> drop_orphs home_rules ++ idCoreRules fn++  | otherwise+  = -- This case expression is a fast path, to avoid calling the+    -- recursive (++) in the common case where there are no rules at all+    case (get local_rule_base, get home_rule_base, get eps_rule_base) of+      ([], [], [])                         -> idCoreRules fn+      (local_rules, home_rules, eps_rules) -> local_rules           +++                                              drop_orphs home_rules +++                                              drop_orphs eps_rules  +++                                              idCoreRules fn+  where+    fn_name = idName fn+    drop_orphs [] = []  -- Fast path; avoid invoking recursive filter+    drop_orphs xs = filter (ruleIsVisible orphs) xs+    get rb = lookupNameEnv rb fn_name `orElse` []++ruleIsVisible :: ModuleSet -> CoreRule -> Bool+ruleIsVisible _ BuiltinRule{} = True+ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }+    = notOrphan orph || origin `elemModuleSet` vis_orphs++ruleIsOrphan :: CoreRule -> Bool+ruleIsOrphan (BuiltinRule {})            = False+ruleIsOrphan (Rule { ru_orphan = orph }) = isOrphan orph++{- Note [Where rules are found]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rules for an Id come from two places:+  (a) the ones it is born with, stored inside the Id itself (idCoreRules fn),+  (b) rules added in other modules, stored in the global RuleBase (imp_rules)++It's tempting to think that+     - LocalIds have only (a)+     - non-LocalIds have only (b)++but that isn't quite right:++     - PrimOps and ClassOps are born with a bunch of rules inside the Id,+       even when they are imported++     - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even+       in the module defining the Id (when it's a LocalId), but+       the rules are kept in the global RuleBase++ Note [External package rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Note [Overall plumbing for rules], it is explained that the final+RuleBase which we must consider is combined from 4 different sources.++During simplifier runs, the fourth source of rules is constantly being updated+as new interfaces are loaded into the EPS. Therefore just before we check to see+if any rules match we get the EPS RuleBase and combine it with the existing RuleBase+and then perform exactly 1 lookup into the new map.++It is more efficient to avoid combining the environments and store the uncombined+environments as we can instead perform 1 lookup into each environment and then combine+the results.++Essentially we use the identity:++> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)+>   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2++The latter being more efficient as we don't construct an intermediate+map.+-}++{-+************************************************************************+*                                                                      *+                        Matching+*                                                                      *+************************************************************************+-}++-- | The main rule matching function. Attempts to apply all (active)+-- supplied rules to this instance of an application in a given+-- context, returning the rule applied and the resulting expression if+-- successful.+lookupRule :: HasDebugCallStack+           => RuleOpts -> InScopeEnv+           -> (Activation -> Bool)      -- When rule is active+           -> Id -- Function head+           -> [CoreExpr] -- Args+           -> [CoreRule] -- Rules+           -> Maybe (CoreRule, CoreExpr)++-- See Note [Extra args in the target]+-- See comments on matchRule+lookupRule opts rule_env@(ISE in_scope _) is_active fn args rules+  = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $+    case go [] rules of+        []     -> Nothing+        (m:ms) -> Just (findBest in_scope (fn,args') m ms)+  where+    rough_args = map roughTopName args++    -- Strip ticks from arguments, see Note [Tick annotations in RULE+    -- matching]. We only collect ticks if a rule actually matches -+    -- this matters for performance tests.+    args' = map (stripTicksTopE tickishFloatable) args+    ticks = concatMap (stripTicksTopT tickishFloatable) args++    go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]+    go ms [] = ms+    go ms (r:rs)+      | Just e <- matchRule opts rule_env is_active fn args' rough_args r+      = go ((r,mkTicks ticks e):ms) rs+      | otherwise+      = -- pprTrace "match failed" (ppr r $$ ppr args $$+        --   ppr [ (arg_id, maybeUnfoldingTemplate unf)+        --       | Var arg_id <- args+        --       , let unf = idUnfolding arg_id+        --       , isCheapUnfolding unf] )+        go ms rs++findBest :: InScopeSet -> (Id, [CoreExpr])+         -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)+-- All these pairs matched the expression+-- Return the pair the most specific rule+-- The (fn,args) is just for overlap reporting++findBest _        _      (rule,ans)   [] = (rule,ans)+findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)+  | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs+  | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs+  | debugIsOn = let pp_rule rule+                      = ifPprDebug (ppr rule)+                                   (doubleQuotes (ftext (ruleName rule)))+                in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"+                         (vcat [ whenPprDebug $+                                 text "Expression to match:" <+> ppr fn+                                 <+> sep (map ppr args)+                               , text "Rule 1:" <+> pp_rule rule1+                               , text "Rule 2:" <+> pp_rule rule2]) $+                findBest in_scope target (rule1,ans1) prs+  | otherwise = findBest in_scope target (rule1,ans1) prs+  where+    (fn,args) = target++ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool+-- The call (rule1 `ruleIsMoreSpecific` rule2)+-- sees if rule2 can be instantiated to look like rule1+-- See Note [ruleIsMoreSpecific]+ruleIsMoreSpecific in_scope rule1 rule2+  = case rule1 of+       BuiltinRule {} -> False+       Rule { ru_bndrs = bndrs1, ru_args = args1 }+                      -> ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2++ruleLhsIsMoreSpecific :: InScopeSet+                      -> [Var] -> [CoreExpr]  -- LHS of a possible new rule+                      -> CoreRule             -- An existing rule+                      -> Bool                 -- New one is more specific+ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2+  = case rule2 of+       BuiltinRule {} -> True+       Rule { ru_bndrs = bndrs2, ru_args = args2 }+                      -> isJust (matchExprs in_scope_env bndrs2 args2 args1)+  where+   full_in_scope = in_scope `extendInScopeSetList` bndrs1+   in_scope_env  = ISE full_in_scope noUnfoldingFun+                   -- noUnfoldingFun: don't expand in templates++noBlackList :: Activation -> Bool+noBlackList _ = False           -- Nothing is black listed++{- Note [ruleIsMoreSpecific]+~~~~~~~~~~~~~~~~~~~~~~~~+The call (rule1 `ruleIsMoreSpecific` rule2)+sees if rule2 can be instantiated to look like rule1.++Wrinkle:++* We take the view that a BuiltinRule is less specific than+  anything else, because we want user-defined rules to "win"+  In particular, class ops have a built-in rule, but we+  prefer any user-specific rules to win:+    eg (#4397)+       truncate :: (RealFrac a, Integral b) => a -> b+       {-# RULES "truncate/Double->Int" truncate = double2Int #-}+       double2Int :: Double -> Int+  We want the specific RULE to beat the built-in class-op rule++Note [Extra args in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find a matching rule, we return (Just (rule, rhs)),+/but/ the rule firing has only consumed as many of the input args+as the ruleArity says.  The unused arguments are handled by the code in+GHC.Core.Opt.Simplify.tryRules, using the arity of the returned rule.++E.g. Rule "foo":  forall a b.  f p1 p2 = rhs+     Target:      f e1 e2 e3++Then lookupRule returns Just (Rule "foo", rhs), where Rule "foo"+has ruleArity 2.  The real rewrite is+        f e1 e2 e3 ==> rhs e3++You might think it'd be cleaner for lookupRule to deal with the+leftover arguments, by applying 'rhs' to them, but the main call+in the Simplifier works better as it is.  Reason: the 'args' passed+to lookupRule are the result of a lazy substitution++Historical note:++At one stage I tried to match even if there are more args in the+/template/ than the target.  I now think this is probably a bad idea.+Should the template (map f xs) match (map g)?  I think not.  For a+start, in general eta expansion wastes work.  SLPJ July 99+-}++------------------------------------+matchRule :: HasDebugCallStack+          => RuleOpts -> InScopeEnv -> (Activation -> Bool)+          -> Id -> [CoreExpr] -> [Maybe Name]+          -> CoreRule -> Maybe CoreExpr++-- If (matchRule rule args) returns Just (name,rhs)+-- then (f args) matches the rule, and the corresponding+-- rewritten RHS is rhs+--+-- The returned expression is occurrence-analysed+--+--      Example+--+-- The rule+--      forall f g x. map f (map g x) ==> map (f . g) x+-- is stored+--      CoreRule "map/map"+--               [f,g,x]                -- tpl_vars+--               [f,map g x]            -- tpl_args+--               map (f.g) x)           -- rhs+--+-- Then the expression+--      map e1 (map e2 e3) e4+-- results in a call to+--      matchRule the_rule [e1,map e2 e3,e4]+--        = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)+--+-- NB: The 'surplus' argument e4 in the input is simply dropped.+-- See Note [Extra args in the target]++matchRule opts rule_env _is_active fn args _rough_args+          (BuiltinRule { ru_try = match_fn })+-- Built-in rules can't be switched off, it seems+  = case match_fn opts rule_env fn args of+        Nothing   -> Nothing+        Just expr -> Just expr++matchRule _ rule_env is_active _ args rough_args+          (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops+                , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })+  | not (is_active act)               = Nothing+  | ruleCantMatch tpl_tops rough_args = Nothing+  | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs+++---------------------------------------+matchN  :: HasDebugCallStack+        => InScopeEnv+        -> RuleName -> [Var] -> [CoreExpr]+        -> [CoreExpr] -> CoreExpr           -- ^ Target; can have more elements than the template+        -> Maybe CoreExpr+-- For a given match template and context, find bindings to wrap around+-- the entire result and what should be substituted for each template variable.+--+-- Fail if there are too few actual arguments from the target to match the template+--+-- See Note [Extra args in the target]+-- If there are too /many/ actual arguments, we simply ignore the+-- trailing ones, returning the result of applying the rule to a prefix+-- of the actual arguments.++matchN ise _rule_name tmpl_vars tmpl_es target_es rhs+  = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es+       ; return (bind_wrapper $+                 mkLams tmpl_vars rhs `mkApps` matched_es) }++matchExprs :: HasDebugCallStack+           => InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]+           -> Maybe (BindWrapper, [CoreExpr])  -- 1-1 with the [Var]+matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es+  = do  { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es+        ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)+                                          (mkEmptySubst in_scope) $+                                tmpl_vars `zip` tmpl_vars1++        ; let bind_wrapper = rs_binds rule_subst+                             -- Floated bindings; see Note [Matching lets]++        ; return (bind_wrapper, matched_es) }+  where+    (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars+                  -- See Note [Cloning the template binders]++    init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1+                   , rv_lcl   = init_rn_env+                   , rv_fltR  = mkEmptySubst (rnInScopeSet init_rn_env)+                   , rv_unf   = id_unf }++    lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr)+                   -- Need to return a RuleSubst solely for the benefit of fake_ty+    lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })+                tcv_subst (tmpl_var, tmpl_var1)+        | isId tmpl_var1+        = case lookupVarEnv id_subst tmpl_var1 of+            Just e | Coercion co <- e+                   -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)+                   | otherwise+                   -> (tcv_subst, e)+            Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1+                    , let co = Coercion.substCo tcv_subst refl_co+                    -> -- See Note [Unbound RULE binders]+                       (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)+                    | otherwise+                    -> unbound tmpl_var++        | otherwise+        = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty')+        where+          ty' = case lookupVarEnv tv_subst tmpl_var1 of+                  Just ty -> ty+                  Nothing -> fake_ty   -- See Note [Unbound RULE binders]+          fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1))+                    -- This substitution is the sole reason we accumulate+                    -- TCvSubst in lookup_tmpl++    unbound tmpl_var+       = pprPanic "Template variable unbound in rewrite rule" $+         vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)+              , text "Rule bndrs:" <+> ppr tmpl_vars+              , text "LHS args:" <+> ppr tmpl_es+              , text "Actual args:" <+> ppr target_es ]++----------------------+match_exprs :: HasDebugCallStack+            => RuleMatchEnv -> RuleSubst+            -> [CoreExpr]       -- Templates+            -> [CoreExpr]       -- Targets+            -> Maybe RuleSubst+-- If the targets are longer than templates, succeed, simply ignoring+-- the leftover targets. This matters in the call in matchN.+--+-- Precondition: corresponding elements of es1 and es2 have the same+--               type, assuming earlier elements match.+-- Example:  f :: forall v. v -> blah+--   match_exprs [Type a, y::a] [Type Int, 3]+-- Then, after matching Type a against Type Int,+-- the type of (y::a) matches that of (3::Int)+match_exprs _ subst [] _+  = Just subst+match_exprs renv subst (e1:es1) (e2:es2)+  = do { subst' <- match renv subst e1 e2 MRefl+       ; match_exprs renv subst' es1 es2 }+match_exprs _ _ _ _ = Nothing+++{- Note [Unbound RULE binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be the case that the binder in a rule is not actually+bound on the LHS:++* Type variables.  Type synonyms with phantom args can give rise to+  unbound template type variables.  Consider this (#10689,+  simplCore/should_compile/T10689):++    type Foo a b = b++    f :: Eq a => a -> Bool+    f x = x==x++    {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}+    finkle = f 'c'++  The rule looks like+    forall (a::*) (d::Eq Char) (x :: Foo a Char).+         f @(Foo a Char) d x = True++  Matching the rule won't bind 'a', and legitimately so.  We fudge by+  pretending that 'a' is bound to (Any :: *).++* Coercion variables.  On the LHS of a RULE for a local binder+  we might have+    RULE forall (c :: a~b). f (x |> c) = e+  Now, if that binding is inlined, so that a=b=Int, we'd get+    RULE forall (c :: Int~Int). f (x |> c) = e+  and now when we simplify the LHS (Simplify.simplRule) we+  optCoercion (look at the CoVarCo case) will turn that 'c' into Refl:+    RULE forall (c :: Int~Int). f (x |> <Int>) = e+  and then perhaps drop it altogether.  Now 'c' is unbound.++  It's tricky to be sure this never happens, so instead I+  say it's OK to have an unbound coercion binder in a RULE+  provided its type is (c :: t~t).  Then, when the RULE+  fires we can substitute <t> for c.++  This actually happened (in a RULE for a local function)+  in #13410, and also in test T10602.++Note [Cloning the template binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following match (example 1):+        Template:  forall x.  f x+        Target:               f (x+1)+This should succeed, because the template variable 'x' has nothing to+do with the 'x' in the target.++Likewise this one (example 2):+        Template:  forall x. f (\x.x)+        Target:              f (\y.y)++We achieve this simply by using rnBndrL to clone the template+binders if they are already in scope.++------ Historical note -------+At one point I tried simply adding the template binders to the+in-scope set /without/ cloning them, but that failed in a horribly+obscure way in #14777.  Problem was that during matching we look+up target-term variables in the in-scope set (see Note [Lookup+in-scope]).  If a target-term variable happens to name-clash with a+template variable, that lookup will find the template variable, which+is /utterly/ bogus.  In #14777, this transformed a term variable+into a type variable, and then crashed when we wanted its idInfo.+------ End of historical note -------+++************************************************************************+*                                                                      *+                   The main matcher+*                                                                      *+********************************************************************* -}++data RuleMatchEnv+  = RV { rv_lcl   :: RnEnv2          -- Renamings for *local bindings*+                                     --   (lambda/case)+       , rv_tmpls :: VarSet          -- Template variables+                                     --   (after applying envL of rv_lcl)+       , rv_fltR  :: Subst           -- Renamings for floated let-bindings+                                     --   (domain disjoint from envR of rv_lcl)+                                     -- See Note [Matching lets]+                                     -- N.B. The InScopeSet of rv_fltR is always ignored;+                                     -- see (4) in Note [Matching lets].+       , rv_unf :: IdUnfoldingFun+       }++{- Note [rv_lcl in RuleMatchEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider matching+  Template: \x->f+  Target:   \f->f++where 'f' is free in the template. When we meet the lambdas we must+remember to rename f :-> f' in the target, as well as x :-> f+in the template.  The rv_lcl::RnEnv2 does that.++Similarly, consider matching+     Template: {a}  \b->b+     Target:        \a->3+We must rename the \a.  Otherwise when we meet the lambdas we might+substitute [b :-> a] in the template, and then erroneously succeed in+matching what looks like the template variable 'a' against 3.++So we must add the template vars to the in-scope set before starting;+see `init_menv` in `matchN`.+-}++-- * The domain of the TvSubstEnv and IdSubstEnv are the template+--   variables passed into the match.+--+-- * The BindWrapper in a RuleSubst are the bindings floated out+--   from nested matches; see the Let case of match, below+--+data RuleSubst = RS { -- Substitution; applied only to the template, not the target+                      -- Domain is the template variables+                      -- Range never includes template variables+                      rs_tv_subst :: TvSubstEnv+                    , rs_id_subst :: IdSubstEnv++                      -- Floated bindings+                    , rs_binds    :: BindWrapper  -- Floated bindings+                    , rs_bndrs    :: [Var]        -- Variables bound by floated lets+                    }++type BindWrapper = CoreExpr -> CoreExpr+  -- See Notes [Matching lets] and [Matching cases]+  -- we represent the floated bindings as a core-to-core function++emptyRuleSubst :: RuleSubst+emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv+                    , rs_binds = \e -> e, rs_bndrs = [] }+++{- Note [Casts in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As far as possible we don't want casts in the target to get in the way of+matching.  E.g.+* (let bind in e)  |> co+* (case e of alts) |> co+* (\ a b. f a b)   |> co++In the first two cases we want to float the cast inwards so we can match on+the let/case.  This is not important in practice because the Simplifier does+this anyway.++But the third case /is/ important: we don't want the cast to get in the way+of eta-reduction.  See Note [Cancel reflexive casts] for a real life example.++The most convenient thing is to make 'match' take an MCoercion argument, thus:++* The main matching function+      match env subst template target mco+  matches   template ~ (target |> mco)++* Invariant: typeof( subst(template) ) = typeof( target |> mco )++Note that for applications+     (e1 e2) ~ (d1 d2) |> co+where 'co' is non-reflexive, we simply fail.  You might wonder about+     (e1 e2) ~ ((d1 |> co1) d2) |> co2+but the Simplifer pushes the casts in an application to to the+right, if it can, so this doesn't really arise.++Note [Casts in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note concerns `matchTemplateCast`.  Consider the definition+  f x = e,+and SpecConstr on call pattern+  f ((e1,e2) |> co)++The danger is that We'll make a RULE+   RULE forall a,b,g.  f ((a,b)|> g) = $sf a b g+   $sf a b g = e[ ((a,b)|> g) / x ]++This requires the rule-matcher to bind the coercion variable `g`.+That is Very Deeply Suspicious:++* It would be unreasonable to match on a structured coercion in a pattern,+  such as    RULE   forall g.  f (x |> Sym g) = ...+  because the strucure of a coercion is arbitrary and may change -- it's their+  /type/ that matters.++* We considered insisting that in a template, in a cast (e |> co), the the cast+  `co` is always a /variable/ cv.  That looks a bit more plausible, but #23209+  (and related tickets) shows that it's very fragile.  For example suppose `e`+  is a variable `f`, and the simplifier has an unconditional substitution+     [f :-> g |> co2]+  Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more!++In short, it is Very Deeply Suspicious for a rule to quantify over a coercion+variable.  And SpecConstr no longer does so: see Note [SpecConstr and casts] in+SpecConstr.++Wrinkles:++(CT0) It is, however, OK for a cast to appear in a template provided the cast mentions+  none of the template variables.  For example+      newtype N a = MkN (a,a)    -- Axiom ax:N a :: (a,a) ~R N a+      f :: N a -> bah+      RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ...+  When matching we can just move these casts to the other side:+      match (tmpl |> co) tgt  -->   match tmpl (tgt |> sym co)+  See matchTemplateCast.++(CT1) We need to be careful about scoping, and to match left-to-right, so that we+  know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we+  can apply that substitition++(CT2) Annoyingly, we still want support one case in which the RULE quantifies+  over a coercion variable: the dreaded map/coerce RULE.+  See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.++  Since that can happen, matchTemplateCast laboriously checks whether the+  coercion mentions a template coercion variable; and if so does the Very Deeply+  Suspicious `match_co` instead.  It works fine for map/coerce, where the+  coercion is always a variable and will (robustly) remain so.++See also+* Note [Coercion arguments]+* Note [Matching coercion variables] in GHC.Core.Unify.+* Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils:+  sm_cast_swizzle is switched off in the template of a RULE++Note [Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~+What if we have (f (Coercion co)) in the template, where the 'co' is a coercion+argument to f?  Right now we have nothing in place to ensure that a+coercion /argument/ in the template is a variable.  We really should,+perhaps by abstracting over that variable.++C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.++For now, though, we simply behave badly, by failing in match_co.+We really should never rely on matching the structure of a coercion+(which is just a proof).+-}++----------------------+match :: HasDebugCallStack+      => RuleMatchEnv+      -> RuleSubst              -- Substitution applies to template only+      -> CoreExpr               -- Template+      -> CoreExpr               -- Target+      -> MCoercion+      -> Maybe RuleSubst++-- Postcondition (TypeInv): if matching succeeds, then+--                          typeof( subst(template) ) = typeof( target |> mco )+--     But this is /not/ a pre-condition! The types of template and target+--     may differ, see the (App e1 e2) case+--+-- Invariant (CoInv):   if mco :: ty ~ ty, then it is MRefl, not MCo co+--                      See Note [Cancel reflexive casts]+--+-- See the notes with Unify.match, which matches types+-- Everything is very similar for terms+++------------------------ Ticks ---------------------+-- We look through certain ticks. See Note [Tick annotations in RULE matching]+match renv subst e1 (Tick t e2) mco+  | tickishFloatable t+  = match renv subst' e1 e2 mco+  | otherwise+  = Nothing+  where+    subst' = subst { rs_binds = rs_binds subst . mkTick t }++match renv subst e@(Tick t e1) e2 mco+  | tickishFloatable t  -- Ignore floatable ticks in rule template.+  =  match renv subst e1 e2 mco+  | otherwise+  = pprPanic "Tick in rule" (ppr e)++------------------------ Types ---------------------+match renv subst (Type ty1) (Type ty2) _mco+  = match_ty renv subst ty1 ty2++------------------------ Coercions ---------------------+-- See Note [Coercion arguments] for why this isn't really right+match renv subst (Coercion co1) (Coercion co2) MRefl+  = match_co renv subst co1 co2+  -- The MCo case corresponds to matching  co ~ (co2 |> co3)+  -- and I have no idea what to do there -- or even if it can occur+  -- Failing seems the simplest thing to do; it's certainly safe.++------------------------ Casts ---------------------+-- See Note [Casts in the template]+--     Note [Casts in the target]+--     Note [Cancel reflexive casts]++match renv subst e1 (Cast e2 co2) mco+  = match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoR co2 mco))+    -- checkReflexiveMCo: cancel casts if possible+    -- This is important: see Note [Cancel reflexive casts]++match renv subst (Cast e1 co1) e2 mco+  = matchTemplateCast renv subst e1 co1 e2 mco++------------------------ Literals ---------------------+match _ subst (Lit lit1) (Lit lit2) mco+  | lit1 == lit2+  = assertPpr (isReflMCo mco) (ppr mco) $+    Just subst++------------------------ Variables ---------------------+-- The Var case follows closely what happens in GHC.Core.Unify.match+match renv subst (Var v1) e2 mco+  = match_var renv subst v1 (mkCastMCo e2 mco)++match renv subst e1 (Var v2) mco  -- Note [Expanding variables]+  | not (inRnEnvR rn_env v2)      -- Note [Do not expand locally-bound variables]+  , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')+  = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' mco+  where+    v2'    = lookupRnInScope rn_env v2+    rn_env = rv_lcl renv+        -- Notice that we look up v2 in the in-scope set+        -- See Note [Lookup in-scope]+        -- No need to apply any renaming first (hence no rnOccR)+        -- because of the not-inRnEnvR++------------------------ Applications ---------------------+-- See Note [Matching higher order patterns]+match renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env })+      subst  e1@App{} e2+      MRefl               -- Like the App case we insist on Refl here+                          -- See Note [Casts in the target]+  | (Var f, args) <- collectArgs e1+  , let f' = rnOccL rn_env f   -- See similar rnOccL in match_var+  , f' `elemVarSet` tmpls                     -- (HOP1)+  , Just vs2 <- traverse arg_as_lcl_var args  -- (HOP2), (HOP3)+  , hasNoDups vs2                             -- (HOP4)+  , not can_decompose_app_instead+  = match_tmpl_var renv subst f' (mkCoreLams vs2 e2)+    -- match_tmpl_var checks (HOP5) and (HOP6)+  where+    arg_as_lcl_var :: CoreExpr -> Maybe Var+    arg_as_lcl_var (Var v)+      | Just v' <- rnOccL_maybe rn_env v+      , not (v' `elemVarSet` tmpls)  -- rnEnvL contains the template variables+      = Just (to_target v')          -- to_target: see (W1)+                                     --   in Note [Matching higher order patterns]+    arg_as_lcl_var _ = Nothing++    can_decompose_app_instead -- Template (e1 v), target (e2 v), and v # fvs(e2)+      = case (e1, e2) of      -- See (W2) in Note [Matching higher order patterns]+           (App _ (Var v1), App f2 (Var v2))+             -> rnOccL rn_env v1 == rnOccR rn_env v2+                && not (v2 `elemVarSet` exprFreeVars f2)+           _ -> False++    ----------------+    -- to_target: see (W1) in Note [Matching higher order patterns]+    to_target :: Var -> Var   -- From canonical variable back to target-expr variable+    to_target v = lookupVarEnv rev_envR v `orElse` v++    rev_envR :: VarEnv Var   -- Inverts rnEnvR: from canonical variable+                             -- back to target-expr variable+    rev_envR = nonDetStrictFoldVarEnv_Directly add_one emptyVarEnv (rnEnvR rn_env)+    add_one uniq var env = extendVarEnv env var (var `setVarUnique` uniq)++{- Note [Matching higher order patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Higher order patterns provide a limited form of higher order matching.+See GHC Proposal #555+  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0555-template-patterns.rst+and #22465 for more details and related work.++Consider the potential match:++   Template: forall f. foo (\x -> f x)+   Target:             foo (\x -> x*2 + x)++The expression `x*2 + x` in the target is not literally an application of a+function to the variable `x`, so the simple application rule does not apply.+However, we can match them modulo beta equivalence with the substitution:++   [f :-> \x -> x*2 + x]++The general problem of higher order matching is tricky to implement, but+the subproblem which we call /higher order pattern matching/ is sufficient+for the given example and much easier to implement.++Design:++We start with terminology.++* /Template variables/. The forall'd variables are called the template+  variables. In the example match above, `f` is a template variable.++* /Local binders/. The local binders of a rule are the variables bound+  inside the template. In the example match above, `x` is a local binder.+  Note that local binders can be term variables and type variables.++A /higher order pattern/ (HOP) is a sub-expression of the template,+of form (f x y z) where:++* (HOP1) f is a template variable+* (HOP2) x, y, z are local binders (like y in rule "wombat" above; see definitions).+* (HOP3) The arguments x, y, z are term variables+* (HOP4) The arguments x, y, z are distinct (no duplicates)++Matching of higher order patterns (HOP-matching). A higher order pattern (f x y z)+(in the template) matches any target expression e provided:++* (HOP5) The target has the same type as the template+* (HOP6) No local binder is free in e, other than x, y, z.++If these two condition hold, the higher order pattern (f x y z) matches+the target expression e, yielding the substitution [f :-> \x y z. e].+Notice that this substitution is type preserving, and the RHS+of the substitution has no free local binders.++HOP matching is small enough to be done in-line in the `match` function.+Two wrinkles:++(W1) Consider the potential match:+        Template:    forall f. foo (\x -> f x)+        Target:                foo (\y -> (y, y))+     During matching we make `x` the canonical variable for the lambdas+     and then we see:+        Template:    f x       rnEnvL = []+        Target:      (y, y)    rnEnvR = [y :-> x]+     We could bind [f :-> \x. (x,x)], by applying rnEnvR substitution to the target+     expression.  But that is tiresome (a) because it involves a traversal, and+     (b) because rnEnvR is a VarEnv Var, and we don't have a substitution function+     for that.++     So instead, we invert rnEnvR, and apply it to the binders, to get+     [f :-> \y. (y,y)].  This is done by `to_target` in the HOP-matching case.+     It takes a little bit of thinking to be sure this will work right in the case+     of shadowing.  E.g.  Template (\x y. f x y)   Target  (\p p. p*p)+     Here rnEnvR will be just [p :-> y], so after inversion we'll get+          [f :-> \x p. p*p]+     but that is fine.++(W2) This wrinkle concerns the overlap between the new HOP rule and the existing+     decompose-application rule.  See 3.1 of GHC Proposal #555 for a discussion.++     Consider potential match:+        Template: forall f.   foo (\x y. Just (f y x))+        Target:               foo (\p q. Just (h (1+q) p)))+     During matching we will encounter:+        Template:    f x y+        Target:      h (1+q) p    rnEnvR = [p:->x, q:->y]+     The rnEnvR renaming `[p:->x, q:->y]` is done by the matcher (today) on the fly,+     to make the bound variables of the template and target "line up".+     But now we can:+     * Either use the new HOP rule to succeed with+          [f :-> \x y. h (1+x) y]+     * Or use the existing decompose-application rule to match+          (f x) against (h (1+q)) and `y` against `p`.+       This will succeed with+          [f :-> \y. h (1+y)]++     Note that the result of the HOP rule will always be eta-equivalent to+     the result of the decompose-application rule.  But the proposal specifies+     that we should use the decompose-application rule because it involves+     less eta-expansion.++     But take care:+        Template: forall f.   foo (\x y. Just (f y x))+        Target:               foo (\p q. Just (h (p+q) p)))+     Then during matching we will encounter:+        Template:    f x y+        Target:      h (p+q) p      rnEnvR = [p:->x, q:->y]+     Now, we cannot use the decompose-application rule, because p is free in+     (h (p+q)). So, we can only use the new HOP rule.++(W3) You might wonder if a HOP can have /type/ arguments, thus (in Core)+        RULE forall h.+             f (\(MkT @b (d::Num b) (x::b)) -> h @b d x) = ...+     where the HOP is (h @b d x). In principle this might be possible, but+     it seems fragile; e.g. we would still need to insist that the (invisible)+     @b was a type variable.  And since `h` gets a polymorphic type, that+     type would have to be declared by the programmer.++     Maybe one day.  But for now, we insist (in `arg_as_lcl_var`)that a HOP+     has only term-variable arguments.+-}++-- Note the match on MRefl!  We fail if there is a cast in the target+--     (e1 e2) ~ (d1 d2) |> co+-- See Note [Cancel reflexive casts]: in the Cast equations for 'match'+-- we aggressively ensure that if MCo is reflective, it really is MRefl.+match renv subst (App f1 a1) (App f2 a2) MRefl+  = do  { subst' <- match renv subst f1 f2 MRefl+        ; match renv subst' a1 a2 MRefl }++------------------------ Float lets ---------------------+match renv subst e1 (Let bind e2) mco+  | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $+    not (isJoinBind bind) -- can't float join point out of argument position+  , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]+  = match (renv { rv_fltR = flt_subst'+                , rv_lcl  = rv_lcl renv `extendRnInScopeSetList` new_bndrs })+                -- We are floating the let-binding out, as if it had enclosed+                -- the entire target from Day 1.  So we must add its binders to+                -- the in-scope set (#20200)+          (subst { rs_binds = rs_binds subst . Let bind'+                 , rs_bndrs = new_bndrs ++ rs_bndrs subst })+          e1 e2 mco+  | otherwise+  = Nothing+  where+    in_scope  = rnInScopeSet (rv_lcl renv) `extendInScopeSetList` rs_bndrs subst+                -- in_scope: see (4) in Note [Matching lets]+    flt_subst = rv_fltR renv `setInScope` in_scope+    (flt_subst', bind') = substBind flt_subst bind+    new_bndrs           = bindersOf bind'++------------------------  Lambdas ---------------------+match renv subst (Lam x1 e1) e2 mco+  | let casted_e2 = mkCastMCo e2 mco+        in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv))+                                       (exprFreeVars casted_e2)+        in_scope_env = ISE in_scope (rv_unf renv)+        -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily+        -- a superset of the free vars of e2; it is only guaranteed a superset of+        -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe+        -- wants an in-scope set that includes all the free vars of its argument.+        -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)+  , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2+    -- See Note [Lambdas in the template]+  = let renv'  = rnMatchBndr2 renv x1 x2+        subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }+    in  match renv' subst' e1 e2' MRefl++match renv subst e1 e2@(Lam {}) mco+  | Just (renv', e2') <- eta_reduce renv e2  -- See Note [Eta reduction in the target]+  = match renv' subst e1 e2' mco++{- Note [Lambdas in the template]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we match+   Template:   (\x. blah_template)+   Target:     (\y. blah_target)+then we want to match inside the lambdas, using rv_lcl to match up+x and y.++But what about this?+   Template   (\x. (blah1 |> cv))+   Target     (\y. blah2) |> co++This happens quite readily, because the Simplifier generally moves+casts outside lambdas: see Note [Casts and lambdas] in+GHC.Core.Opt.Simplify.Utils. So, tiresomely, we want to push `co`+back inside, which is what `exprIsLambda_maybe` does.  But we've+stripped off that cast, so now we need to put it back, hence mkCastMCo.++Unlike the target, where we attempt eta-reduction, we do not attempt+to eta-reduce the template, and may therefore fail on+  Template:   \x. f True x+  Target      f True++It's not especially easy to deal with eta reducing the template,+and never happens, because no one write eta-expanded left-hand-sides.+-}++------------------------ Case expression ---------------------+{- Disabled: see Note [Matching cases] below+match renv (tv_subst, id_subst, binds) e1+      (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])+  | exprOkForSpeculation scrut  -- See Note [Matching cases]+  , okToFloat rn_env bndrs (exprFreeVars scrut)+  = match (renv { me_env = rn_env' })+          (tv_subst, id_subst, binds . case_wrap)+          e1 rhs+  where+    rn_env   = me_env renv+    rn_env'  = extendRnInScopeList rn_env bndrs+    bndrs    = case_bndr : alt_bndrs+    case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]+-}++match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) mco+  = do  { subst1 <- match_ty renv subst ty1 ty2+        ; subst2 <- match renv subst1 e1 e2 MRefl+        ; let renv' = rnMatchBndr2 renv x1 x2+        ; match_alts renv' subst2 alts1 alts2 mco   -- Alts are both sorted+        }++-- Everything else fails+match _ _ _e1 _e2 _mco = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $+                         Nothing++-------------+eta_reduce :: RuleMatchEnv -> CoreExpr -> Maybe (RuleMatchEnv, CoreExpr)+-- See Note [Eta reduction in the target]+eta_reduce renv e@(Lam {})+  = go renv id [] e+  where+    go :: RuleMatchEnv -> BindWrapper -> [Var] -> CoreExpr+       -> Maybe (RuleMatchEnv, CoreExpr)+    go renv bw vs (Let b e) = go renv (bw . Let b) vs e++    go renv bw vs (Lam v e) = go renv' bw (v':vs) e+      where+         (rn_env', v') = rnBndrR (rv_lcl renv) v+         renv' = renv { rv_lcl = rn_env' }++    go renv bw (v:vs) (App f arg)+      | Var a <- arg, v == rnOccR (rv_lcl renv) a+      = go renv bw vs f++      | Type ty <- arg, Just tv <- getTyVar_maybe ty+      , v == rnOccR (rv_lcl renv) tv+      = go renv bw vs f++    go renv bw []    e = Just (renv, bw e)+    go _    _  (_:_) _ = Nothing++eta_reduce _ _ = Nothing++{- Note [Eta reduction in the target]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are faced with this (#19790)+   Template {x}  f x+   Target        (\a b c. let blah in f x a b c)++You might wonder why we have an eta-expanded target (see first subtle+point below), but regardless of how it came about, we'd like+eta-expansion not to impede matching.++So eta_reduce does on-the-fly eta-reduction of the target expression.+Given (\a b c. let blah in e a b c), it returns (let blah in e).++Subtle points:+* Consider a target:  \x. f <expensive> x+  In the main eta-reducer we do not eta-reduce this, because doing so+  might reduce the arity of the expression (from 1 to zero, because of+  <expensive>).  But for rule-matching we /do/ want to match template+  (f a) against target (\x. f <expensive> x), with a := <expensive>++  This is a compelling reason for not relying on the Simplifier's+  eta-reducer.++* The Lam case of eta_reduce renames as it goes. Consider+  (\x. \x. f x x).  We should not eta-reduce this.  As we go we rename+  the first x to x1, and the second to x2; then both argument x's are x2.++* eta_reduce does /not/ need to check that the bindings 'blah'+  and expression 'e' don't mention a b c; but it /does/ extend the+  rv_lcl RnEnv2 (see rn_bndr in eta_reduce).+  * If 'blah' mentions the binders, the let-float rule won't+    fire; and+  * if 'e' mentions the binders we we'll also fail to match+    e.g. because of the exprFreeVars test in match_tmpl_var.++  Example: Template: {x}  f a         -- Some top-level 'a'+           Target:   (\a b. f a a b)  -- The \a shadows top level 'a'+  Then eta_reduce will /succeed/, with+      (rnEnvR = [a :-> a'], f a)+  The returned RnEnv will map [a :-> a'], where a' is fresh. (There is+  no need to rename 'b' because (in this example) it is not in scope.+  So it's as if we'd returned (f a') from eta_reduce; the renaming applied+  to the target is simply deferred.++Note [Cancel reflexive casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is an example (from #19790) which we want to catch+   (f x) ~ (\a b. (f x |> co) a b) |> sym co+where+   f :: Int -> Stream+   co :: Stream ~ T1 -> T2 -> T3++when we eta-reduce (\a b. blah a b) to 'blah', we'll get+  (f x) ~ (f x) |> co |> sym co++and we really want to spot that the co/sym-co cancels out.+Hence+  * We keep an invariant that the MCoercion is always MRefl+    if the MCoercion is reflexive+  * We maintain this invariant via the call to checkReflexiveMCo+    in the Cast case of 'match'.+-}++-------------+matchTemplateCast+    :: RuleMatchEnv -> RuleSubst+    -> CoreExpr -> Coercion+    -> CoreExpr -> MCoercion+    -> Maybe RuleSubst+matchTemplateCast renv subst e1 co1 e2 mco+  | isEmptyVarSet $ fvVarSet $+    filterFV (`elemVarSet` rv_tmpls renv) $    -- Check that the coercion does not+    tyCoFVsOfCo substed_co                     -- mention any of the template variables+  = -- This is the good path+    -- See Note [Casts in the template] wrinkle (CT0)+    match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co)))++  | otherwise+  = -- This is the Deeply Suspicious Path+    -- See Note [Casts in the template]+    do { let co2 = case mco of+                     MRefl   -> mkRepReflCo (exprType e2)+                     MCo co2 -> co2+       ; subst1 <- match_co renv subst co1 co2+         -- If match_co succeeds, then (exprType e1) = (exprType e2)+         -- Hence the MRefl in the next line+       ; match renv subst1 e1 e2 MRefl }+  where+    substed_co = substCo current_subst co1++    current_subst :: Subst+    current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv))+                               (rs_tv_subst subst)+                               emptyCvSubstEnv+       -- emptyCvSubstEnv: ugh!+       -- If there were any CoVar substitutions they would be in+       -- rs_id_subst; but we don't expect there to be any; see+       -- Note [Casts in the template]++match_co :: RuleMatchEnv+         -> RuleSubst+         -> Coercion+         -> Coercion+         -> Maybe RuleSubst+-- We only match if the template is a coercion variable or Refl:+--   see Note [Casts in the template]+-- Like 'match' it is /not/ guaranteed that+--     coercionKind template  =  coercionKind target+-- But if match_co succeeds, it /is/ guaranteed that+--     coercionKind (subst template) = coercionKind target++match_co renv subst co1 co2+  | Just cv <- getCoVar_maybe co1+  = match_var renv subst cv (Coercion co2)++  | Just (ty1, r1) <- isReflCo_maybe co1+  = do { (ty2, r2) <- isReflCo_maybe co2+       ; guard (r1 == r2)+       ; match_ty renv subst ty1 ty2 }++  | debugIsOn+  = pprTrace "match_co: needs more cases" (ppr co1 $$ ppr co2) Nothing+    -- Currently just deals with CoVarCo and Refl++  | otherwise+  = Nothing++-------------+rnMatchBndr2 :: RuleMatchEnv -> Var -> Var -> RuleMatchEnv+rnMatchBndr2 renv x1 x2+  = renv { rv_lcl  = rnBndr2 (rv_lcl renv) x1 x2+         , rv_fltR = delBndr (rv_fltR renv) x2 }+++------------------------------------------+match_alts :: RuleMatchEnv+           -> RuleSubst+           -> [CoreAlt]                 -- Template+           -> [CoreAlt] -> MCoercion    -- Target+           -> Maybe RuleSubst+match_alts _ subst [] [] _+  = return subst+match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2) mco+  | c1 == c2+  = do  { subst1 <- match renv' subst r1 r2 mco+        ; match_alts renv subst1 alts1 alts2 mco }+  where+    renv' = foldl' mb renv (vs1 `zip` vs2)+    mb renv (v1,v2) = rnMatchBndr2 renv v1 v2++match_alts _ _ _ _ _+  = Nothing++------------------------------------------+okToFloat :: RnEnv2 -> VarSet -> Bool+okToFloat rn_env bind_fvs+  = allVarSet not_captured bind_fvs+  where+    not_captured fv = not (inRnEnvR rn_env fv)++------------------------------------------+match_var :: HasDebugCallStack+          => RuleMatchEnv+          -> RuleSubst+          -> Var        -- Template+          -> CoreExpr   -- Target+          -> Maybe RuleSubst+match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })+          subst v1 e2+  | v1' `elemVarSet` tmpls+  = match_tmpl_var renv subst v1' e2++  | otherwise   -- v1' is not a template variable; check for an exact match with e2+  = case e2 of  -- Remember, envR of rn_env is disjoint from rv_fltR+       Var v2 | Just v2' <- rnOccR_maybe rn_env v2+              -> -- v2 was bound by a nested lambda or case+                 if v1' == v2' then Just subst+                               else Nothing++              -- v2 is not bound nestedly; it is free+              -- in the whole expression being matched+              -- So it will be in the InScopeSet for flt_env (#20200)+              | Var v2' <- lookupIdSubst flt_env v2+              , v1' == v2'+              -> Just subst+              | otherwise+              -> Nothing++       _ -> Nothing++  where+    v1' = rnOccL rn_env v1+        -- If the template is+        --      forall x. f x (\x -> x) = ...+        -- Then the x inside the lambda isn't the+        -- template x, so we must rename first!++------------------------------------------+match_tmpl_var :: HasDebugCallStack+               => RuleMatchEnv+               -> RuleSubst+               -> Var                -- Template+               -> CoreExpr           -- Target+               -> Maybe RuleSubst++match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })+               subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })+               v1' e2+  -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs+  -- if the right side of the env is empty.+  | anyInRnEnvR rn_env (exprFreeVars e2)+  = Nothing     -- Skolem-escape failure+                -- e.g. match forall a. (\x -> a) against (\y -> y)++  | Just e1' <- lookupVarEnv id_subst v1'+  = if eqCoreExpr e1' e2'+    then Just subst+    else Nothing++  | otherwise   -- See Note [Matching variable types]+  = do { subst' <- match_ty renv subst (idType v1') (exprType e2)+       ; return (subst' { rs_id_subst = id_subst' }) }+  where+    -- e2' is the result of applying flt_env to e2+    e2' | null let_bndrs = e2+        | otherwise = substExpr flt_env e2++    id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'+         -- No further renaming to do on e2',+         -- because no free var of e2' is in the rnEnvR of the envt++------------------------------------------++match_ty :: RuleMatchEnv+         -> RuleSubst+         -> Type                -- Template+         -> Type                -- Target+         -> Maybe RuleSubst+-- Matching Core types: use the matcher in GHC.Tc.Utils.TcType.+-- Notice that we treat newtypes as opaque.  For example, suppose+-- we have a specialised version of a function at a newtype, say+--      newtype T = MkT Int+-- We only want to replace (f T) with f', not (f Int).++match_ty (RV { rv_tmpls = tmpls, rv_lcl = rn_env })+         subst@(RS { rs_tv_subst = tv_subst })+         ty1 ty2+  = do  { tv_subst' <- Unify.ruleMatchTyKiX tmpls rn_env tv_subst ty1 ty2+               -- NB: ruleMatchTyKiX applis tv_subst to ty1 only+               --     and of course only binds 'tmpls'+        ; return (subst { rs_tv_subst = tv_subst' }) }++{- Note [Matching variable types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching x ~ e, where 'x' is a template variable, we must check that+x's type matches e's type, to establish (TypeInv).  For example+  forall (c::Char->Int) (x::Char).+     f (c x) = "RULE FIRED"+We must not match on, say (f (pred (3::Int))).++It's actually quite difficult to come up with an example that shows+you need type matching, esp since matching is left-to-right, so type+args get matched first.  But it's possible (e.g. simplrun008) and this+is the Right Thing to do.++An alternative would be to make (TypeInf) into a /pre-condition/.  It+is threatened only by the App rule.  So when matching an application+(e1 e2) ~ (d1 d2) would be to collect args of the application chain,+match the types of the head, then match arg-by-arg.++However that alternative seems a bit more complicated.  And by+matching types at variables we do one match_ty for each template+variable, rather than one for each application chain.  Usually there are+fewer template variables, although for simple rules it could be the other+way around.++Note [Expanding variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another Very Important rule: if the term being matched is a+variable, we expand it so long as its unfolding is "expandable". (Its+occurrence information is not necessarily up to date, so we don't use+it.)  By "expandable" we mean a WHNF or a "constructor-like" application.+This is the key reason for "constructor-like" Ids.  If we have+     {-# NOINLINE [1] CONLIKE g #-}+     {-# RULE f (g x) = h x #-}+then in the term+   let v = g 3 in ....(f v)....+we want to make the rule fire, to replace (f v) with (h 3).++Note [Do not expand locally-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do *not* expand locally-bound variables, else there's a worry that the+unfolding might mention variables that are themselves renamed.+Example+          case x of y { (p,q) -> ...y... }+Don't expand 'y' to (p,q) because p,q might themselves have been+renamed.  Essentially we only expand unfoldings that are "outside"+the entire match.++Hence, (a) the guard (not (isLocallyBoundR v2))+       (b) when we expand we nuke the renaming envt (nukeRnEnvR).++Note [Tick annotations in RULE matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to unconditionally look through ticks in both template and+expression being matched. This is actually illegal for counting or+cost-centre-scoped ticks, because we have no place to put them without+changing entry counts and/or costs. So now we just fail the match in+these cases.++On the other hand, where we are allowed to insert new cost into the+tick scope, we can float them upwards to the rule application site.++Moreover, we may encounter ticks in the template of a rule. There are a few+ways in which these may be introduced (e.g. #18162, #17619). Such ticks are+ignored by the matcher. See Note [Simplifying rules] in+GHC.Core.Opt.Simplify.Utils for details.++cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr+++Note [Matching lets]+~~~~~~~~~~~~~~~~~~~~+Matching a let-expression.  Consider+        RULE forall x.  f (g x) = <rhs>+and target expression+        f (let { w=R } in g E))+Then we'd like the rule to match, to generate+        let { w=R } in (\x. <rhs>) E+In effect, we want to float the let-binding outward, to enable+the match to happen.  This is the WHOLE REASON for accumulating+bindings in the RuleSubst++We can only do this if the free variables of R are not bound by the+part of the target expression outside the let binding; e.g.+        f (\v. let w = v+1 in g E)+Here we obviously cannot float the let-binding for w.  Hence the+use of okToFloat.++There are a couple of tricky points:+  (a) What if floating the binding captures a variable that is+      free in the entire expression?+        f (let v = x+1 in v) v+      --> NOT!+        let v = x+1 in f (x+1) v++  (b) What if the let shadows a local binding?+        f (\v -> (v, let v = x+1 in (v,v))+      --> NOT!+        let v = x+1 in f (\v -> (v, (v,v)))++  (c) What if two non-nested let bindings bind the same variable?+        f (let v = e1 in b1) (let v = e2 in b2)+      --> NOT!+        let v = e1 in let v = e2 in (f b2 b2)+      See testsuite test `T4814`.++Our cunning plan is this:+  (1) Along with the growing substitution for template variables+      we maintain a growing set of floated let-bindings (rs_binds)+      plus the set of variables thus bound (rs_bndrs).++  (2) The RnEnv2 in the MatchEnv binds only the local binders+      in the term (lambdas, case), not the floated let-bndrs.++  (3) When we encounter a `let` in the term to be matched, in the Let+      case of `match`, we use `okToFloat` to check that it does not mention any+      locally bound (lambda, case) variables.  If so we fail.++  (4) In the Let case of `match`, we use GHC.Core.Subst.substBind to+      freshen the binding (which, remember (3), mentions no locally+      bound variables), in a lexically-scoped way (via rv_fltR in+      MatchEnv).++      The subtle point is that we want an in-scope set for this+      substitution that includes /two/ sets:+      * The in-scope variables at this point, so that we avoid using+        those local names for the floated binding; points (a) and (b) above.+      * All "earlier" floated bindings, so that we avoid using the+        same name for two different floated bindings; point (c) above.++      Because we have to compute the in-scope set here, the in-scope set+      stored in `rv_fltR` is always ignored; we leave it only because it's+      convenient to have `rv_fltR :: Subst` (with an always-ignored `InScopeSet`)+      rather than storing three separate substitutions.++  (5) We apply that freshening substitution, in a lexically-scoped+      way to the term, although lazily; this is the rv_fltR field.++See #4814, which is an issue resulting from getting this wrong.++Note [Matching cases]+~~~~~~~~~~~~~~~~~~~~~+{- NOTE: This idea is currently disabled.  It really only works if+         the primops involved are OkForSpeculation, and, since+         they have side effects readIntOfAddr and touch are not.+         Maybe we'll get back to this later .  -}++Consider+   f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+      case touch# fp s# of { _ ->+      I# n# } } )+This happened in a tight loop generated by stream fusion that+Roman encountered.  We'd like to treat this just like the let+case, because the primops concerned are ok-for-speculation.+That is, we'd like to behave as if it had been+   case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->+   case touch# fp s# of { _ ->+   f (I# n# } } )++Note [Lookup in-scope]+~~~~~~~~~~~~~~~~~~~~~~+Consider this example+        foo :: Int -> Maybe Int -> Int+        foo 0 (Just n) = n+        foo m (Just n) = foo (m-n) (Just n)++SpecConstr sees this fragment:++        case w_smT of wild_Xf [Just A] {+          Data.Maybe.Nothing -> lvl_smf;+          Data.Maybe.Just n_acT [Just S(L)] ->+            case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->+              $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf+            }};++and correctly generates the rule++        RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#+                                          sc_snn :: GHC.Prim.Int#}+          $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))+          = $s$wfoo_sno y_amr sc_snn ;]++BUT we must ensure that this rule matches in the original function!+Note that the call to $wfoo is+            $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf++During matching we expand wild_Xf to (Just n_acT).  But then we must also+expand n_acT to (I# y_amr).  And we can only do that if we look up n_acT+in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding+at all.++That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'+is so important.+++************************************************************************+*                                                                      *+                   Rule-check the program+*                                                                      *+************************************************************************++   We want to know what sites have rules that could have fired but didn't.+   This pass runs over the tree (without changing it) and reports such.+-}++-- | Report partial matches for rules beginning with the specified+-- string for the purposes of error reporting+ruleCheckProgram :: RuleOpts                    -- ^ Rule options+                 -> CompilerPhase               -- ^ Rule activation test+                 -> String                      -- ^ Rule pattern+                 -> (Id -> [CoreRule])          -- ^ Rules for an Id+                 -> CoreProgram                 -- ^ Bindings to check in+                 -> SDoc                        -- ^ Resulting check message+ruleCheckProgram ropts phase rule_pat rules binds+  | isEmptyBag results+  = text "Rule check results: no rule application sites"+  | otherwise+  = vcat [text "Rule check results:",+          line,+          vcat [ p $$ line | p <- bagToList results ]+         ]+  where+    line = text (replicate 20 '-')+    env = RuleCheckEnv { rc_is_active = isActive phase+                       , rc_id_unf    = idUnfolding     -- Not quite right+                                                        -- Should use activeUnfolding+                       , rc_pattern   = rule_pat+                       , rc_rules     = rules+                       , rc_ropts     = ropts+                       , rc_in_scope  = emptyInScopeSet }++    results = go env binds++    go _   []           = emptyBag+    go env (bind:binds) = let (env', ds) = ruleCheckBind env bind+                          in ds `unionBags` go env' binds++data RuleCheckEnv = RuleCheckEnv+    { rc_is_active :: Activation -> Bool+    , rc_id_unf    :: IdUnfoldingFun+    , rc_pattern   :: String+    , rc_rules     :: Id -> [CoreRule]+    , rc_ropts     :: RuleOpts+    , rc_in_scope  :: InScopeSet }++extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv+extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v+  = env { rc_in_scope = in_scope `extendInScopeSet` v }++extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv+extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs+  = env { rc_in_scope = in_scope `extendInScopeSetList` vs }++ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc)+   -- The Bag returned has one SDoc for each call site found+ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r)+ruleCheckBind env (Rec prs)    = (env', unionManyBags (map (ruleCheck env') rhss))+                               where+                                 (bs, rhss) = unzip prs+                                 env' = env `extendInScopeListRC` bs++ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc+ruleCheck _   (Var _)         = emptyBag+ruleCheck _   (Lit _)         = emptyBag+ruleCheck _   (Type _)        = emptyBag+ruleCheck _   (Coercion _)    = emptyBag+ruleCheck env (App f a)       = ruleCheckApp env (App f a) []+ruleCheck env (Tick _ e)      = ruleCheck env e+ruleCheck env (Cast e _)      = ruleCheck env e+ruleCheck env (Let bd e)      = let (env', ds) = ruleCheckBind env bd+                                in  ds `unionBags` ruleCheck env' e+ruleCheck env (Lam b e)       = ruleCheck (env `extendInScopeRC` b) e+ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags`+                                unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r+                                              | Alt _ bs r <- as]++ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc+ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)+ruleCheckApp env (Var f) as   = ruleCheckFun env f as+ruleCheckApp env other _      = ruleCheck env other++ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc+-- Produce a report for all rules matching the predicate+-- saying why it doesn't match the specified application++ruleCheckFun env fn args+  | null name_match_rules = emptyBag+  | otherwise             = unitBag (ruleAppCheck_help env fn args name_match_rules)+  where+    name_match_rules = filter match (rc_rules env fn)+    match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule)++ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc+ruleAppCheck_help env fn args rules+  =     -- The rules match the pattern, so we want to print something+    vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),+          vcat (map check_rule rules)]+  where+    in_scope = rc_in_scope env+    n_args   = length args+    i_args   = args `zip` [1::Int ..]+    rough_args = map roughTopName args++    check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule++    rule_herald (BuiltinRule { ru_name = name })+        = text "Builtin rule" <+> doubleQuotes (ftext name)+    rule_herald (Rule { ru_name = name })+        = text "Rule" <+> doubleQuotes (ftext name)++    rule_info opts rule+        | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))+                              noBlackList fn args rough_args rule+        = text "matches (which is very peculiar!)"++    rule_info _ (BuiltinRule {}) = text "does not match"++    rule_info _ (Rule { ru_act = act,+                        ru_bndrs = rule_bndrs, ru_args = rule_args})+        | not (rc_is_active env act)  = text "active only in later phase"+        | n_args < n_rule_args        = text "too few arguments"+        | n_mismatches == n_rule_args = text "no arguments match"+        | n_mismatches == 0           = text "all arguments match (considered individually), but rule as a whole does not"+        | otherwise                   = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"+        where+          n_rule_args  = length rule_args+          n_mismatches = length mismatches+          mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,+                              not (isJust (match_fn rule_arg arg))]++          match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl+                where+                  renv = RV { rv_lcl   = mkRnEnv2 in_scope+                            , rv_tmpls = mkVarSet rule_bndrs+                            , rv_fltR  = mkEmptySubst in_scope+                            , rv_unf   = rc_id_unf env }
+ GHC/Core/Rules/Config.hs view
@@ -0,0 +1,19 @@+module GHC.Core.Rules.Config where++import GHC.Prelude+import GHC.Platform++-- | Rule options+data RuleOpts = RuleOpts+   { roPlatform                :: !Platform+     -- ^ Target platform+   , roNumConstantFolding      :: !Bool+     -- ^ Enable constant folding through nested expressions.+     --+     -- See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold+   , roExcessRationalPrecision :: !Bool+     -- ^ Cut down precision of Rational values to that of Float/Double if disabled+   , roBignumRules             :: !Bool+     -- ^ Enable rules for bignums+   }+
+ GHC/Core/Seq.hs view
@@ -0,0 +1,117 @@+-- |+-- Various utilities for forcing Core structures+--+-- It can often be useful to force various parts of the AST. This module+-- provides a number of @seq@-like functions to accomplish this.++module GHC.Core.Seq (+        -- * Utilities for forcing Core structures+        seqExpr, seqExprs, seqUnfolding, seqRules,+        megaSeqIdInfo, seqRuleInfo, seqBinds,+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Types.Id.Info+import GHC.Types.Demand( seqDemand, seqDmdSig )+import GHC.Types.Cpr( seqCprSig )+import GHC.Types.Basic( seqOccInfo )+import GHC.Types.Tickish+import GHC.Types.Var.Set( seqDVarSet )+import GHC.Types.Var( varType, tyVarKind )+import GHC.Core.Type( seqType, isTyVar )+import GHC.Core.Coercion( seqCo )+import GHC.Types.Id( idInfo )++-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the+-- compiler+megaSeqIdInfo :: IdInfo -> ()+megaSeqIdInfo info+  = seqRuleInfo (ruleInfo info)                 `seq`++-- Omitting this improves runtimes a little, presumably because+-- some unfoldings are not calculated at all+--    seqUnfolding (realUnfoldingInfo info)         `seq`++    seqDemand (demandInfo info)                 `seq`+    seqDmdSig (dmdSigInfo info)          `seq`+    seqCprSig (cprSigInfo info)                    `seq`+    seqCaf (cafInfo info)                       `seq`+    seqOneShot (oneShotInfo info)               `seq`+    seqOccInfo (occInfo info)++seqOneShot :: OneShotInfo -> ()+seqOneShot l = l `seq` ()++seqRuleInfo :: RuleInfo -> ()+seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs++seqCaf :: CafInfo -> ()+seqCaf c = c `seq` ()++seqRules :: [CoreRule] -> ()+seqRules [] = ()+seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)+  = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules+seqRules (BuiltinRule {} : rules) = seqRules rules++seqExpr :: CoreExpr -> ()+seqExpr (Var v)         = v `seq` ()+seqExpr (Lit lit)       = lit `seq` ()+seqExpr (App f a)       = seqExpr f `seq` seqExpr a+seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e+seqExpr (Let b e)       = seqBind b `seq` seqExpr e+seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as+seqExpr (Cast e co)     = seqExpr e `seq` seqCo co+seqExpr (Tick n e)      = seqTickish n `seq` seqExpr e+seqExpr (Type t)        = seqType t+seqExpr (Coercion co)   = seqCo co++seqExprs :: [CoreExpr] -> ()+seqExprs [] = ()+seqExprs (e:es) = seqExpr e `seq` seqExprs es++seqTickish :: CoreTickish -> ()+seqTickish ProfNote{ profNoteCC = cc } = cc `seq` ()+seqTickish HpcTick{} = ()+seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids+seqTickish SourceNote{} = ()++seqBndr :: CoreBndr -> ()+seqBndr b | isTyVar b = seqType (tyVarKind b)+          | otherwise = seqType (varType b)             `seq`+                        megaSeqIdInfo (idInfo b)++seqBndrs :: [CoreBndr] -> ()+seqBndrs [] = ()+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs++seqBinds :: [Bind CoreBndr] -> ()+seqBinds bs = foldr (seq . seqBind) () bs++seqBind :: Bind CoreBndr -> ()+seqBind (NonRec b e) = seqBndr b `seq` seqExpr e+seqBind (Rec prs)    = seqPairs prs++seqPairs :: [(CoreBndr, CoreExpr)] -> ()+seqPairs [] = ()+seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs++seqAlts :: [CoreAlt] -> ()+seqAlts [] = ()+seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts++seqUnfolding :: Unfolding -> ()+seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,+                uf_cache = cache, uf_guidance = g})+  = seqExpr e `seq` top `seq` cache `seq` seqGuidance g+    -- The unf_cache :: UnfoldingCache field is a strict data type,+    -- so it is sufficient to use plain `seq` for this field+    -- See Note [UnfoldingCache] in GHC.Core++seqUnfolding _ = ()++seqGuidance :: UnfoldingGuidance -> ()+seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()+seqGuidance _                      = ()
+ GHC/Core/SimpleOpt.hs view
@@ -0,0 +1,1612 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+++module GHC.Core.SimpleOpt (+        SimpleOpts (..), defaultSimpleOpts,++        -- ** Simple expression optimiser+        simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith,++        -- ** Join points+        joinPointBinding_maybe, joinPointBindings_maybe,++        -- ** Predicates on expressions+        exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe,++    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.Opt.Arity+import GHC.Core.Subst+import GHC.Core.Utils+import GHC.Core.FVs+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Make ( FloatBind(..), mkWildValBinder )+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs )+import GHC.Core.DataCon+import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )+import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList+                            , isInScope, substTyVarBndr, cloneTyVarBndr )+import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )++import GHC.Types.Literal+import GHC.Types.Id+import GHC.Types.Id.Info  ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )+import GHC.Types.Var      ( isNonCoVarId )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Demand( etaConvertDmdSig, topSubDmd )+import GHC.Types.Tickish+import GHC.Types.Basic++import GHC.Builtin.Types+import GHC.Builtin.Names++import GHC.Unit.Module ( Module )+import GHC.Utils.Encoding+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Data.Maybe       ( orElse )+import GHC.Data.Graph.UnVar+import Data.List (mapAccumL)+import qualified Data.ByteString as BS++{-+************************************************************************+*                                                                      *+        The Simple Optimiser+*                                                                      *+************************************************************************++Note [The simple optimiser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The simple optimiser is a lightweight, pure (non-monadic) function+that rapidly does a lot of simple optimisations, including++  - inlining things that occur just once,+      or whose RHS turns out to be trivial+  - beta reduction+  - case of known constructor+  - dead code elimination++It does NOT do any call-site inlining; it only inlines a function if+it can do so unconditionally, dropping the binding.  It thereby+guarantees to leave no un-reduced beta-redexes.++It is careful to follow the guidance of "Secrets of the GHC inliner",+and in particular the pre-inline-unconditionally and+post-inline-unconditionally story, to do effective beta reduction on+functions called precisely once, without repeatedly optimising the same+expression.  In fact, the simple optimiser is a good example of this+little dance in action; the full Simplifier is a lot more complicated.++Note [The InScopeSet for simpleOptExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Care must be taken to remove unfoldings from `Var`s collected by exprFreeVars+before using them to construct an in-scope set hence `zapIdUnfolding` in `init_subst`.+Consider calling `simpleOptExpr` on an expression like++```+ case x of (a,b) -> (x,a)+```++* One of those two occurrences of x has an unfolding (the one in (x,a), with+unfolding x = (a,b)) and the other does not. (Inside a case GHC adds+unfolding-info to the scrutinee's Id.)+* But exprFreeVars just builds a set, so it's a bit random which occurrence is collected.+* Then simpleOptExpr replaces each occurrence of x with the one in the in-scope set.+* Bad bad bad: then the x in  case x of ... may be replaced with a version that has an unfolding.++See ticket #25790+-}++-- | Simple optimiser options+data SimpleOpts = SimpleOpts+   { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options+   , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options+   , so_eta_red :: !Bool            -- ^ Eta reduction on?+   , so_inline :: !Bool             -- ^ False <=> do no inlining whatsoever,+                                    --    even for trivial or used-once things+   }++-- | Default options for the Simple optimiser.+defaultSimpleOpts :: SimpleOpts+defaultSimpleOpts = SimpleOpts+   { so_uf_opts = defaultUnfoldingOpts+   , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }+   , so_eta_red = False+   , so_inline  = True+   }++simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr+-- See Note [The simple optimiser]+-- Do simple optimisation on an expression+-- The optimisation is very straightforward: just+-- inline non-recursive bindings that are used only once,+-- or where the RHS is trivial+--+-- We also inline bindings that bind a Eq# box: see+-- See Note [Getting the map/coerce RULE to work].+--+-- Also we convert functions to join points where possible (as+-- the occurrence analyser does most of the work anyway).+--+-- The result is NOT guaranteed occurrence-analysed, because+-- in  (let x = y in ....) we substitute for x; so y's occ-info+-- may change radically+--+-- Note that simpleOptExpr is a pure function that we want to be able to call+-- from lots of places, including ones that don't have DynFlags (e.g to optimise+-- unfoldings of statically defined Ids via mkCompulsoryUnfolding). It used to+-- fetch its options directly from the DynFlags, however, so some callers had to+-- resort to using unsafeGlobalDynFlags (a global mutable variable containing+-- the DynFlags). It has been modified to take its own SimpleOpts that may be+-- created from DynFlags, but not necessarily.++simpleOptExpr opts expr+  = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)+    simpleOptExprWith opts init_subst expr+  where+    init_subst = mkEmptySubst (mkInScopeSet (mapVarSet zapIdUnfolding (exprFreeVars expr)))+        -- zapIdUnfolding: see Note [The InScopeSet for simpleOptExpr]++        -- It's a bit painful to call exprFreeVars, because it makes+        -- three passes instead of two (occ-anal, and go)++simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr+-- A variant of simpleOptExpr, but without+-- occurrence analysis or inlining of any kind.+-- Result: we don't inline evidence bindings, which is useful for the specialiser+simpleOptExprNoInline opts expr+  = simple_opt_expr init_env expr+  where+    init_opts  = opts { so_inline = False }+    init_env   = (emptyEnv init_opts) { soe_subst = init_subst }+    init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))++simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr+-- See Note [The simple optimiser]+simpleOptExprWith opts subst expr+  = simple_opt_expr init_env (occurAnalyseExpr expr)+  where+    init_env = (emptyEnv opts) { soe_subst = subst }++----------------------+simpleOptPgm :: SimpleOpts+             -> Module+             -> CoreProgram+             -> [CoreRule]+             -> (CoreProgram, [CoreRule], CoreProgram)+-- See Note [The simple optimiser]+simpleOptPgm opts this_mod binds rules =+    (reverse binds', rules', occ_anald_binds)+  where+    occ_anald_binds  = occurAnalysePgm this_mod+                          (\_ -> True)  {- All unfoldings active -}+                          (\_ -> False) {- No rules active -}+                          rules binds++    (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds+    final_subst = soe_subst final_env++    rules' = substRulesForImportedIds final_subst rules+             -- We never unconditionally inline into rules,+             -- hence paying just a substitution++    do_one (env, binds') bind+      = case simple_opt_bind env bind TopLevel of+          (env', Nothing)    -> (env', binds')+          (env', Just bind') -> (env', bind':binds')++-- In these functions the substitution maps InVar -> OutExpr++----------------------+type SimpleClo = (SimpleOptEnv, InExpr)++data SimpleOptEnv+  = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts+             -- ^ Simplifier options++        , soe_inl :: IdEnv SimpleClo+             -- ^ Deals with preInlineUnconditionally; things+             -- that occur exactly once and are inlined+             -- without having first been simplified++        , soe_subst :: Subst+             -- ^ Deals with cloning; includes the InScopeSet++        , soe_rec_ids :: !UnVarSet+             -- ^ Fast OutVarSet tracking which recursive RHSs we are analysing.+             -- See Note [Eta reduction in recursive RHSs]+        }++instance Outputable SimpleOptEnv where+  ppr (SOE { soe_inl = inl, soe_subst = subst })+    = text "SOE {" <+> vcat [ text "soe_inl   =" <+> ppr inl+                            , text "soe_subst =" <+> ppr subst ]+                   <+> text "}"++emptyEnv :: SimpleOpts -> SimpleOptEnv+emptyEnv opts = SOE { soe_inl     = emptyVarEnv+                    , soe_subst   = emptySubst+                    , soe_rec_ids = emptyUnVarSet+                    , soe_opts    = opts  }++soeZapSubst :: SimpleOptEnv -> SimpleOptEnv+soeZapSubst env@(SOE { soe_subst = subst })+  = env { soe_inl = emptyVarEnv, soe_subst = zapSubst subst }++soeInScope :: SimpleOptEnv -> InScopeSet+soeInScope (SOE { soe_subst = subst }) = substInScopeSet subst++soeSetInScope :: InScopeSet -> SimpleOptEnv -> SimpleOptEnv+soeSetInScope in_scope env2@(SOE { soe_subst = subst2 })+  = env2 { soe_subst = setInScope subst2 in_scope }++enterRecGroupRHSs :: SimpleOptEnv -> [OutBndr] -> (SimpleOptEnv -> (SimpleOptEnv, r))+                  -> (SimpleOptEnv, r)+enterRecGroupRHSs env bndrs k+  = (env'{soe_rec_ids = soe_rec_ids env}, r)+  where+    (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}++---------------+simple_opt_clo :: HasDebugCallStack+               => InScopeSet+               -> SimpleClo+               -> OutExpr+simple_opt_clo in_scope (e_env, e)+  = simple_opt_expr (soeSetInScope in_scope e_env) e++simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr+simple_opt_expr env expr+  = go expr+  where+    rec_ids      = soe_rec_ids env+    subst        = soe_subst env+    in_scope     = substInScopeSet subst+    in_scope_env = ISE in_scope alwaysActiveUnfoldingFun++    ---------------+    go (Var v)+       | Just clo <- lookupVarEnv (soe_inl env) v+       = simple_opt_clo in_scope clo+       | otherwise+       = lookupIdSubst (soe_subst env) v++    go (App e1 e2)      = simple_app env e1 [(env,e2)]+    go (Type ty)        = Type     (substTyUnchecked subst ty)+    go (Coercion co)    = Coercion (go_co co)+    go (Lit lit)        = Lit lit+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)+    go (Cast e co)      = mk_cast (go e) (go_co co)+    go (Let bind body)  = case simple_opt_bind env bind NotTopLevel of+                             (env', Nothing)   -> simple_opt_expr env' body+                             (env', Just bind) -> Let bind (simple_opt_expr env' body)++    go lam@(Lam {})     = go_lam env [] lam+    go (Case e b ty as)+      | isDeadBinder b+      , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'+        -- We don't need to be concerned about floats when looking for coerce.+      , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as+      = case altcon of+          DEFAULT -> go rhs+          _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs+            where+              (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $+                               zipEqual bs es++         -- See Note [Getting the map/coerce RULE to work]+      | isDeadBinder b+      , [Alt DEFAULT _ rhs] <- as+      , isCoVarType (varType b)+      , (Var fun, _args) <- collectArgs e+      , fun `hasKey` coercibleSCSelIdKey+         -- without this last check, we get #11230+      = go rhs++      | otherwise+      = Case e' b' (substTyUnchecked subst ty)+                   (map (go_alt env') as)+      where+        e' = go e+        (env', b') = subst_opt_bndr env b++    ----------------------+    go_co co = optCoercion (so_co_opts (soe_opts env)) subst co++    ----------------------+    go_alt env (Alt con bndrs rhs)+      = Alt con bndrs' (simple_opt_expr env' rhs)+      where+        (env', bndrs') = subst_opt_bndrs env bndrs++    ----------------------+    -- go_lam tries eta reduction+    -- It is quite important that it does so. I tried removing this code and+    -- got a lot of regressions, e.g., +11% ghc/alloc in T18223 and many+    -- run/alloc increases. Presumably RULEs are affected.+    go_lam env bs' (Lam b e)+       = go_lam env' (b':bs') e+       where+         (env', b') = subst_opt_bndr env b+    go_lam env bs' e+       | so_eta_red (soe_opts env)+       , Just etad_e <- tryEtaReduce rec_ids bs e' topSubDmd = etad_e+       | otherwise                                           = mkLams bs e'+       where+         bs = reverse bs'+         e' = simple_opt_expr env e++mk_cast :: CoreExpr -> CoercionR -> CoreExpr+-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check.+-- mkCast doesn't do that because the Simplifier does (in simplCast)+-- But in SimpleOpt it's nice to kill those nested casts (#18112)+mk_cast (Cast e co1) co2        = mk_cast e (co1 `mkTransCo` co2)+mk_cast (Tick t e)   co         = Tick t (mk_cast e co)+mk_cast e co | isReflexiveCo co = e+             | otherwise        = Cast e co++----------------------+-- simple_app collects arguments for beta reduction+simple_app :: HasDebugCallStack => SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr++simple_app env (Var v) as+  | Just (env', e) <- lookupVarEnv (soe_inl env) v+  = simple_app (soeSetInScope (soeInScope env) env') e as++  | let unf = idUnfolding v+  , isCompulsoryUnfolding unf+  , isAlwaysActive (idInlineActivation v)+    -- See Note [Unfold compulsory unfoldings in RULE LHSs]+  , Just rhs <- maybeUnfoldingTemplate unf+    -- Always succeeds if isCompulsoryUnfolding does+  = simple_app (soeZapSubst env) rhs as++  | otherwise+  , let out_fn = lookupIdSubst (soe_subst env) v+  = finish_app env out_fn as++simple_app env (App e1 e2) as+  = simple_app env e1 ((env, e2) : as)++simple_app env e@(Lam {}) as@(_:_)+  = do_beta env (zapLambdaBndrs e n_args) as+    -- Be careful to zap the lambda binders if necessary+    -- c.f. the Lam case of simplExprF1 in GHC.Core.Opt.Simplify+    -- Lacking this zap caused #19347, when we had a redex+    --   (\ a b. K a b) e1 e2+    -- where (as it happens) the eta-expanded K is produced by+    -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head+  where+    n_args = length as++    do_beta env (Lam b body) (a:as)+      | -- simpl binder before looking at its type+        -- See Note [Dark corner with representation polymorphism]+        needsCaseBinding (idType b') (snd a)+        -- This arg must not be inlined (side-effects) and cannot be let-bound,+        -- due to the let-can-float invariant. So simply case-bind it here.+      , let a' = simple_opt_clo (soeInScope env) a+      = mkDefaultCase a' b' $ do_beta env' body as++      | (env'', mb_pr) <- simple_bind_pair env' b (Just b') a NotTopLevel+      = wrapLet mb_pr $ do_beta env'' body as++      where (env', b') = subst_opt_bndr env b++    do_beta env body as+      = simple_app env body as++simple_app env (Tick t e) as+  -- Okay to do "(Tick t e) x ==> Tick t (e x)"?+  | t `tickishScopesLike` SoftScope+  = mkTick t $ simple_app env e as++-- (let x = e in b) a1 .. an  =>  let x = e in (b a1 .. an)+-- The let might appear there as a result of inlining+-- e.g.   let f = let x = e in b+--        in f a1 a2+--   (#13208)+-- However, do /not/ do this transformation for join points+--    See Note [simple_app and join points]+simple_app env (Let bind body) args+  = case simple_opt_bind env bind NotTopLevel of+      (env', Nothing)   -> simple_app env' body args+      (env', Just bind')+        | isJoinBind bind' -> finish_app env expr' args+        | otherwise        -> Let bind' (simple_app env' body args)+        where+          expr' = Let bind' (simple_opt_expr env' body)++simple_app env e as+  = finish_app env (simple_opt_expr env e) as++finish_app :: HasDebugCallStack+           => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr+-- See Note [Eliminate casts in function position]+finish_app env (Cast (Lam x e) co) as@(_:_)+  | not (isTyVar x) && not (isCoVar x)+  , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True+  , Just (x',e') <- pushCoercionIntoLambda (soeInScope env) x e co+  = simple_app (soeZapSubst env) (Lam x' e') as++finish_app env fun args+  = foldl mk_app fun args+  where+    in_scope = soeInScope env+    mk_app fun arg = App fun (simple_opt_clo in_scope arg)++----------------------+simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag+                -> (SimpleOptEnv, Maybe OutBind)+simple_opt_bind env (NonRec b r) top_level+  = (env', case mb_pr of+            Nothing    -> Nothing+            Just (b,r) -> Just (NonRec b r))+  where+    (b', r') = joinPointBinding_maybe b r `orElse` (b, r)+    (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level++simple_opt_bind env (Rec prs) top_level+  = (env2, res_bind)+  where+    res_bind          = Just (Rec (reverse rev_prs'))+    prs'              = joinPointBindings_maybe prs `orElse` prs+    (env1, bndrs')    = subst_opt_bndrs env (map fst prs')+    (env2, rev_prs')  = enterRecGroupRHSs env1 bndrs' $ \env ->+                          foldl' do_pr (env, []) (prs' `zip` bndrs')+    do_pr (env, prs) ((b,r), b')+       = (env', case mb_pr of+                  Just pr -> pr : prs+                  Nothing -> prs)+       where+         (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level++----------------------+simple_bind_pair :: SimpleOptEnv+                 -> InVar -> Maybe OutVar+                 -> SimpleClo+                 -> TopLevelFlag+                 -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+    -- (simple_bind_pair subst in_var out_rhs)+    --   either extends subst with (in_var -> out_rhs)+    --   or     returns Nothing+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts })+                 in_bndr mb_out_bndr clo@(rhs_env, in_rhs)+                 top_level+  | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>+  , let out_ty = substTyUnchecked (soe_subst rhs_env) ty+  = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)++  | Coercion co <- in_rhs+  , let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co+  = assert (isCoVar in_bndr)+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)++  | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)+    -- The previous two guards got rid of tyvars and coercions+    -- See Note [Core type and coercion invariant] in GHC.Core+    pre_inline_unconditionally+  = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing)++  | otherwise+  = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs+                         occ active stable_unf top_level+  where+    stable_unf = isStableUnfolding (idUnfolding in_bndr)+    active     = isAlwaysActive (idInlineActivation in_bndr)+    occ        = idOccInfo in_bndr+    in_scope   = substInScopeSet subst++    out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr+            = simple_join_rhs join_arity+            | otherwise+            = simple_opt_clo in_scope clo++    simple_join_rhs join_arity -- See Note [Preserve join-binding arity]+      = mkLams join_bndrs' (simple_opt_expr env_body join_body)+      where+        env0 = soeSetInScope in_scope rhs_env+        (join_bndrs, join_body) = collectNBinders join_arity in_rhs+        (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs++    pre_inline_unconditionally :: Bool+    pre_inline_unconditionally+       | not (so_inline opts)     = False    -- Not if so_inline is False+       | isExportedId in_bndr     = False+       | stable_unf               = False+       | not active               = False    -- Note [Inline prag in simplOpt]+       | not (safe_to_inline occ) = False+       | otherwise                = True++        -- Unconditionally safe to inline+safe_to_inline :: OccInfo -> Bool+safe_to_inline IAmALoopBreaker{}                  = False+safe_to_inline IAmDead                            = True+safe_to_inline OneOcc{ occ_in_lam = NotInsideLam+                     , occ_n_br = 1 }             = True+safe_to_inline OneOcc{}                           = False+safe_to_inline ManyOccs{}                         = False++do_beta_by_substitution :: Id -> CoreExpr -> Bool+-- True <=> you can inline (bndr = rhs) by substitution+-- See Note [Exploit occ-info in exprIsConApp_maybe]+do_beta_by_substitution bndr rhs+  = exprIsTrivial rhs                   -- Can duplicate+    || safe_to_inline (idOccInfo bndr)  -- Occurs at most once++do_case_elim :: CoreExpr -> Id -> [Id] -> Bool+do_case_elim scrut case_bndr alt_bndrs+  =  exprIsHNF scrut+  && safe_to_inline (idOccInfo case_bndr)+  && all isDeadBinder alt_bndrs++-------------------+simple_out_bind :: TopLevelFlag+                -> SimpleOptEnv+                -> (InVar, OutExpr)+                -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)+  | Type out_ty <- out_rhs+  = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs)+    (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)++  | Coercion out_co <- out_rhs+  = assert (isCoVar in_bndr)+    (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing)++  | otherwise+  = simple_out_bind_pair env in_bndr Nothing out_rhs+                         (idOccInfo in_bndr) True False top_level++-------------------+simple_out_bind_pair :: SimpleOptEnv+                     -> InId -> Maybe OutId -> OutExpr+                     -> OccInfo -> Bool -> Bool -> TopLevelFlag+                     -> (SimpleOptEnv, Maybe (OutVar, OutExpr))+simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts })+                     in_bndr mb_out_bndr out_rhs+                     occ_info active stable_unf top_level+  | assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)+    -- Type and coercion bindings are caught earlier+    -- See Note [Core type and coercion invariant]+    post_inline_unconditionally+  = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs }+    , Nothing)++  | otherwise+  = ( env', Just (out_bndr, out_rhs) )+  where+    (env', bndr1) = case mb_out_bndr of+                      Just out_bndr -> (env, out_bndr)+                      Nothing       -> subst_opt_bndr env in_bndr+    out_bndr = add_info env' in_bndr top_level out_rhs bndr1++    post_inline_unconditionally :: Bool+    post_inline_unconditionally+       | not (so_inline opts)  = False -- Not if so_inline is False+       | isExportedId in_bndr  = False -- Note [Exported Ids and trivial RHSs]+       | stable_unf            = False -- Note [Stable unfoldings and postInlineUnconditionally]+       | not active            = False --     in GHC.Core.Opt.Simplify.Utils+       | is_loop_breaker       = False -- If it's a loop-breaker of any kind, don't inline+                                       -- because it might be referred to "earlier"+       | exprIsTrivial out_rhs = True+       | coercible_hack        = True+       | otherwise             = False++    is_loop_breaker = isWeakLoopBreaker occ_info++    -- See Note [Getting the map/coerce RULE to work]+    coercible_hack | (Var fun, args) <- collectArgs out_rhs+                   , Just dc <- isDataConWorkId_maybe fun+                   , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey+                   = all exprIsTrivial args+                   | otherwise+                   = False++{- Note [Exported Ids and trivial RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously do not want to unconditionally inline an Id that is exported.+In GHC.Core.Opt.Simplify.Utils, Note [Top level and postInlineUnconditionally], we+explain why we don't inline /any/ top-level things unconditionally, even+trivial ones.  But we do here!  Why?  In the simple optimiser++  * We do no rule rewrites+  * We do no call-site inlining++Those differences obviate the reasons for not inlining a trivial rhs,+and increase the benefit for doing so.  So we unconditionally inline trivial+rhss here.++Note [Eliminate casts in function position]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following program:++  type R :: Type -> RuntimeRep+  type family R a where { R Float = FloatRep; R Double = DoubleRep }+  type F :: forall (a :: Type) -> TYPE (R a)+  type family F a where { F Float = Float#  ; F Double = Double# }++  type N :: forall (a :: Type) -> TYPE (R a)+  newtype N a = MkN (F a)++As MkN is a newtype, its unfolding is a lambda which wraps its argument+in a cast:++  MkN :: forall (a :: Type). F a -> N a+  MkN = /\a \(x::F a). x |> co_ax+    -- recall that F a :: TYPE (R a)++This is a representation-polymorphic lambda, in which the binder has an unknown+representation (R a). We can't compile such a lambda on its own, but we can+compile instantiations, such as `MkN @Float` or `MkN @Double`.++Our strategy to avoid running afoul of the representation-polymorphism+invariants of Note [Representation polymorphism invariants] in GHC.Core is thus:++  1. Give the newtype a compulsory unfolding (it has no binding, as we can't+     define lambdas with representation-polymorphic value binders in source Haskell).+  2. Rely on the optimiser to beta-reduce away any representation-polymorphic+     value binders.++For example, consider the application++    MkN @Float 34.0#++After inlining MkN we'll get++   ((/\a \(x:F a). x |> co_ax) @Float) |> co 34#++where co :: (F Float -> N Float) ~ (Float# ~ N Float)++But to actually beta-reduce that lambda, we need to push the 'co'+inside the `\x` with pushCoecionIntoLambda.  Hence the extra+equation for Cast-of-Lam in finish_app.++This is regrettably delicate.++Note [Preserve join-binding arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Be careful /not/ to eta-reduce the RHS of a join point, lest we lose+the join-point arity invariant.  #15108 was caused by simplifying+the RHS with simple_opt_expr, which does eta-reduction.  Solution:+simplify the RHS of a join point by simplifying under the lambdas+(which of course should be there).++Note [simple_app and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general for let-bindings we can do this:+   (let { x = e } in b) a  ==>  let { x = e } in b a++But not for join points!  For two reasons:++- We would need to push the continuation into the RHS:+   (join { j = e } in b) a  ==>  let { j' = e a } in b[j'/j] a+                                      NB ----^^+  and also change the type of j, hence j'.+  That's a bit sophisticated for the very simple optimiser.++- We might end up with something like+    join { j' = e a } in+    (case blah of        )+    (  True  -> j' void# ) a+    (  False -> blah     )+  and now the call to j' doesn't look like a tail call, and+  Lint may reject.  I say "may" because this is /explicitly/+  allowed in the "Compiling without Continuations" paper+  (Section 3, "Managing \Delta").  But GHC currently does not+  allow this slightly-more-flexible form.  See GHC.Core+  Note [Join points are less general than the paper].++The simple thing to do is to disable this transformation+for join points in the simple optimiser++Note [The Let-Unfoldings Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A program has the Let-Unfoldings property iff:++- For every let-bound variable f, whether top-level or nested, whether+  recursive or not:+  - Both the binding Id of f, and every occurrence Id of f, has an idUnfolding.+  - For non-INLINE things, that unfolding will be f's right hand sids+  - For INLINE things (which have a "stable" unfolding) that unfolding is+    semantically equivalent to f's RHS, but derived from the original RHS of f+    rather that its current RHS.++Informally, we can say that in a program that has the Let-Unfoldings property,+all let-bound Id's have an explicit unfolding attached to them.++Currently, the simplifier guarantees the Let-Unfoldings invariant for anything+it outputs.++-}++----------------------+subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar])+subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs++subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar)+subst_opt_bndr env bndr+  | isTyVar bndr  = (env { soe_subst = subst_tv }, tv')+  | isCoVar bndr  = (env { soe_subst = subst_cv }, cv')+  | otherwise     = subst_opt_id_bndr env bndr+  where+    subst           = soe_subst env+    (subst_tv, tv') = substTyVarBndr subst bndr+    (subst_cv, cv') = substCoVarBndr subst bndr++subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId)+-- Nuke all fragile IdInfo, unfolding, and RULES; it gets added back later by+-- add_info.+--+-- Rather like SimplEnv.substIdBndr+--+-- It's important to zap fragile OccInfo (which GHC.Core.Subst.substIdBndr+-- carefully does not do) because simplOptExpr invalidates it++subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id+  = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id)+  where+    Subst in_scope id_subst tv_subst cv_subst = subst++    id1    = uniqAway in_scope old_id+    id2    = updateIdTypeAndMult (substTyUnchecked subst) id1+    new_id = zapFragileIdInfo id2+             -- Zaps rules, unfolding, and fragile OccInfo+             -- The unfolding and rules will get added back later, by add_info++    new_in_scope = in_scope `extendInScopeSet` new_id++    no_change = new_id == old_id++        -- Extend the substitution if the unique has changed,+        -- See the notes with substTyVarBndr for the delSubstEnv+    new_id_subst+      | no_change = delVarEnv id_subst old_id+      | otherwise = extendVarEnv id_subst old_id (Var new_id)++    new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst+    new_inl   = delVarEnv inl old_id++----------------------+add_info :: SimpleOptEnv -> InVar -> TopLevelFlag -> OutExpr -> OutVar -> OutVar+add_info env old_bndr top_level new_rhs new_bndr+ | isTyVar old_bndr = new_bndr+ | otherwise        = lazySetIdInfo new_bndr new_info+ where+   subst    = soe_subst env+   uf_opts  = so_uf_opts (soe_opts env)+   old_info = idInfo old_bndr++   -- Add back in the rules and unfolding which were+   -- removed by zapFragileIdInfo in subst_opt_id_bndr.+   --+   -- See Note [The Let-Unfoldings Invariant]+   new_info = idInfo new_bndr `setRuleInfo`      new_rules+                              `setUnfoldingInfo` new_unfolding++   old_rules = ruleInfo old_info+   new_rules = substRuleInfo subst new_bndr old_rules++   old_unfolding = realUnfoldingInfo old_info+   new_unfolding | isStableUnfolding old_unfolding+                 = substUnfolding subst old_unfolding+                 | otherwise+                 = unfolding_from_rhs++   unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc+                                    (isTopLevel top_level)+                                    False -- may be bottom or not+                                    False -- Not a join point+                                    new_rhs Nothing++wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr+wrapLet Nothing      body = body+wrapLet (Just (b,r)) body = Let (NonRec b r) body++{-+Note [Inline prag in simplOpt]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If there's an INLINE/NOINLINE pragma that restricts the phase in+which the binder can be inlined, we don't inline here; after all,+we don't know what phase we're in.  Here's an example++  foo :: Int -> Int -> Int+  {-# INLINE foo #-}+  foo m n = inner m+     where+       {-# INLINE [1] inner #-}+       inner m = m+n++  bar :: Int -> Int+  bar n = foo n 1++When inlining 'foo' in 'bar' we want the let-binding for 'inner'+to remain visible until Phase 1++Note [Unfold compulsory unfoldings in RULE LHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user writes `RULES map coerce = coerce` as a rule, the rule+will only ever match if simpleOptExpr replaces coerce by its unfolding+on the LHS, because that is the core that the rule matching engine+will find. So do that for everything that has a compulsory+unfolding. Also see Note [Desugaring coerce as cast] in GHC.HsToCore.++However, we don't want to inline 'seq', which happens to also have a+compulsory unfolding, so we only do this unfolding only for things+that are always-active.  See Note [User-defined RULES for seq] in GHC.Types.Id.Make.++Note [Getting the map/coerce RULE to work]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to allow the "map/coerce" RULE to fire:++  {-# RULES "map/coerce" map coerce = coerce #-}++The naive core produced for this is++  forall a b (dict :: Coercible * a b).+    map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict'++  where dict' :: Coercible [a] [b]+        dict' = ...++This matches literal uses of `map coerce` in code, but that's not what we+want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)+too.  Achieving all this is surprisingly tricky:++(MC1) We must compulsorily unfold MkAge to a cast.+      See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make++(MC2) We must compulsorily unfold coerce on the rule LHS, yielding+        forall a b (dict :: Coercible * a b).+          map @a @b (\(x :: a) -> case dict of+            MkCoercible (co :: a ~R# b) -> x |> co) = ...++  Getting better. But this isn't exactly what gets produced. This is because+  Coercible essentially has ~R# as a superclass, and superclasses get eagerly+  extracted during solving. So we get this:++    forall a b (dict :: Coercible * a b).+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+                                 MkCoercible (co :: a ~R# b) -> x |> co) = ...++  Unfortunately, this still abstracts over a Coercible dictionary. We really+  want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,+  which transforms the above to++    forall a b (co :: a ~R# b).+      let dict = MkCoercible @* @a @b co in+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+           MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...++  See Note [Desugaring coerce as cast] in GHC.HsToCore++(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three+  separate actions:+  1. Inline certain non-recursive bindings. The choice whether to inline+     is made in simple_bind_pair. Note the rather specific check for+     MkCoercible in there.++  2. Stripping case expressions like the Coercible_SCSel one.+     See the `Case` case of simple_opt_expr's `go` function.++  3. Look for case expressions that unpack something that was+     just packed and inline them. This is also done in simple_opt_expr's+     `go` function.++(MC4) The map/coerce rule is the only compelling reason for having a RULE that+  quantifies over a coercion variable, something that is otherwise Very Deeply+  Suspicious.  See Note [Casts in the template] in GHC.Core.Rules. Ugh!++This is all a fair amount of special-purpose hackery, but it's for+a good cause. And it won't hurt other RULES and such that it comes across.+++************************************************************************+*                                                                      *+                Join points+*                                                                      *+************************************************************************+-}++{- Note [Strictness and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   let f = \x.  if x>200 then e1 else e1++and we know that f is strict in x.  Then if we subsequently+discover that f is an arity-2 join point, we'll eta-expand it to++   let f = \x y.  if x>200 then e1 else e1++and now it's only strict if applied to two arguments.  So we should+adjust the strictness info.++A more common case is when++   f = \x. error ".."++and again its arity increases (#15517)+-}+++-- | Returns Just (bndr,rhs) if the binding is a join point:+-- If it's a JoinId, just return it+-- If it's not yet a JoinId but is always tail-called,+--    make it into a JoinId and return it.+-- In the latter case, eta-expand the RHS if necessary, to make the+-- lambdas explicit, as is required for join points+--+-- Precondition: the InBndr has been occurrence-analysed,+--               so its OccInfo is valid+joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr)+joinPointBinding_maybe bndr rhs+  | not (isId bndr)+  = Nothing++  | isJoinId bndr+  = Just (bndr, rhs)++  | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)+  , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs+  , let str_sig   = idDmdSig bndr+        str_arity = count isId bndrs  -- Strictness demands are for Ids only+        join_bndr = bndr `asJoinId`        join_arity+                         `setIdDmdSig` etaConvertDmdSig str_arity str_sig+  = Just (join_bndr, mkLams bndrs body)++  | otherwise+  = Nothing++joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]+joinPointBindings_maybe bndrs+  = mapM (uncurry joinPointBinding_maybe) bndrs+++{- *********************************************************************+*                                                                      *+         exprIsConApp_maybe+*                                                                      *+************************************************************************++Note [exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~+exprIsConApp_maybe is a very important function.  There are two principal+uses:+  * case e of { .... }+  * cls_op e, where cls_op is a class operation++In both cases you want to know if e is of form (C e1..en) where C is+a data constructor.++However e might not *look* as if+++Note [exprIsConApp_maybe on literal strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #9400 and #13317.++Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core+they are represented as unpackCString# "abc"# by GHC.Core.Make.mkStringExprFS, or+unpackCStringUtf8# when the literal contains multi-byte UTF8 characters.++For optimizations we want to be able to treat it as a list, so they can be+decomposed when used in a case-statement. exprIsConApp_maybe detects those+calls to unpackCString# and returns:++Just (':', [Char], ['a', unpackCString# "bc"]).++We need to be careful about UTF8 strings here. ""# contains an encoded ByteString, so+we call utf8UnconsByteString to correctly deal with the encoding and splitting.++We must also be careful about+   lvl = "foo"#+   ...(unpackCString# lvl)...+to ensure that we see through the let-binding for 'lvl'.  Hence the+(exprIsLiteral_maybe .. arg) in the guard before the call to+dealWithStringLiteral.++The tests for this function are in T9400.++Note [Push coercions in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #13025 I found a case where we had+    op (df @t1 @t2)     -- op is a ClassOp+where+    df = (/\a b. K e1 e2) |> g++To get this to come out we need to simplify on the fly+   ((/\a b. K e1 e2) |> g) @t1 @t2++Hence the use of pushCoArgs.++Note [exprIsConApp_maybe on data constructors with wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem:+- some data constructors have wrappers+- these wrappers inline late (see MkId Note [Activation for data constructor wrappers])+- but we still want case-of-known-constructor to fire early.++Example:+   data T = MkT !Int+   $WMkT n = case n of n' -> MkT n'   -- Wrapper for MkT+   foo x = case $WMkT e of MkT y -> blah++Here we want the case-of-known-constructor transformation to fire, giving+   foo x = case e of x' -> let y = x' in blah++Here's how exprIsConApp_maybe achieves this:++0.  Start with scrutinee = $WMkT e++1.  Inline $WMkT on-the-fly.  That's why data-constructor wrappers are marked+    as expandable. (See GHC.Core.Utils.isExpandableApp.) Now we have+      scrutinee = (\n. case n of n' -> MkT n') e++2.  Beta-reduce the application, generating a floated 'let'.+    See Note [beta-reduction in exprIsConApp_maybe] below.  Now we have+      scrutinee = case n of n' -> MkT n'+      with floats {Let n = e}++3.  Float the "case x of x' ->" binding out.  Now we have+      scrutinee = MkT n'+      with floats {Let n = e; case n of n' ->}++And now we have a known-constructor MkT that we can return.++Notice that both (2) and (3) require exprIsConApp_maybe to gather and return+a bunch of floats, both let and case bindings.++Note that this strategy introduces some subtle scenarios where a data-con+wrapper can be replaced by a data-con worker earlier than we’d like, see+Note [exprIsConApp_maybe for data-con wrappers: tricky corner].++Note [beta-reduction in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is+typically a function. For instance, take the wrapper for MkT in Note+[exprIsConApp_maybe on data constructors with wrappers]:++    $WMkT n = case n of { n' -> T n' }++If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT,+it will see++   (\n -> case n of { n' -> T n' }) arg++In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction.++We don't want to blindly substitute `arg` in the body of the function, because+it duplicates work. We can (and, in fact, used to) substitute `arg` in the body,+but only when `arg` is a variable (or something equally work-free).++But, because of Note [exprIsConApp_maybe on data constructors with wrappers],+'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce+_always_:++    (\x -> body) arg++Is transformed into++   let x = arg in body++Which, effectively, means emitting a float `let x = arg` and recursively+analysing the body.++For newtypes, this strategy requires that their wrappers have compulsory unfoldings.+Suppose we have+   newtype T a b where+     MkT :: a -> T b a   -- Note args swapped++This defines a worker function MkT, a wrapper function $WMkT, and an axT:+   $WMkT :: forall a b. a -> T b a+   $WMkT = /\b a. \(x:a). MkT a b x    -- A real binding++   MkT :: forall a b. a -> T a b+   MkT = /\a b. \(x:a). x |> (ax a b)  -- A compulsory unfolding++   axiom axT :: a ~R# T a b++Now we are optimising+   case $WMkT (I# 3) |> sym axT of I# y -> ...+we clearly want to simplify this. If $WMkT did not have a compulsory+unfolding, we would end up with+   let a = I# 3 in case a of I# y -> ...+because in general, we do this on-the-fly beta-reduction+   (\x. e) blah  -->  let x = blah in e+and then float the let.  (Substitution would risk duplicating 'blah'.)++But if the case-of-known-constructor doesn't actually fire (i.e.+exprIsConApp_maybe does not return Just) then nothing happens, and nothing+will happen the next time either.++See test T16254, which checks the behavior of newtypes.++Note [Exploit occ-info in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#23159) we have a simple data constructor wrapper like this (this one+might have come from a data family instance):+   $WK x y = K x y |> co+Now suppose the simplifier sees+   case ($WK e1 e2) |> co2 of+      K p q ->  case q of ...++`exprIsConApp_maybe` expands the wrapper on the fly+(see Note [beta-reduction in exprIsConApp_maybe]). It effectively expands+that ($WK e1 e2) to+   let x = e1; y = e2 in K x y |> co++So the Simplifier might end up producing this:+   let x = e1; y = e2+   in case x of ...++But suppose `q` was used just once in the body of the `K p q` alternative; we+don't want to wait a whole Simplifier iteration to inline that `x`.  (e1 might+be another constructor for example.)  This would happen if `exprIsConApp_maybe`+we created a let for every (non-trivial) argument.  So let's not do that when+the binder is used just once!++Instead, take advantage of the occurrence-info on `x` and `y` in the unfolding+of `$WK`.  Since in `$WK` both `x` and `y` occur once, we want to effectively+expand `($WK e1 e2)` to `(K e1 e2 |> co)`.  Hence in+`do_beta_by_substitution` we say "yes" if++  (a) the RHS is trivial (so we can duplicate it);+      see call to `exprIsTrivial`+or+  (b) the binder occurs at most once (so there is no worry about duplication);+      see call to `safe_to_inline`.++To see this in action, look at testsuite/tests/perf/compiler/T15703.  The+initial Simlifier run takes 5 iterations without (b), but only 3 when we add+(b).++Note [Don't float join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+exprIsConApp_maybe should succeed on+   let v = e in Just v+returning [x=e] as one of the [FloatBind].  But it must+NOT succeed on+   join j x = rhs in Just v+because join-points can't be gaily floated.  Consider+   case (join j x = rhs in Just) of+     K p q -> blah+We absolutely must not "simplify" this to+   join j x = rhs+   in blah+because j's return type is (Maybe t), quite different to blah's.++You might think this could never happen, because j can't be+tail-called in the body if the body returns a constructor.  But+in !3113 we had a /dead/ join point (which is not illegal),+and its return type was wonky.++The simple thing is not to float a join point.  The next iteration+of the simplifier will sort everything out.  And it there is+a join point, the chances are that the body is not a constructor+application, so failing faster is good.++Note [exprIsConApp_maybe for data-con wrappers: tricky corner]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking++  * exprIsConApp_maybe honours the inline phase; that is, it does not look+    inside the unfolding for an Id unless its unfolding is active in this phase.+    That phase-sensitivity is expressed in the InScopeEnv (specifically, the+    IdUnfoldingFun component of the InScopeEnv) passed to exprIsConApp_maybe.++  * Data-constructor wrappers are active only in phase 0 (the last phase);+    see Note [Activation for data constructor wrappers] in GHC.Types.Id.Make.++On the face of it that means that exprIsConApp_maybe won't look inside data+constructor wrappers until phase 0. But that seems pretty Bad. So we cheat.+For data con wrappers we unconditionally look inside its unfolding, regardless+of phase, so that we get case-of-known-constructor to fire in every phase.++Perhaps unsurprisingly, this cheating can backfire. An example:++    data T = C !A B+    foo p q = let x = C e1 e2 in seq x $ f x+    {-# RULE "wurble" f (C a b) = b #-}++In Core, the RHS of foo is++    let x = $WC e1 e2 in case x of y { C _ _ -> f x }++and after doing a binder swap and inlining x, we have:++    case $WC e1 e2 of y { C _ _ -> f y }++Case-of-known-constructor fires, but now we have to reconstruct a binding for+`y` (which was dead before the binder swap) on the RHS of the case alternative.+Naturally, we’ll use the worker:++    case e1 of a { DEFAULT -> let y = C a e2 in f y }++and after inlining `y`, we have:++    case e1 of a { DEFAULT -> f (C a e2) }++Now we might hope the "wurble" rule would fire, but alas, it will not: we have+replaced $WC with C, but the (desugared) rule matches on $WC! We weren’t+supposed to inline $WC yet for precisely that reason (see Note [Activation for+data constructor wrappers]), but our cheating in exprIsConApp_maybe came back to+bite us.++This is rather unfortunate, especially since this can happen inside stable+unfoldings as well as ordinary code (which really happened, see !3041). But+there is no obvious solution except to delay case-of-known-constructor on+data-con wrappers, and that cure would be worse than the disease.++This Note exists solely to document the problem.+-}++data ConCont = CC [CoreExpr] MCoercion+                  -- Substitution already applied++-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument+-- expression is a *saturated* constructor application of the form @let b1 in+-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the+-- *universally-quantified* type args of 'dc'. Floats can also be (and most+-- likely are) single-alternative case expressions. Why does+-- 'exprIsConApp_maybe' return floats? We may have to look through lets and+-- cases to detect that we are in the presence of a data constructor wrapper. In+-- this case, we need to return the lets and cases that we traversed. See Note+-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers+-- are unfolded late, but we really want to trigger case-of-known-constructor as+-- early as possible. See also Note [Activation for data constructor wrappers]+-- in "GHC.Types.Id.Make".+--+-- We also return the incoming InScopeSet, augmented with+-- the binders from any [FloatBind] that we return+exprIsConApp_maybe :: HasDebugCallStack+                   => InScopeEnv -> CoreExpr+                   -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])+exprIsConApp_maybe ise@(ISE in_scope id_unf) expr+  = go (Left in_scope) [] expr (CC [] MRefl)+  where+    go :: Either InScopeSet Subst+             -- Left in-scope  means "empty substitution"+             -- Right subst    means "apply this substitution to the CoreExpr"+             -- NB: in the call (go subst floats expr cont)+             --     the substitution applies to 'expr', but /not/ to 'floats' or 'cont'+       -> [FloatBind] -> CoreExpr -> ConCont+             -- Notice that the floats here are in reverse order+       -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])+    go subst floats (Tick t expr) cont+       | not (tickishIsCode t) = go subst floats expr cont++    go subst floats (Cast expr co1) (CC args m_co2)+       | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args+            -- See Note [Push coercions in exprIsConApp_maybe]+       = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2))++    go subst floats (App fun arg) (CC args mco)+       | let arg_type = exprType arg+       , not (isTypeArg arg) && needsCaseBinding arg_type arg+       -- An unlifted argument that’s not ok for speculation must not simply be+       -- put into the args, as these are going to be substituted into the case+       -- alternatives, and possibly lost on the way.+       --+       -- Instead, we need need to+       -- make sure they are evaluated right here (using a case float), and+       -- the case binder can then be substituted into the case alternaties.+       --+       -- Example:+       -- Simplifying  case Mk# exp of Mk# a → rhs+       -- will use     exprIsConApp_maybe (Mk# exp)+       --+       -- Bad:  returning (Mk#, [exp]) with no floats+       --       simplifier produces rhs[exp/a], changing semantics if exp is not ok-for-spec+       -- Good: returning (Mk#, [x]) with a float of  case exp of x { DEFAULT -> [] }+       --       simplifier produces case exp of a { DEFAULT -> exp[x/a] }+       , (subst', float, bndr) <- case_bind subst arg arg_type+       = go subst' (float:floats) fun (CC (Var bndr : args) mco)+       | otherwise+       = go subst floats fun (CC (subst_expr subst arg : args) mco)++    go subst floats (Lam bndr body) (CC (arg:args) mco)+       | do_beta_by_substitution bndr arg+       = go (extend subst bndr arg) floats body (CC args mco)+       | otherwise+       = let (subst', bndr') = subst_bndr subst bndr+             float           = FloatLet (NonRec bndr' arg)+         in go subst' (float:floats) body (CC args mco)++    go subst floats (Let (NonRec bndr rhs) expr) cont+       | not (isJoinId bndr)+         -- Crucial guard! See Note [Don't float join points]+       = let rhs'            = subst_expr subst rhs+             (subst', bndr') = subst_bndr subst bndr+             float           = FloatLet (NonRec bndr' rhs')+         in go subst' (float:floats) expr cont++    go subst floats (Case scrut b _ [Alt con vars expr]) cont+       | do_case_elim scrut' b vars  -- See Note [Case elim in exprIsConApp_maybe]+       = go (extend subst b scrut') floats expr cont+       | otherwise+       = let+          (subst', b')     = subst_bndr subst b+          (subst'', vars') = subst_bndrs subst' vars+          float            = FloatCase scrut' b' con vars'+         in+           go subst'' (float:floats) expr cont+       where+          scrut'           = subst_expr subst scrut++    go (Right sub) floats (Var v) cont+       = go (Left (substInScopeSet sub))+            floats+            (lookupIdSubst sub v)+            cont++    go (Left in_scope) floats (Var fun) cont@(CC args mco)++        | Just con <- isDataConWorkId_maybe fun+        , count isValArg args == idArity fun+        , (in_scope', seq_floats, args') <- mkFieldSeqFloats in_scope con args+          -- mkFieldSeqFloats: See (SFC2) in Note [Strict fields in Core]+        = succeedWith in_scope' (seq_floats ++ floats) $+          pushCoDataCon con args' mco++        -- Look through data constructor wrappers: they inline late (See Note+        -- [Activation for data constructor wrappers]) but we want to do+        -- case-of-known-constructor optimisation eagerly (see Note+        -- [exprIsConApp_maybe on data constructors with wrappers]).+        | Just rhs <- dataConWrapUnfolding_maybe fun+        = go (Left in_scope) floats rhs cont++        -- Look through dictionary functions; see Note [Unfolding DFuns]+        | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding+        , bndrs `equalLength` args    -- See Note [DFun arity check]+        , let in_scope' = extend_in_scope (exprsFreeVars dfun_args)+              subst = mkOpenSubst in_scope' (bndrs `zip` args)+              -- We extend the in-scope set here to silence warnings from+              -- substExpr when it finds not-in-scope Ids in dfun_args.+              -- simplOptExpr initialises the in-scope set with exprFreeVars,+              -- but that doesn't account for DFun unfoldings+        = succeedWith in_scope floats $+          pushCoDataCon con (map (substExpr subst) dfun_args) mco++        -- Look through unfoldings, but only arity-zero one;+        -- if arity > 0 we are effectively inlining a function call,+        -- and that is the business of callSiteInline.+        -- In practice, without this test, most of the "hits" were+        -- CPR'd workers getting inlined back into their wrappers,+        | idArity fun == 0+        , Just rhs <- expandUnfolding_maybe unfolding+        , let in_scope' = extend_in_scope (exprFreeVars rhs)+        = go (Left in_scope') floats rhs cont++        -- See Note [exprIsConApp_maybe on literal strings]+        | (fun `hasKey` unpackCStringIdKey) ||+          (fun `hasKey` unpackCStringUtf8IdKey)+        , [arg]              <- args+        , Just (LitString str) <- exprIsLiteral_maybe ise arg+        = succeedWith in_scope floats $+          dealWithStringLiteral fun str mco+        where+          unfolding = id_unf fun+          extend_in_scope unf_fvs+            | isLocalId fun = in_scope `extendInScopeSetSet` unf_fvs+            | otherwise     = in_scope+            -- A GlobalId has no (LocalId) free variables; and the+            -- in-scope set tracks only LocalIds++    go _ _ _ _ = Nothing++    succeedWith :: InScopeSet -> [FloatBind]+                -> Maybe (DataCon, [Type], [CoreExpr])+                -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])+    succeedWith in_scope rev_floats x+      = do { (con, tys, args) <- x+           ; let floats = reverse rev_floats+           ; return (in_scope, floats, con, tys, args) }++    ----------------------------+    -- Operations on the (Either InScopeSet GHC.Core.Subst)+    -- The Left case is wildly dominant++    subst_in_scope (Left in_scope) = in_scope+    subst_in_scope (Right s) = substInScopeSet s++    subst_extend_in_scope (Left in_scope) v = Left (in_scope `extendInScopeSet` v)+    subst_extend_in_scope (Right s) v = Right (s `extendSubstInScope` v)++    subst_co (Left {}) co = co+    subst_co (Right s) co = GHC.Core.Subst.substCo s co++    subst_expr (Left {}) e = e+    subst_expr (Right s) e = substExpr s e++    subst_bndr msubst bndr+      = (Right subst', bndr')+      where+        (subst', bndr') = substBndr subst bndr+        subst = case msubst of+                  Left in_scope -> mkEmptySubst in_scope+                  Right subst   -> subst++    subst_bndrs subst bs = mapAccumL subst_bndr subst bs++    extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e)+    extend (Right s)       v e = Right (extendSubst s v e)++    case_bind :: Either InScopeSet Subst -> CoreExpr -> Type -> (Either InScopeSet Subst, FloatBind, Id)+    case_bind subst expr expr_ty = (subst', float, bndr)+      where+        bndr   = setCaseBndrEvald MarkedStrict $+                 uniqAway (subst_in_scope subst) $+                 mkWildValBinder ManyTy expr_ty+        subst' = subst_extend_in_scope subst bndr+        expr'  = subst_expr subst expr+        float  = FloatCase expr' bndr DEFAULT []++    mkFieldSeqFloats :: InScopeSet -> DataCon -> [CoreExpr] -> (InScopeSet, [FloatBind], [CoreExpr])+    -- See Note [Strict fields in Core] for what a field seq is and (SFC2) for+    -- why we insert them+    mkFieldSeqFloats in_scope dc args+      | isLazyDataConRep dc+      = (in_scope, [], args)+      | otherwise+      = (in_scope', floats', ty_args ++ val_args')+      where+        (ty_args, val_args) = splitAtList (dataConUnivAndExTyCoVars dc) args+        (in_scope', floats', val_args') = foldr do_one (in_scope, [], []) $ zipEqual str_marks val_args+        str_marks = dataConRepStrictness dc+        do_one (str, arg) (in_scope,floats,args)+          | NotMarkedStrict <- str   = no_seq+          | exprIsHNF arg            = no_seq+          | otherwise                = (in_scope', float:floats, Var bndr:args)+          where+            no_seq = (in_scope, floats, arg:args)+            (in_scope', float, bndr) =+               case case_bind (Left in_scope) arg (exprType arg) of+                 (Left in_scope', float, bndr) -> (in_scope', float, bndr)+                 (right, _, _) -> pprPanic "case_bind did not preserve Left" (ppr in_scope $$ ppr arg $$ ppr right)++-- See Note [exprIsConApp_maybe on literal strings]+dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion+                      -> Maybe (DataCon, [Type], [CoreExpr])++-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS+-- turns those into [] automatically, but just in case something else in GHC+-- generates a string literal directly.+dealWithStringLiteral fun str mco =+  case utf8UnconsByteString str of+    Nothing -> pushCoDataCon nilDataCon [Type charTy] mco+    Just (char, charTail) ->+      let char_expr = mkConApp charDataCon [mkCharLit char]+          -- In singleton strings, just add [] instead of unpackCstring# ""#.+          rest = if BS.null charTail+                   then mkConApp nilDataCon [Type charTy]+                   else App (Var fun)+                            (Lit (LitString charTail))++      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco++{-+Note [Case elim in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   data K a = MkK !a++   $WMkK x = case x of y -> K y   -- Wrapper for MkK++   ...case $WMkK v of K w -> <rhs>++We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper+and beta-reduce, so we get to+   exprIsConApp_maybe (case v of y -> K y)++So we may float the case, and end up with+   case v of y -> <rhs>[y/w]++But if `v` is already evaluated, the next run of the Simplifier will+eliminate the case, and we may then make more progress with <rhs>.+Better to do it in one iteration.  Hence the `do_case_elim`+check in `exprIsConApp_maybe`.++Note [Unfolding DFuns]+~~~~~~~~~~~~~~~~~~~~~~+DFuns look like++  df :: forall a b. (Eq a, Eq b) -> Eq (a,b)+  df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)+                               ($c2 a b d_a d_b)++So to split it up we just need to apply the ops $c1, $c2 etc+to the very same args as the dfun.  It takes a little more work+to compute the type arguments to the dictionary constructor.++Note [DFun arity check]+~~~~~~~~~~~~~~~~~~~~~~~+Here we check that the total number of supplied arguments (including+type args) matches what the dfun is expecting.  This may be *less*+than the ordinary arity of the dfun: see Note [DFun unfoldings] in GHC.Core+-}++exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal+-- Same deal as exprIsConApp_maybe, but much simpler+-- Nevertheless we do need to look through unfoldings for+-- string literals, which are vigorously hoisted to top level+-- and not subsequently inlined+exprIsLiteral_maybe env@(ISE _ id_unf) e+  = case e of+      Lit l     -> Just l+      Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?+      Var v     -> expandUnfolding_maybe (id_unf v)+                    >>= exprIsLiteral_maybe env+      _         -> Nothing++{-+Note [exprIsLambda_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~+exprIsLambda_maybe will, given an expression `e`, try to turn it into the form+`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through+casts (using the Push rule), and it unfolds function calls if the unfolding+has a greater arity than arguments are present.++Currently, it is used in GHC.Core.Rules.match, and is required to make+"map coerce = coerce" match.+-}++exprIsLambda_maybe :: HasDebugCallStack+                   => InScopeEnv -> CoreExpr+                   -> Maybe (Var, CoreExpr,[CoreTickish])+    -- See Note [exprIsLambda_maybe]++-- The simple case: It is a lambda already+exprIsLambda_maybe _ (Lam x e)+    = Just (x, e, [])++-- Still straightforward: Ticks that we can float out of the way+exprIsLambda_maybe ise (Tick t e)+    | tickishFloatable t+    , Just (x, e, ts) <- exprIsLambda_maybe ise e+    = Just (x, e, t:ts)++-- Also possible: A casted lambda. Push the coercion inside+exprIsLambda_maybe ise@(ISE in_scope_set _) (Cast casted_e co)+    | Just (x, e,ts) <- exprIsLambda_maybe ise casted_e+    -- Only do value lambdas.+    -- this implies that x is not in scope in gamma (makes this code simpler)+    , not (isTyVar x) && not (isCoVar x)+    , assert (not $ x `elemVarSet` tyCoVarsOfCo co) True+    , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co+    , let res = Just (x',e',ts)+    = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)])+      res++-- Another attempt: See if we find a partial unfolding+exprIsLambda_maybe ise@(ISE in_scope_set id_unf) e+    | (Var f, as, ts) <- collectArgsTicks tickishFloatable e+    , idArity f > count isValArg as+    -- Make sure there is hope to get a lambda+    , Just rhs <- expandUnfolding_maybe (id_unf f)+    -- Optimize, for beta-reduction+    , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)+    -- Recurse, because of possible casts+    , Just (x', e'', ts') <- exprIsLambda_maybe ise e'+    , let res = Just (x', e'', ts++ts')+    = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')])+      res++exprIsLambda_maybe _ _e+    = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])+      Nothing
+ GHC/Core/SimpleOpt.hs-boot view
@@ -0,0 +1,11 @@+module GHC.Core.SimpleOpt where++import GHC.Core+import {-# SOURCE #-} GHC.Core.Unfold+import GHC.Utils.Misc (HasDebugCallStack)++data SimpleOpts++so_uf_opts :: SimpleOpts -> UnfoldingOpts++simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
+ GHC/Core/Stats.hs view
@@ -0,0 +1,138 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-2015+-}++-- | Functions to computing the statistics reflective of the "size"+-- of a Core expression+module GHC.Core.Stats (+        -- * Expression and bindings size+        coreBindsSize, exprSize,+        CoreStats(..), coreBindsStats, exprStats,+    ) where++import GHC.Prelude++import GHC.Types.Basic+import GHC.Core+import GHC.Utils.Outputable+import GHC.Core.Coercion+import GHC.Types.Tickish+import GHC.Types.Var+import GHC.Core.Type(Type, typeSize)+import GHC.Types.Id (isJoinId)++data CoreStats = CS { cs_tm :: !Int    -- Terms+                    , cs_ty :: !Int    -- Types+                    , cs_co :: !Int    -- Coercions+                    , cs_vb :: !Int    -- Local value bindings+                    , cs_jb :: !Int }  -- Local join bindings+++instance Outputable CoreStats where+ ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 })+   = braces (sep [text "terms:"     <+> intWithCommas i1 <> comma,+                  text "types:"     <+> intWithCommas i2 <> comma,+                  text "coercions:" <+> intWithCommas i3 <> comma,+                  text "joins:"     <+> intWithCommas i5 <> char '/' <>+                                        intWithCommas (i4 + i5) ])++plusCS :: CoreStats -> CoreStats -> CoreStats+plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 })+       (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 })+  = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2+       , cs_jb = j1+j2 }++zeroCS, oneTM :: CoreStats+zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 }+oneTM  = zeroCS { cs_tm = 1 }++sumCS :: (a -> CoreStats) -> [a] -> CoreStats+sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS++coreBindsStats :: [CoreBind] -> CoreStats+coreBindsStats = sumCS (bindStats TopLevel)++bindStats :: TopLevelFlag -> CoreBind -> CoreStats+bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r+bindStats top_lvl (Rec prs)    = sumCS (\(v,r) -> bindingStats top_lvl v r) prs++bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats+bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r++bndrStats :: Var -> CoreStats+bndrStats v = oneTM `plusCS` tyStats (varType v)++letBndrStats :: TopLevelFlag -> Var -> CoreStats+letBndrStats top_lvl v+  | isTyVar v || isTopLevel top_lvl = bndrStats v+  | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats+  | otherwise  = oneTM { cs_vb = 1 } `plusCS` ty_stats+  where+    ty_stats = tyStats (varType v)++exprStats :: CoreExpr -> CoreStats+exprStats (Var {})        = oneTM+exprStats (Lit {})        = oneTM+exprStats (Type t)        = tyStats t+exprStats (Coercion c)    = coStats c+exprStats (App f a)       = exprStats f `plusCS` exprStats a+exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e+exprStats (Let b e)       = bindStats NotTopLevel b `plusCS` exprStats e+exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b+                                        `plusCS` sumCS altStats as+exprStats (Cast e co)     = coStats co `plusCS` exprStats e+exprStats (Tick _ e)      = exprStats e++altStats :: CoreAlt -> CoreStats+altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r++altBndrStats :: [Var] -> CoreStats+-- Charge one for the alternative, not for each binder+altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs++tyStats :: Type -> CoreStats+tyStats ty = zeroCS { cs_ty = typeSize ty }++coStats :: Coercion -> CoreStats+coStats co = zeroCS { cs_co = coercionSize co }++coreBindsSize :: [CoreBind] -> Int+-- We use coreBindsStats for user printout+-- but this one is a quick and dirty basis for+-- the simplifier's tick limit+coreBindsSize bs = sum (map bindSize bs)++exprSize :: CoreExpr -> Int+-- ^ A measure of the size of the expressions, strictly greater than 0+-- Counts *leaves*, not internal nodes. Types and coercions are not counted.+exprSize (Var _)         = 1+exprSize (Lit _)         = 1+exprSize (App f a)       = exprSize f + exprSize a+exprSize (Lam b e)       = bndrSize b + exprSize e+exprSize (Let b e)       = bindSize b + exprSize e+exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as)+exprSize (Cast e _)      = 1 + exprSize e+exprSize (Tick n e)      = tickSize n + exprSize e+exprSize (Type _)        = 1+exprSize (Coercion _)    = 1++tickSize :: CoreTickish -> Int+tickSize (ProfNote _ _ _) = 1+tickSize _ = 1++bndrSize :: Var -> Int+bndrSize _ = 1++bndrsSize :: [Var] -> Int+bndrsSize = sum . map bndrSize++bindSize :: CoreBind -> Int+bindSize (NonRec b e) = bndrSize b + exprSize e+bindSize (Rec prs)    = sum (map pairSize prs)++pairSize :: (Var, CoreExpr) -> Int+pairSize (b,e) = bndrSize b + exprSize e++altSize :: CoreAlt -> Int+altSize (Alt _ bs e) = bndrsSize bs + exprSize e
+ GHC/Core/Subst.hs view
@@ -0,0 +1,686 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utility functions on @Core@ syntax+-}++module GHC.Core.Subst (+        -- * Main data types+        Subst(..), -- Implementation exported for supercompiler's Renaming.hs only+        TvSubstEnv, IdSubstEnv, InScopeSet,++        -- ** Substituting into expressions and related types+        deShadowBinds, substRuleInfo, substRulesForImportedIds,+        substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,+        substUnfolding, substUnfoldingSC,+        lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,+        substTickish, substDVarSet, substIdInfo,++        -- ** Operations on substitutions+        emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,+        extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,+        extendIdSubstWithClone,+        extendSubst, extendSubstList, extendSubstWithVar,+        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,+        isInScope, setInScope, substInScopeSet,+        extendTvSubst, extendCvSubst,+        delBndr, delBndrs, zapSubst,++        -- ** Substituting and cloning binders+        substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,+        cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,+        cloneBndrsM, cloneRecIdBndrsM,++    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Seq+import GHC.Core.Utils++        -- We are defining local versions+import GHC.Core.Type hiding ( substTy )+import GHC.Core.Coercion+    ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr )++import GHC.Types.Var.Set+import GHC.Types.Var.Env as InScopeSet+import GHC.Types.Id+import GHC.Types.Name     ( Name )+import GHC.Types.Var+import GHC.Types.Tickish+import GHC.Types.Id.Info+import GHC.Types.Unique.Supply++import GHC.Builtin.Names+import GHC.Data.Maybe++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.Functor.Identity (Identity (..))+import Data.List (mapAccumL)++{-+************************************************************************+*                                                                      *+\subsection{Substitutions}+*                                                                      *+************************************************************************+-}++{-+Note [Extending the IdSubstEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a different choice for Ids than we do for TyVars.++For TyVars, see Note [Extending the TvSubstEnv and CvSubstEnv] in GHC.Core.TyCo.Subst.++For Ids, we have a different invariant+        The IdSubstEnv is extended *only* when the Unique on an Id changes+        Otherwise, we just extend the InScopeSet++In consequence:++* If all subst envs are empty, substExpr would be a+  no-op, so substExprSC ("short cut") does nothing.++  However, substExpr still goes ahead and substitutes.  Reason: we may+  want to replace existing Ids with new ones from the in-scope set, to+  avoid space leaks.++* In substIdBndr, we extend the IdSubstEnv only when the unique changes++* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,+  substExpr does nothing (Note that the above rule for substIdBndr+  maintains this property.  If the incoming envts are both empty, then+  substituting the type and IdInfo can't change anything.)++* In lookupIdSubst, we *must* look up the Id in the in-scope set, because+  it may contain non-trivial changes.  Example:+        (/\a. \x:a. ...x...) Int+  We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change+  so we only extend the in-scope set.  Then we must look up in the in-scope+  set when we find the occurrence of x.++* The requirement to look up the Id in the in-scope set means that we+  must NOT take no-op short cut when the IdSubst is empty.+  We must still look up every Id in the in-scope set.++* (However, we don't need to do so for expressions found in the IdSubst+  itself, whose range is assumed to be correct wrt the in-scope set.)++Why do we make a different choice for the IdSubstEnv than the+TvSubstEnv and CvSubstEnv?++* For Ids, we change the IdInfo all the time (e.g. deleting the+  unfolding), and adding it back later, so using the TyVar convention+  would entail extending the substitution almost all the time++* The simplifier wants to look up in the in-scope set anyway, in case it+  can see a better unfolding from an enclosing case expression++* For TyVars, only coercion variables can possibly change, and they are+  easy to spot+-}++----------------------------++-- We keep GHC.Core.Subst separate from GHC.Core.TyCo.Subst to avoid creating+-- circular dependencies. Functions in this file that don't depend on+-- the definition of CoreExpr can be moved to GHC.Core.TyCo.Subst, as long+-- as it does not require importing too many additional hs-boot files and+-- cause a significant drop in performance.++-- | 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+extendIdSubst :: Subst -> Id -> CoreExpr -> Subst+-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set+extendIdSubst (Subst in_scope ids tvs cvs) v r+  = assertPpr (isNonCoVarId v) (ppr v $$ ppr r) $+    Subst in_scope (extendVarEnv ids v r) tvs cvs++extendIdSubstWithClone :: Subst -> Id -> Id -> Subst+extendIdSubstWithClone (Subst in_scope ids tvs cvs) v v'+  = assertPpr (isNonCoVarId v) (ppr v $$ ppr v') $+    Subst (extendInScopeSetSet in_scope new_in_scope)+          (extendVarEnv ids v (varToCoreExpr v')) tvs cvs+    where+      new_in_scope = tyCoVarsOfType (varType v') `extendVarSet` v'++-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'+extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst+extendIdSubstList (Subst in_scope ids tvs cvs) prs+  = assert (all (isNonCoVarId . fst) prs) $+    Subst in_scope (extendVarEnvList ids prs) tvs cvs++-- | Add a substitution appropriate to the thing being substituted+--   (whether an expression, type, or coercion). See also+--   'extendIdSubst', 'extendTvSubst', 'extendCvSubst'+extendSubst :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst+extendSubst subst var arg+  = case arg of+      Type ty     -> assertPpr (isTyVar var) doc $ extendTvSubst subst var ty+      Coercion co -> assertPpr (isCoVar var) doc $ extendCvSubst subst var co+      _           -> assertPpr (isId    var) doc $ extendIdSubst subst var arg+  where+   doc = ppr var <+> text ":=" <+> ppr arg++extendSubstWithVar :: Subst -> Var -> Var -> Subst+extendSubstWithVar subst v1 v2+  | isTyVar v1 = assert (isTyVar v2) $ extendTvSubst subst v1 (mkTyVarTy v2)+  | isCoVar v1 = assert (isCoVar v2) $ extendCvSubst subst v1 (mkCoVarCo v2)+  | otherwise  = assert (isId    v2) $ extendIdSubst subst v1 (Var v2)++-- | Add a substitution as appropriate to each of the terms being+--   substituted (whether expressions, types, or coercions). See also+--   'extendSubst'.+extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst+extendSubstList subst []              = subst+extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs++-- | Find the substitution for an 'Id' in the 'Subst'+-- The Id should not be a CoVar+lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr+lookupIdSubst (Subst in_scope ids _ _) v+  | assertPpr (isId v && not (isCoVar v)) (ppr v)+    not (isLocalId v)                   = Var v+  | Just e  <- lookupVarEnv ids       v = e+  | Just v' <- lookupInScope in_scope v = Var v'+        -- Vital! See Note [Extending the IdSubstEnv]+        -- If v isn't in the InScopeSet, we panic, because+        -- it's a bad bug and we really want to know+  | otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)++lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr+-- Just look up in the substitution; do not check the in-scope set+lookupIdSubst_maybe (Subst _ ids _ _) v+  = assertPpr (isId v && not (isCoVar v)) (ppr v) $+    lookupVarEnv ids v++delBndr :: Subst -> Var -> Subst+delBndr (Subst in_scope ids tvs cvs) v+  | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)+  | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs+  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs++delBndrs :: Subst -> [Var] -> Subst+delBndrs (Subst in_scope ids tvs cvs) vs+  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)+      -- Easiest thing is just delete all from all!++-- | Simultaneously substitute for a bunch of variables+--   No left-right shadowing+--   ie the substitution for   (\x \y. e) a1 a2+--      so neither x nor y scope over a1 a2+mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst+mkOpenSubst in_scope pairs = Subst in_scope+                                   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])+                                   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])+                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])++------------------------------++{-+************************************************************************+*                                                                      *+        Substituting expressions+*                                                                      *+************************************************************************+-}++substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr+-- Just like substExpr, but a no-op if the substitution is empty+-- Note that this does /not/ replace occurrences of free vars with+-- their canonical representatives in the in-scope set+substExprSC subst orig_expr+  | isEmptySubst subst = orig_expr+  | otherwise          = substExpr subst orig_expr++-- | substExpr applies a substitution to an entire 'CoreExpr'. Remember,+-- you may only apply the substitution /once/:+-- See Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst"+--+-- Do *not* attempt to short-cut in the case of an empty substitution!+-- See Note [Extending the IdSubstEnv]+substExpr :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr+   -- HasDebugCallStack so we can track failures in lookupIdSubst+substExpr subst expr+  = go expr+  where+    go (Var v)         = lookupIdSubst subst v+    go (Type ty)       = Type (substTyUnchecked subst ty)+    go (Coercion co)   = Coercion (substCo subst co)+    go (Lit lit)       = Lit lit+    go (App fun arg)   = App (go fun) (go arg)+    go (Tick tickish e) = mkTick (substTickish subst tickish) (go e)+    go (Cast e co)     = Cast (go e) (substCo subst co)+       -- Do not optimise even identity coercions+       -- Reason: substitution applies to the LHS of RULES, and+       --         if you "optimise" an identity coercion, you may+       --         lose a binder. We optimise the LHS of rules at+       --         construction time++    go (Lam bndr body) = Lam bndr' (substExpr subst' body)+                       where+                         (subst', bndr') = substBndr subst bndr++    go (Let bind body) = Let bind' (substExpr subst' body)+                       where+                         (subst', bind') = substBind subst bind++    go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts)+                                 where+                                 (subst', bndr') = substBndr subst bndr++    go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs)+                                 where+                                   (subst', bndrs') = substBndrs subst bndrs++-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst'+-- that should be used by subsequent substitutions.+substBind, substBindSC :: HasDebugCallStack => Subst -> CoreBind -> (Subst, CoreBind)++substBindSC subst bind    -- Short-cut if the substitution is empty+  | not (isEmptySubst subst)+  = substBind subst bind+  | otherwise+  = case bind of+       NonRec bndr rhs -> (subst', NonRec bndr' rhs)+          where+            (subst', bndr') = substBndr subst bndr+       Rec pairs -> (subst', Rec (bndrs' `zip` rhss'))+          where+            (bndrs, rhss)    = unzip pairs+            (subst', bndrs') = substRecBndrs subst bndrs+            rhss' | isEmptySubst subst'+                  = rhss+                  | otherwise+                  = map (substExpr subst') rhss++substBind subst (NonRec bndr rhs)+  = (subst', NonRec bndr' (substExpr subst rhs))+  where+    (subst', bndr') = substBndr subst bndr++substBind subst (Rec pairs)+   = (subst', Rec (bndrs' `zip` rhss'))+   where+       (bndrs, rhss)    = unzip pairs+       (subst', bndrs') = substRecBndrs subst bndrs+       rhss' = map (substExpr subst') rhss++-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply+-- by running over the bindings with an empty substitution, because substitution+-- returns a result that has no-shadowing guaranteed.+--+-- (Actually, within a single /type/ there might still be shadowing, because+-- 'substTy' is a no-op for the empty substitution, but that's probably OK.)+--+-- [Aug 09] This function is not used in GHC at the moment, but seems so+--          short and simple that I'm going to leave it here+deShadowBinds :: CoreProgram -> CoreProgram+deShadowBinds binds = snd (mapAccumL substBind emptySubst binds)++{-+************************************************************************+*                                                                      *+        Substituting binders+*                                                                      *+************************************************************************++Remember that substBndr and friends are used when doing expression+substitution only.  Their only business is substitution, so they+preserve all IdInfo (suitably substituted).  For example, we *want* to+preserve occ info in rules.+-}++-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning+-- the result and an updated 'Subst' that should be used by subsequent substitutions.+-- 'IdInfo' is preserved by this process, although it is substituted into appropriately.+substBndr :: Subst -> Var -> (Subst, Var)+substBndr subst bndr+  | isTyVar bndr  = substTyVarBndr subst bndr+  | isCoVar bndr  = substCoVarBndr subst bndr+  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr++-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right+substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var)+substBndrs = mapAccumL substBndr+{-# INLINE substBndrs #-}++-- | Substitute in a mutually recursive group of 'Id's+substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id)+substRecBndrs subst bndrs+  = (new_subst, new_bndrs)+  where         -- Here's the reason we need to pass rec_subst to subst_id+    (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs+{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-}+{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-}++substIdBndr :: SDoc+            -> Subst            -- ^ Substitution to use for the IdInfo+            -> Subst -> Id      -- ^ Substitution and Id to transform+            -> (Subst, Id)      -- ^ Transformed pair+                                -- NB: unfolding may be zapped++substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id+  = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $+    (Subst new_in_scope new_env tvs cvs, new_id)+  where+    id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary+    id2 | no_type_change = id1+        | otherwise      = updateIdTypeAndMult (substTyUnchecked subst) id1++    old_ty = idType old_id+    old_w = idMult old_id+    no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||+                     (noFreeVarsOfType old_ty && noFreeVarsOfType old_w)++        -- new_id has the right IdInfo+        -- The lazy-set is because we're in a loop here, with+        -- rec_subst, when dealing with a mutually-recursive group+    !new_id = maybeModifyIdInfo mb_new_info id2+    mb_new_info = substIdInfo rec_subst id2 (idInfo id2)+        -- NB: unfolding info may be zapped++        -- Extend the substitution if the unique has changed+        -- See the notes with substTyVarBndr for the delVarEnv+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    !new_env | no_change = delVarEnv env old_id+             | otherwise = extendVarEnv env old_id (Var new_id)++    no_change = id1 == old_id+        -- See Note [Extending the IdSubstEnv]+        -- it's /not/ necessary to check mb_new_info and no_type_change++{-+Now a variant that unconditionally allocates a new unique.+It also unconditionally zaps the OccInfo.+-}++-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for+-- each variable in its output.  It substitutes the IdInfo though.+-- Discards non-Stable unfoldings+cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id)+cloneIdBndr subst us old_id+  = clone_id subst subst (old_id, uniqFromSupply us)++-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final+-- substitution from left to right+-- Discards non-Stable unfoldings+cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])+cloneIdBndrs subst us ids+  = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)++cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var])+-- Works for all kinds of variables (typically case binders)+-- not just Ids+cloneBndrs subst us vs+  = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us)++cloneBndrsM :: MonadUnique m => Subst -> [Var] -> m (Subst, [Var])+-- Works for all kinds of variables (typically case binders)+-- not just Ids+cloneBndrsM subst vs = cloneBndrs subst `flip` vs <$> getUniqueSupplyM++cloneBndr :: Subst -> Unique -> Var -> (Subst, Var)+cloneBndr subst uniq v+  | isTyVar v = cloneTyVarBndr subst v uniq+  | otherwise = clone_id subst subst (v,uniq)  -- Works for coercion variables too++-- | Clone a mutually recursive group of 'Id's+cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id])+cloneRecIdBndrs subst us ids =+    let x@(subst', _) = mapAccumL (clone_id subst') subst (ids `zip` uniqsFromSupply us)+    in x++-- | Clone a mutually recursive group of 'Id's+cloneRecIdBndrsM :: MonadUnique m => Subst -> [Id] -> m (Subst, [Id])+cloneRecIdBndrsM subst ids = cloneRecIdBndrs subst `flip` ids <$> getUniqueSupplyM++-- Just like substIdBndr, except that it always makes a new unique+-- It is given the unique to use+-- Discards non-Stable unfoldings+clone_id    :: Subst                    -- Substitution for the IdInfo+            -> Subst -> (Id, Unique)    -- Substitution and Id to transform+            -> (Subst, Id)              -- Transformed pair++clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)+  = (Subst new_in_scope new_idvs tvs new_cvs, new_id)+  where+    id1     = setVarUnique old_id uniq+    id2     = substIdType subst id1+    !new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    (!new_idvs, !new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))+                          | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)++{-+************************************************************************+*                                                                      *+                Types and Coercions+*                                                                      *+************************************************************************+-}++{-+************************************************************************+*                                                                      *+\section{IdInfo substitution}+*                                                                      *+************************************************************************+-}++substIdType :: Subst -> Id -> Id+substIdType subst@(Subst _ _ tv_env cv_env) id+  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)+    || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id+  | otherwise   =+      updateIdTypeAndMult (substTyUnchecked subst) id+        -- 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+    old_w  = idMult id++------------------+-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.+-- Discards unfoldings, unless they are Stable+substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo+substIdInfo subst new_id info+  | nothing_to_do = Nothing+  | otherwise     = Just (info `setRuleInfo`      substRuleInfo subst new_id old_rules+                               `setUnfoldingInfo` substUnfolding subst old_unf)+  where+    old_rules     = ruleInfo info+    old_unf       = realUnfoldingInfo info+    nothing_to_do = isEmptyRuleInfo old_rules && not (hasCoreUnfolding old_unf)++------------------+-- | Substitutes for the 'Id's within an unfolding+-- NB: substUnfolding /discards/ any unfolding without+--     without a Stable source.  This is usually what we want,+--     but it may be a bit unexpected+substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding+        -- Seq'ing on the returned Unfolding is enough to cause+        -- all the substitutions to happen completely++substUnfoldingSC subst unf       -- Short-cut version+  | isEmptySubst subst = unf+  | otherwise          = substUnfolding subst unf++substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+  = df { df_bndrs = bndrs', df_args = args' }+  where+    (subst',bndrs') = substBndrs subst bndrs+    args'           = map (substExpr subst') args++substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })+  -- Retain stable unfoldings+  | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work+  = NoUnfolding+  | otherwise                 -- But keep a stable one!+  = seqExpr new_tmpl `seq`+    unf { uf_tmpl = new_tmpl }+  where+    new_tmpl = substExpr subst tmpl++substUnfolding _ unf = unf      -- NoUnfolding, OtherCon++------------------+substIdOcc :: Subst -> Id -> Id+-- These Ids should not be substituted to non-Ids+substIdOcc subst v = case lookupIdSubst subst v of+                        Var v' -> v'+                        other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])++------------------+-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id'+substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo+substRuleInfo subst new_id (RuleInfo rules rhs_fvs)+  = RuleInfo (map (substRule subst subst_ru_fn) rules)+                  (substDVarSet subst rhs_fvs)+  where+    subst_ru_fn = const (idName new_id)++------------------+substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]+substRulesForImportedIds subst rules+  = map (substRule subst not_needed) rules+  where+    not_needed name = pprPanic "substRulesForImportedIds" (ppr name)++------------------+substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule++-- The subst_ru_fn argument is applied to substitute the ru_fn field+-- of the rule:+--    - Rules for *imported* Ids never change ru_fn+--    - Rules for *local* Ids are in the IdInfo for that Id,+--      and the ru_fn field is simply replaced by the new name+--      of the Id+substRule _ _ rule@(BuiltinRule {}) = rule+substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args+                                       , ru_fn = fn_name, ru_rhs = rhs+                                       , ru_local = is_local })+  = rule { ru_bndrs = bndrs'+         , ru_fn    = if is_local+                        then subst_ru_fn fn_name+                        else fn_name+         , ru_args  = map (substExpr subst') args+         , ru_rhs   = substExpr subst' rhs }+           -- Do NOT optimise the RHS (previously we did simplOptExpr here)+           -- See Note [Substitute lazily]+  where+    (subst', bndrs') = substBndrs subst bndrs++------------------+substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet+substDVarSet subst@(Subst _ _ tv_env cv_env) fvs+  = mkDVarSet $ fst $ foldr subst_fv ([], emptyVarSet) $ dVarSetElems fvs+  where+  subst_fv :: Var -> ([Var], VarSet) -> ([Var], VarSet)+  subst_fv fv acc+     | isTyVar fv+     , let fv_ty = lookupVarEnv tv_env fv `orElse` mkTyVarTy fv+     = tyCoFVsOfType fv_ty (const True) emptyVarSet $! acc+     | isCoVar fv+     , let fv_co = lookupVarEnv cv_env fv `orElse` mkCoVarCo fv+     = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc+     | otherwise+     , let fv_expr = lookupIdSubst subst fv+     = exprLocalFVs fv_expr (const True) emptyVarSet $! acc++------------------+-- | Drop free vars from the breakpoint if they have a non-variable substitution.+substTickish :: Subst -> CoreTickish -> CoreTickish+substTickish subst (Breakpoint ext bid ids)+   = Breakpoint ext bid (mapMaybe do_one ids)+ where+    do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst++substTickish _subst other = other++{- Note [Substitute lazily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions that substitute over IdInfo must be pretty lazy, because+they are knot-tied by substRecBndrs.++One case in point was #10627 in which a rule for a function 'f'+referred to 'f' (at a different type) on the RHS.  But instead of just+substituting in the rhs of the rule, we were calling simpleOptExpr, which+looked at the idInfo for 'f'; result <<loop>>.++In any case we don't need to optimise the RHS of rules, or unfoldings,+because the simplifier will do that.++Another place this went wrong was in `substRuleInfo`, which would immediately force+the lazy call to substExpr, which led to an infinite loop (as reported by #20112).++This time the call stack looked something like:++* `substRecBndrs`+* `substIdBndr`+* `substIdInfo`+* `substRuleInfo`+* `substRule`+* `substExpr`+* `mkTick`+* `isSaturatedConApp`+* Look at `IdInfo` for thing we are currently substituting because the rule is attached to `transpose` and mentions it in the `RHS` of the rule.++and the rule was++{-# RULES+"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs) #-}++This rule was attached to `transpose`, but also mentions itself in the RHS so we have+to be careful to not force the `IdInfo` for transpose when dealing with the RHS of the rule.++++Note [substTickish]+~~~~~~~~~~~~~~~~~~~~~~+A Breakpoint contains a list of Ids.  What happens if we ever want to+substitute an expression for one of these Ids?++First, we ensure that we only ever substitute trivial expressions for+these Ids, by marking them as NoOccInfo in the occurrence analyser.+Then, when substituting for the Id, we unwrap any type applications+and abstractions to get back to an Id, with getIdFromTrivialExpr.++Second, we have to ensure that we never try to substitute a literal+for an Id in a breakpoint.  We ensure this by never storing an Id with+an unlifted type in a Breakpoint - see GHC.HsToCore.Ticks.mkTickish.+Breakpoints can't handle free variables with unlifted types anyway.++These measures are only reliable with unoptimized code.+Since we can now enable optimizations for GHCi with+@-fno-unoptimized-core-for-interpreter -O@, nontrivial expressions can be+substituted, e.g. by specializations.+Therefore we resort to discarding free variables from breakpoints when this+situation occurs.+-}++{-+Note [Worker inlining]+~~~~~~~~~~~~~~~~~~~~~~+A worker can get substituted away entirely.+        - it might be trivial+        - it might simply be very small+We do not treat an InlWrapper as an 'occurrence' in the occurrence+analyser, so it's possible that the worker is not even in scope any more.++In all these cases we simply drop the special case, returning to+InlVanilla.  The WARN is just so I can see if it happens a lot.+-}
+ GHC/Core/Tidy.hs view
@@ -0,0 +1,440 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++This module contains "tidying" code for *nested* expressions, bindings, rules.+The code for *top-level* bindings is in GHC.Iface.Tidy.+-}+++module GHC.Core.Tidy (+        tidyExpr, tidyRules, tidyCbvInfoTop, tidyBndrs+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.Type+import GHC.Core.TyCo.Tidy+import GHC.Core.Seq ( seqUnfolding )++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand ( zapDmdEnvSig, isStrUsedDmd )+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Unique (getUnique)+import GHC.Types.Unique.FM+import GHC.Types.Name hiding (tidyNameOcc)+import GHC.Types.Name.Set+import GHC.Types.SrcLoc+import GHC.Types.Tickish++import GHC.Data.Maybe+import GHC.Utils.Misc+import Data.List (mapAccumL)+import GHC.Utils.Outputable+import GHC.Types.RepType (typePrimRep)+import GHC.Utils.Panic+import GHC.Types.Basic (isMarkedCbv, CbvMark (..))+import GHC.Core.Utils (shouldUseCbvForId)++{-+************************************************************************+*                                                                      *+\subsection{Tidying expressions, rules}+*                                                                      *+************************************************************************+-}++tidyBind :: TidyEnv+         -> CoreBind+         ->  (TidyEnv, CoreBind)++tidyBind env (NonRec bndr rhs)+  = -- pprTrace "tidyBindNonRec" (ppr bndr) $+    let cbv_bndr = (tidyCbvInfoLocal bndr rhs)+        (env', bndr') = tidyLetBndr env env cbv_bndr+        tidy_rhs = (tidyExpr env' rhs)+    in (env', NonRec bndr' tidy_rhs)++tidyBind env (Rec prs)+  = -- pprTrace "tidyBindRec" (ppr $ map fst prs) $+    let+       cbv_bndrs = map ((\(bnd,rhs) -> tidyCbvInfoLocal bnd rhs)) prs+       (_bndrs, rhss)  = unzip prs+       (env', bndrs') = mapAccumL (tidyLetBndr env') env cbv_bndrs+    in+    map (tidyExpr env') rhss =: \ rhss' ->+    (env', Rec (zip bndrs' rhss'))+++-- Note [Attaching CBV Marks to ids]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See Note [CBV Function Ids] for the *why*.+-- Before tidy, we turn all worker functions into worker like ids.+-- This way we can later tell if we can assume the existence of a wrapper. This also applies to+-- specialized versions of functions generated by SpecConstr for which we, in a sense,+-- consider the unspecialized version to be the wrapper.+-- During tidy we take the demands on the arguments for these ids and compute+-- CBV (call-by-value) semantics for each individual argument.+-- The marks themselves then are put onto the function id itself.+-- This means the code generator can get the full calling convention by only looking at the function+-- itself without having to inspect the RHS.+--+-- The actual logic is in computeCbvInfo and takes:+-- * The function id+-- * The functions rhs+-- And gives us back the function annotated with the marks.+-- We call it in:+-- * tidyTopPair for top level bindings+-- * tidyBind for local bindings.+--+-- Not that we *have* to look at the untidied rhs.+-- During tidying some knot-tying occurs which can blow up+-- if we look at the post-tidy types of the arguments here.+-- However we only care if the types are unlifted and that doesn't change during tidy.+-- so we can just look at the untidied types.+--+-- If the id is boot-exported we don't use a cbv calling convention via marks,+-- as the boot file won't contain them. Which means code calling boot-exported+-- ids might expect these ids to have a vanilla calling convention even if we+-- determine a different one here.+-- To be able to avoid this we pass a set of boot exported ids for this module around.+-- For non top level ids we can skip this. Local ids are never boot-exported+-- as boot files don't have unfoldings. So there this isn't a concern.+-- See also Note [CBV Function Ids]+++-- See Note [CBV Function Ids]+tidyCbvInfoTop :: HasDebugCallStack => NameSet -> Id -> CoreExpr -> Id+tidyCbvInfoTop boot_exports id rhs+  -- Can't change calling convention for boot exported things+  | elemNameSet (idName id) boot_exports = id+  | otherwise = computeCbvInfo id rhs++-- See Note [CBV Function Ids]+tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id+tidyCbvInfoLocal id rhs = computeCbvInfo id rhs++-- | For a binding we:+-- * Look at the args+-- * Mark any argument as call-by-value if:+--   - It's argument to a worker and demanded strictly+--   - Unless it's an unlifted type already+-- * Update the id+-- See Note [CBV Function Ids]+-- See Note [Attaching CBV Marks to ids]++computeCbvInfo :: HasCallStack+               => Id            -- The function+               -> CoreExpr      -- It's RHS+               -> Id+-- computeCbvInfo fun_id rhs = fun_id+computeCbvInfo fun_id rhs+  | is_wkr_like || isJoinPoint mb_join_id+  , valid_unlifted_worker val_args+  = -- pprTrace "computeCbvInfo"+    --   (text "fun" <+> ppr fun_id $$+    --     text "arg_tys" <+> ppr (map idType val_args) $$++    --     text "prim_rep" <+> ppr (map typePrimRep_maybe $ map idType val_args) $$+    --     text "rrarg" <+> ppr (map isRuntimeVar val_args) $$+    --     text "cbv_marks" <+> ppr cbv_marks $$+    --     text "out_id" <+> ppr cbv_bndr $$+    --     ppr rhs)+    cbv_bndr++  | otherwise = fun_id+  where+    mb_join_id  = idJoinPointHood fun_id+    is_wkr_like = isWorkerLikeId fun_id++    val_args = filter isId lam_bndrs+    -- When computing CbvMarks, we limit the arity of join points to+    -- the JoinArity, because that's the arity we are going to use+    -- when calling it. There may be more lambdas than that on the RHS.+    lam_bndrs | JoinPoint join_arity <- mb_join_id+              = fst $ collectNBinders join_arity rhs+              | otherwise+              = fst $ collectBinders rhs++    cbv_marks = -- assert: CBV marks are only set during tidy so none should be present already.+                assertPpr (maybe True null $ idCbvMarks_maybe fun_id)+                          (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $+                map mkMark val_args++    cbv_bndr | any isMarkedCbv cbv_marks+             = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks+               -- seqList: avoid retaining the original rhs++             | otherwise+             = -- pprTraceDebug "computeCbvInfo: Worker seems to take unboxed tuple/sum types!"+               --    (ppr fun_id <+> ppr rhs)+               asNonWorkerLikeId fun_id++    -- We don't set CBV marks on functions which take unboxed tuples or sums as+    -- arguments.  Doing so would require us to compute the result of unarise+    -- here in order to properly determine argument positions at runtime.+    --+    -- In practice this doesn't matter much. Most "interesting" functions will+    -- get a W/W split which will eliminate unboxed tuple arguments, and unboxed+    -- sums are rarely used. But we could change this in the future and support+    -- unboxed sums/tuples as well.+    valid_unlifted_worker args =+      -- pprTrace "valid_unlifted" (ppr fun_id $$ ppr args) $+      all isSingleUnarisedArg args++    isSingleUnarisedArg v+      | isUnboxedSumType ty = False+      | isUnboxedTupleType ty = isSimplePrimRep (typePrimRep ty)+      | otherwise = isSimplePrimRep (typePrimRep ty)+      where+        ty = idType v+        isSimplePrimRep []  = True+        isSimplePrimRep [_] = True+        isSimplePrimRep _   = False++    mkMark arg+      | not $ shouldUseCbvForId arg = NotMarkedCbv+      -- We can only safely use cbv for strict arguments+      | (isStrUsedDmd (idDemandInfo arg))+      , not (isDeadEndId fun_id) = MarkedCbv+      | otherwise = NotMarkedCbv+++------------  Expressions  --------------+tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr+tidyExpr env (Var v)       = Var (tidyVarOcc env v)+tidyExpr env (Type ty)     = Type (tidyType env ty)+tidyExpr env (Coercion co) = Coercion (tidyCo env co)+tidyExpr _   (Lit lit)     = Lit lit+tidyExpr env (App f a)     = App (tidyExpr env f) (tidyExpr env a)+tidyExpr env (Tick t e)    = Tick (tidyTickish env t) (tidyExpr env e)+tidyExpr env (Cast e co)   = Cast (tidyExpr env e) (tidyCo env co)++tidyExpr env (Let b e)+  = tidyBind env b      =: \ (env', b') ->+    Let b' (tidyExpr env' e)++tidyExpr env (Case e b ty alts)+  = tidyBndr env b  =: \ (env', b) ->+    Case (tidyExpr env e) b (tidyType env ty)+         (map (tidyAlt env') alts)++tidyExpr env (Lam b e)+  = tidyBndr env b      =: \ (env', b) ->+    Lam b (tidyExpr env' e)++------------  Case alternatives  --------------+tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt+tidyAlt env (Alt con vs rhs)+  = tidyBndrs env vs    =: \ (env', vs) ->+    (Alt con vs (tidyExpr env' rhs))++------------  Tickish  --------------+tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish+tidyTickish env (Breakpoint ext bid ids)+  = Breakpoint ext bid (map (tidyVarOcc env) ids)+tidyTickish _   other_tickish       = other_tickish++------------  Rules  --------------+tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]+tidyRules _   [] = []+tidyRules env (rule : rules)+  = tidyRule env rule           =: \ rule ->+    tidyRules env rules         =: \ rules ->+    (rule : rules)++tidyRule :: TidyEnv -> CoreRule -> CoreRule+tidyRule _   rule@(BuiltinRule {}) = rule+tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,+                          ru_fn = fn, ru_rough = mb_ns })+  = tidyBndrs env bndrs         =: \ (env', bndrs) ->+    map (tidyExpr env') args    =: \ args ->+    rule { ru_bndrs = bndrs, ru_args = args,+           ru_rhs   = tidyExpr env' rhs,+           ru_fn    = tidyNameOcc env fn,+           ru_rough = map (fmap (tidyNameOcc env')) mb_ns }++{-+************************************************************************+*                                                                      *+\subsection{Tidying non-top-level binders}+*                                                                      *+************************************************************************+-}++tidyNameOcc :: TidyEnv -> Name -> Name+-- In rules and instances, we have Names, and we must tidy them too+-- Fortunately, we can lookup in the VarEnv with a name+tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of+                                Nothing -> n+                                Just v  -> idName v++tidyVarOcc :: TidyEnv -> Var -> Var+tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v++-- tidyBndr is used for lambda and case binders+tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)+tidyBndr env var+  | isTyCoVar var = tidyVarBndr env var+  | otherwise     = tidyIdBndr env var++tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])+tidyBndrs env vars = mapAccumL tidyBndr env vars++-- Non-top-level variables, not covars+tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)+tidyIdBndr env@(tidy_env, var_env) id+  = -- Do this pattern match strictly, otherwise we end up holding on to+    -- stuff in the OccName.+    case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        -- Give the Id a fresh print-name, *and* rename its type+        -- The SrcLoc isn't important now,+        -- though we could extract it from the Id+        --+        ty'      = tidyType env (idType id)+        mult'    = tidyType env (idMult id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        id'      = mkLocalIdWithInfo name' mult' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        new_info = vanillaIdInfo `setOccInfo` occInfo old_info+                                 `setUnfoldingInfo` new_unf+                                  -- see Note [Preserve OneShotInfo]+                                 `setOneShotInfo` oneShotInfo old_info+        old_info = idInfo id+        old_unf  = realUnfoldingInfo old_info+        new_unf  = trimUnfolding old_unf  -- See Note [Preserve evaluatedness]+    in+    ((tidy_env', var_env'), id')+   }++tidyLetBndr :: TidyEnv         -- Knot-tied version for unfoldings+            -> TidyEnv         -- The one to extend+            -> Id -> (TidyEnv, Id)+-- Used for local (non-top-level) let(rec)s+-- Just like tidyIdBndr above, but with more IdInfo+tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id+  = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->+    let+        ty'      = tidyType env (idType id)+        mult'    = tidyType env (idMult id)+        name'    = mkInternalName (idUnique id) occ' noSrcSpan+        details  = idDetails id+        id'      = mkLocalVar details name' mult' ty' new_info+        var_env' = extendVarEnv var_env id id'++        -- Note [Tidy IdInfo]+        -- We need to keep around any interesting strictness and+        -- demand info because later on we may need to use it when+        -- converting to A-normal form.+        -- eg.+        --      f (g x),  where f is strict in its argument, will be converted+        --      into  case (g x) of z -> f z  by CorePrep, but only if f still+        --      has its strictness info.+        --+        -- Similarly for the demand info - on a let binder, this tells+        -- CorePrep to turn the let into a case.+        -- But: Remove the usage demand here+        --      (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap)+        --+        -- Similarly arity info for eta expansion in CorePrep+        -- Don't attempt to recompute arity here; this is just tidying!+        -- Trying to do so led to #17294+        --+        -- Set inline-prag info so that we preserve it across+        -- separate compilation boundaries+        old_info = idInfo id+        new_info = vanillaIdInfo+                    `setOccInfo`        occInfo old_info+                    `setArityInfo`      arityInfo old_info+                    `setDmdSigInfo`     zapDmdEnvSig (dmdSigInfo old_info)+                    `setDemandInfo`     demandInfo old_info+                    `setInlinePragInfo` inlinePragInfo old_info+                    `setUnfoldingInfo`  new_unf++        old_unf = realUnfoldingInfo old_info+        new_unf = tidyNestedUnfolding rec_tidy_env old_unf++    in+    ((tidy_env', var_env'), id') }++------------ Unfolding  --------------+tidyNestedUnfolding :: TidyEnv -> Unfolding -> Unfolding+tidyNestedUnfolding _ NoUnfolding   = NoUnfolding+tidyNestedUnfolding _ BootUnfolding = BootUnfolding+tidyNestedUnfolding _ (OtherCon {}) = evaldUnfolding++tidyNestedUnfolding 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++tidyNestedUnfolding tidy_env+    unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_cache = cache })+  | isStableSource src+  = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs }    -- Preserves OccInfo+            -- This seqIt avoids a space leak: otherwise the uf_cache+            -- field may retain a reference to the pre-tidied+            -- expression forever (GHC.CoreToIface doesn't look at+            -- them)++  -- Discard unstable unfoldings, but see Note [Preserve evaluatedness]+  | uf_is_value cache = evaldUnfolding+  | otherwise = noUnfolding++  where+    seqIt unf = seqUnfolding unf `seq` unf++{-+Note [Tidy IdInfo]+~~~~~~~~~~~~~~~~~~+All nested Ids now have the same IdInfo, namely vanillaIdInfo, which+should save some space; except that we preserve occurrence info for+two reasons:++  (a) To make printing tidy core nicer++  (b) Because we tidy RULES and unfoldings, which may then propagate+      via --make into the compilation of the next module, and we want+      the benefit of that occurrence analysis when we use the rule or+      or inline the function.  In particular, it's vital not to lose+      loop-breaker info, else we get an infinite inlining loop++Note that tidyLetBndr puts more IdInfo back.++Note [Preserve evaluatedness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT !Bool+  ....(case v of MkT y ->+       let z# = case y of+                  True -> 1#+                  False -> 2#+       in ...)++The z# binding is ok because the RHS is ok-for-speculation,+but Lint will complain unless it can *see* that.  So we+preserve the evaluated-ness on 'y' in tidyBndr.++(Another alternative would be to tidy unboxed lets into cases,+but that seems more indirect and surprising.)++Note [Preserve OneShotInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We keep the OneShotInfo because we want it to propagate into the interface.+Not all OneShotInfo is determined by a compiler analysis; some is added by a+call of GHC.Exts.oneShot, which is then discarded before the end of the+optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we+must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make.++This applies to lambda binders only, hence it is stored in IfaceLamBndr.+-}++(=:) :: a -> (a -> b) -> b+m =: k = m `seq` k m
+ GHC/Core/TyCo/Compare.hs view
@@ -0,0 +1,853 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1998++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}++-- | Type equality and comparison+module GHC.Core.TyCo.Compare (++    -- * Type equality+    eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes,+    eqVarBndrs,++    pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,+    tcEqTyConApps, tcEqTyConAppArgs,+    mayLookIdentical,++    -- * Type comparison+    nonDetCmpType,++   -- * Visiblity comparision+   eqForAllVis, cmpForAllVis++   ) where++import GHC.Prelude++import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe+                    , isLevityTy, isRuntimeRepTy, isMultiplicityTy )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Multiplicity( MultiplicityFlag(..) )++import GHC.Types.Var+import GHC.Types.Unique+import GHC.Types.Var.Env+import GHC.Types.Var.Set++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Base (reallyUnsafePtrEquality#)++import qualified Data.Semigroup as S++{- GHC.Core.TyCo.Compare overview+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module implements type equality and comparison++It uses a few functions from GHC.Core.Type, notably `typeKind`,+so it currently sits "on top of" GHC.Core.Type.+-}++{- *********************************************************************+*                                                                      *+                       Type equality++     We don't use (==) from class Eq, partly so that we know where+     type equality is called, and partly because there are multiple+     variants.+*                                                                      *+********************************************************************* -}++{- Note [Computing equality on types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module implements type equality, notably `eqType`. This is+"definitional equality" or just "equality" for short.++There are several places within GHC that depend on the precise choice of+definitional equality used. If we change that definition, all these places+must be updated. This Note merely serves as a place for all these places+to refer to, so searching for references to this Note will find every place+that needs to be updated.++* See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.++* See Historical Note [Typechecker equality vs definitional equality]+  below++Note [Casts and coercions in type comparision]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As (EQTYPE) in Note [Non-trivial definitional equality] says, our+general plan, implemented by `fullEq`, is:+ (1) ignore both casts and coercions when comparing types,+ (2) instead, compare the /kinds/ of the two types,+     as well as the types themselves++If possible we want to avoid step (2), comparing the kinds; doing so involves+calling `typeKind` and doing another comparision.++When can we avoid doing so?  Answer: we can certainly avoid doing so if the+types we are comparing have no casts or coercions.  But we can do better.+Consider+    eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn])+We are going to call (eqType s1 t1), (eqType s2 t2) etc.++The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded,+and both TyConApps are headed by the same T. So the first recursive call to `eqType`+certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise,+we know that `s1` and `t1` are themselves equal (not just their kinds). This+makes the kinds of `s2` and `t2` to be equal, because those kinds come from the+kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not+need to check the kinds of `s2` and `t2`. By induction, we don't need to check+the kinds of *any* of the types in a TyConApp, and we also do not need to check+the kinds of the TyConApps themselves.++Conclusion:++* casts and coercions under a TyConApp don't matter -- even including type synonyms++* In step (2), use `hasCasts` to tell if there are any casts to worry about. It+  does not look very deep, because TyConApps and FunTys are so common, and it+  doesn't allocate.  The only recursive cases are AppTy and ForAllTy.++Alternative implementation.  Instead of `hasCasts`, we could make the+generic_eq_type function return+  data EqResult = NotEq | EqWithNoCasts | EqWithCasts+Practically free; but stylistically I prefer useing `hasCasts`:+  * `generic_eq_type` can just uses familiar booleans+  * There is a lot more branching with the three-value variant.+  * It separates concerns.  No need to think about cast-tracking when doing the+    equality comparison.+  * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted+    work.+I did try both; there was no perceptible perf difference so I chose `hasCasts` version.++Note [Equality on AppTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+In our cast-ignoring equality, we want to say that the following two+are equal:++  (Maybe |> co) (Int |> co')   ~?       Maybe Int++But the left is an AppTy while the right is a TyConApp. The solution is+to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and+then continue. Easy to do, but also easy to forget to do.++Note [Comparing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of testing equality between two 'Type's of the form++  TyConApp tc tys1  =  TyConApp tc tys2++where `tc` is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of `tc` may be large. We'd+prefer to compare `tys1 = tys2`.  When is that sound?  Precisely when the+synonym is not /forgetful/; that is, all its type variables appear in its+RHS -- see `GHC.Core.TyCon.isForgetfulSynTyCon`.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be equal.++This works fine for /equality/, but not for /comparison/.  Consider+   type S a b = (b, a)+Now consider+   S Int Bool `compare` S Char Char+The ordering may depend on whether we expand the synonym or not, and we+don't want the result to depend on that. So for comparison we stick to+/nullary/ synonyms only, which is still useful.++We perform this optimisation in a number of places:++ * GHC.Core.TyCo.Compare.eqType      (works for non-nullary synonyms)+ * GHC.Core.Map.TYpe.eqDeBruijnType  (works for non-nullary synonyms)+ * GHC.Core.Types.nonDetCmpType      (nullary only)++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.++Currently-missed opportunity (#25009):+* In the case of forgetful synonyms, we could still compare the args, pairwise,+  and then compare the RHS's with a suitably extended RnEnv2.  That would avoid+  comparing the same arg repeatedly.  e.g.+      type S a b = (a,a)+  Compare   S <big> y ~ S <big> y+  If we expand, we end up compare <big> with itself twice.++  But since forgetful synonyms are rare, we have not tried this.++Note [Type comparisons using object pointer comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quite often we substitute the type from a definition site into+occurrences without a change. This means for code like:+    \x -> (x,x,x)+The type of every `x` will often be represented by a single object+in the heap. We can take advantage of this by shortcutting the equality+check if two types are represented by the same pointer under the hood.+In some cases this reduces compiler allocations by ~2%.++See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp++Note [Respecting multiplicity when comparing types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, we respect multiplicities (i.e. the linear part of the type+system) when comparing types.  Doing so is of course crucial during typechecking.++But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard+to ensure that Core is always type-correct when it comes to linearity.  So+* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities+* We use this multiplicity-blind comparison very occasionally, notably+    - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint+    - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy]+      in GHC.Core.Unify+-}+++tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool+tcEqKind = tcEqType++tcEqType :: HasDebugCallStack => Type -> Type -> Bool+tcEqType = eqType++-- | Just like 'tcEqType', but will return True for types of different kinds+-- as long as their non-coercion structure is identical.+tcEqTypeNoKindCheck :: Type -> Type -> Bool+tcEqTypeNoKindCheck = eqTypeNoKindCheck++-- | Check whether two TyConApps are the same; if the number of arguments+-- are different, just checks the common prefix of arguments.+tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool+tcEqTyConApps tc1 args1 tc2 args2+  = tc1 == tc2 && tcEqTyConAppArgs args1 args2++tcEqTyConAppArgs :: [Type] -> [Type] -> Bool+-- Args do not have to have equal length;+-- we discard the excess of the longer one+tcEqTyConAppArgs args1 args2+  = and (zipWith tcEqTypeNoKindCheck args1 args2)+    -- No kind check necessary: if both arguments are well typed, then+    -- any difference in the kinds of later arguments would show up+    -- as differences in earlier (dependent) arguments++-- | Type equality on lists of types, looking through type synonyms+eqTypes :: [Type] -> [Type] -> Bool+eqTypes []       []       = True+eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2+eqTypes _        _        = False++eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2+-- Check that the var lists are the same length+-- and have matching kinds; if so, extend the RnEnv2+-- Returns Nothing if they don't match+eqVarBndrs env [] []+ = Just env+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)+ | eqTypeX env (varType tv1) (varType tv2)+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2+eqVarBndrs _ _ _= Nothing++initRnEnv :: Type -> Type -> RnEnv2+initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $+                  tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb++eqTypeNoKindCheck :: Type -> Type -> Bool+eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2++-- | Type equality comparing both visible and invisible arguments,+-- expanding synonyms and respecting multiplicities.+eqType :: HasCallStack => Type -> Type -> Bool+eqType ta tb = fullEq eq_type_expand_respect ta tb++-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.+eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool+eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb++eqTypeIgnoringMultiplicity :: Type -> Type -> Bool+-- See Note [Respecting multiplicity when comparing types]+eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb++-- | Like 'pickyEqTypeVis', but returns a Bool for convenience+pickyEqType :: Type -> Type -> Bool+-- Check when two types _look_ the same, _including_ synonyms.+-- So (pickyEqType String [Char]) returns False+-- This ignores kinds and coercions, because this is used only for printing.+pickyEqType ta tb = eq_type_keep_respect ta tb++{- Note [Specialising type equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type equality predicates in Type are hit pretty hard by GHC.  Consequently+we take pains to ensure that these paths are compiled to efficient,+minimally-allocating code.  Plan:++* The main workhorse is `inline_generic_eq_type_x`.  It is /non-recursive/+  and is marked INLINE.++* `inline_generic_eq_type_x` has various parameters that control what it does:+  * syn_flag::SynFlag            whether type synonyms are expanded or kept.+  * mult_flag::MultiplicityFlag  whether multiplicities are ignored or respected+  * mb_env::Maybe RnEnv2         an optional RnEnv2.++* `inline_generic_eq_type_x` has a handful of call sites, namely the ones+  in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc.  It inlines+  at all these sites, specialising to the data values passed for the+  control parameters.++* All /other/ calls to `inline_generic_eq_type_x` go via+     generic_eq_type_x = inline_generic_eq_type_x+     {-# NOINLNE generic_eq_type_x #-}+  The idea is that all calls to `generic_eq_type_x` are specialised by the+  RULES, so this NOINLINE version is seldom, if ever, actually called.++* For each of specialised copy of `inline_generic_eq_type_x, there is a+  corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args)+  into the appropriate specialied version.++See #19226.+-}++-- | This flag controls whether we expand synonyms during comparison+data SynFlag = ExpandSynonyms | KeepSynonyms++eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect+  :: Type -> Type -> Bool+eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x+   :: RnEnv2 -> Type -> Type -> Bool++eq_type_expand_respect       = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+eq_type_expand_ignore        = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  Nothing+eq_type_expand_ignore_x env  = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  (Just env)+eq_type_keep_respect         = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities Nothing+eq_type_keep_respect_x env   = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities (Just env)++{-# RULES+"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+             = eq_type_expand_respect+"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+             = eq_type_expand_respect_x env+"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing+             = eq_type_expand_ignore+"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)+             = eq_type_expand_ignore_x env+"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing+             = eq_type_keep_respect+"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)+             = eq_type_keep_respect_x env+ #-}++-- ---------------------------------------------------------------+-- | Real worker for 'eqType'. No kind check!+-- Inline it at the (handful of local) call sites+-- The "generic" bit refers to the flag paramerisation+-- See Note [Specialising type equality].+generic_eq_type_x, inline_generic_eq_type_x+  :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool++{-# NOINLINE generic_eq_type_x #-}+generic_eq_type_x = inline_generic_eq_type_x+-- See Note [Computing equality on types] in Type++{-# INLINE inline_generic_eq_type_x #-}+-- This non-recursive function can inline at its (few) call sites.  The+-- recursion goes via generic_eq_type_x, which is the loop-breaker.+inline_generic_eq_type_x syn_flag mult_flag mb_env+  = \ t1 t2 -> t1 `seq` t2 `seq`+    let go = generic_eq_type_x syn_flag mult_flag mb_env+             -- Abbreviation for recursive calls++        gos []       []       = True+        gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2+        gos _ _               = False++    in case (t1,t2) of+      _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True+      -- See Note [Type comparisons using object pointer comparisons]++      (TyConApp tc1 tys1, TyConApp tc2 tys2)+        | tc1 == tc2, not (isForgetfulSynTyCon tc1)   -- See Note [Comparing type synonyms]+        -> gos tys1 tys2++      _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2+        | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2'++      (TyConApp tc1 ts1, TyConApp tc2 ts2)+        | tc1 == tc2 -> gos ts1 ts2+        | otherwise  -> False++      (TyVarTy tv1, TyVarTy tv2)+        -> case mb_env of+              Nothing  -> tv1 == tv2+              Just env -> rnOccL env tv1 == rnOccR env tv2++      (LitTy lit1,    LitTy lit2)    -> lit1 == lit2+      (CastTy t1' _,   _)            -> go t1' t2 -- Ignore casts+      (_,             CastTy t2' _)  -> go t1 t2' -- Ignore casts+      (CoercionTy {}, CoercionTy {}) -> True      -- Ignore coercions++    -- Make sure we handle all FunTy cases since falling through to the+    -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked+    -- kind variable, which causes things to blow up.+    -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check+    -- kinds here+      (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2)+        ->   fullEq go arg1 arg2+          && fullEq go res1 res2+          && (case mult_flag of+                  RespectMultiplicities -> go w1 w2+                  IgnoreMultiplicities  -> True)++      -- See Note [Equality on AppTys] in GHC.Core.Type+      (AppTy s1 t1', _)+        | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2+        -> go s1 s2 && go t1' t2'+      (_,  AppTy s2 t2')+        | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1+        -> go s1 s2 && go t1' t2'++      (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2)+        -> case mb_env of+              Nothing -> generic_eq_type_x syn_flag mult_flag+                            (Just (initRnEnv t1 t2)) t1 t2+              Just env+                | vis1 `eqForAllVis` vis2         -- See Note [ForAllTy and type equality]+                -> go (varType tv1) (varType tv2)  -- Always do kind-check+                   && generic_eq_type_x syn_flag mult_flag+                             (Just (rnBndr2 env tv1 tv2)) body1 body2+                | otherwise+                -> False++      _ -> False++fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool+-- Do "full equality" including the kind check+-- See Note [Casts and coercions in type comparision]+{-# INLINE fullEq #-}+fullEq eq ty1 ty2+  = case eq ty1 ty2 of+          False    -> False+          True | hasCasts ty1 || hasCasts ty2+               -> eq (typeKind ty1) (typeKind ty2)+               | otherwise+               -> True++hasCasts :: Type -> Bool+-- Fast, does not look deep, does not allocate+hasCasts (CastTy {})     = True+hasCasts (CoercionTy {}) = True+hasCasts (AppTy t1 t2)   = hasCasts t1 || hasCasts t2+hasCasts (ForAllTy _ ty) = hasCasts ty+hasCasts _               = False   -- TyVarTy, TyConApp, FunTy, LitTy+++{- *********************************************************************+*                                                                      *+                Comparing ForAllTyFlags+*                                                                      *+********************************************************************* -}++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool+-- See Note [ForAllTy and type equality]+eqForAllVis Required      Required      = True+eqForAllVis (Invisible _) (Invisible _) = True+eqForAllVis _             _             = False++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering+-- See Note [ForAllTy and type equality]+cmpForAllVis Required      Required       = EQ+cmpForAllVis Required      (Invisible {}) = LT+cmpForAllVis (Invisible _) Required       = GT+cmpForAllVis (Invisible _) (Invisible _)  = EQ+++{- Note [ForAllTy and type equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we compare (ForAllTy (Bndr tv1 vis1) ty1)+         and    (ForAllTy (Bndr tv2 vis2) ty2)+what should we do about `vis1` vs `vis2`?++We had a long debate about this: see #22762 and GHC Proposal 558.+Here is the conclusion.++* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be+  distinct types, not interchangeable.  The latter requires a type argument,+  but the former does not.  See GHC Proposal 558.++* We /really/ do not want the typechecker and Core to have different notions of+  equality.  That is, we don't want `tcEqType` and `eqType` to differ.  Why not?+  Not so much because of code duplication but because it is virtually impossible+  to cleave the two apart. Here is one particularly awkward code path:+     The type checker calls `substTy`, which calls `mkAppTy`,+     which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`.++* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the+  typechecker and Core have a single notion of equality.++* So in GHC:+  - `tcEqType` and `eqType` implement the same equality+  - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker+  - That is, both `eqType` and `tcEqType` distinguish them.++* But /at representational role/ we can relate the types. That is,+    (forall a. ty) ~R (forall a -> ty)+  After all, since types are erased, they are represented the same way.+  See Note [ForAllCo] and the typing rule for ForAllCo given there++* What about (forall a. ty) and (forall {a}. ty)?  See Note [Comparing visibility].++Note [Comparing visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see+Note [ForAllTy and type equality].  But we have /three/ settings for the ForAllTyFlag:+  * Specified: forall a. ty+  * Inferred:  forall {a}. ty+  * Required:  forall a -> ty++We could (and perhaps should) distinguish all three. But for now we distinguish+Required from Specified/Inferred, and ignore the distinction between Specified+and Inferred.++The answer doesn't matter too much, provided we are consistent. And we are consistent+because we always compare ForAllTyFlags with+  * `eqForAllVis`+  * `cmpForAllVis`.+(You can only really check this by inspecting all pattern matches on ForAllTyFlags.)+So if we change the decision, we just need to change those functions.++Why don't we distinguish all three? Should GHC type-check the following program+(adapted from #15740)?++  {-# LANGUAGE PolyKinds, ... #-}+  data D a+  type family F :: forall k. k -> Type+  type instance F = D++Due to the way F is declared, any instance of F must have a right-hand side+whose kind is equal to `forall k. k -> Type`. The kind of D is+`forall {k}. k -> Type`, which is very close, but technically uses distinct+Core:++  -----------------------------------------------------------+  | Source Haskell    | Core                                |+  -----------------------------------------------------------+  | forall  k.  <...> | ForAllTy (Bndr k Specified) (<...>) |+  | forall {k}. <...> | ForAllTy (Bndr k Inferred)  (<...>) |+  -----------------------------------------------------------++We could deem these kinds to be unequal, but that would imply rejecting+programs like the one above. Whether a kind variable binder ends up being+specified or inferred can be somewhat subtle, however, especially for kinds+that aren't explicitly written out in the source code (like in D above).++For now, we decide++    the specified/inferred status of an invisible type variable binder+    does not affect GHC's notion of equality.++That is, we have the following:++  --------------------------------------------------+  | Type 1            | Type 2            | Equal? |+  --------------------|-----------------------------+  | forall k. <...>   | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall {k}. <...> | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall k -> <...> | forall k. <...>   | No     |+  |                   | forall {k}. <...> | No     |+  |                   | forall k -> <...> | Yes    |+  --------------------------------------------------++Examples: T16946, T15079.++Historical Note [Typechecker equality vs definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes some history, in case there are vestiges of this+history lying around in the code.++Summary: prior to summer 2022, GHC had have two notions of equality+over Core types.  But now there is only one: definitional equality,+or just equality for short.++The old setup was:++* Definitional equality, as implemented by GHC.Core.Type.eqType.+  See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.++* Typechecker equality, as implemented by tcEqType.+  GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality.++Typechecker equality implied definitional equality: if two types are equal+according to typechecker equality, then they are also equal according to+definitional equality. The converse is not always true, as typechecker equality+is more finer-grained than definitional equality in two places:++* Constraint vs Type.  Definitional equality equated Type and+  Constraint, but typechecker treats them as distinct types.++* Unlike definitional equality, which does not care about the ForAllTyFlag of a+  ForAllTy, typechecker equality treats Required type variable binders as+  distinct from Invisible type variable binders.+  See Note [ForAllTy and type equality]+++************************************************************************+*                                                                      *+                Comparison for types++      Not so heavily used, less carefully optimised+*                                                                      *+************************************************************************++-- Now here comes the real worker++Note [nonDetCmpType nondeterminism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX+uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for+ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,+comparing type variables is nondeterministic, note the call to nonDetCmpVar in+nonDetCmpTypeX.+See Note [Unique Determinism] for more details.+-}++nonDetCmpType :: Type -> Type -> Ordering+{-# INLINE nonDetCmpType #-}+nonDetCmpType !t1 !t2+  -- See Note [Type comparisons using object pointer comparisons]+  | 1# <- reallyUnsafePtrEquality# t1 t2+  = EQ+nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2+  = EQ+nonDetCmpType t1 t2+  -- we know k1 and k2 have the same kind, because they both have kind *.+  = nonDetCmpTypeX rn_env t1 t2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))++-- | An ordering relation between two 'Type's (known below as @t1 :: k1@+-- and @t2 :: k2@)+data TypeOrdering = TLT  -- ^ @t1 < t2@+                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,+                         -- therefore we can conclude @k1 ~ k2@+                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so+                         -- they may differ in kind.+                  | TGT  -- ^ @t1 > t2@+                  deriving (Eq, Ord, Enum, Bounded)++nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse+    -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+    -- See Note [Computing equality on types]+    -- Always respects multiplicities, unlike eqType+nonDetCmpTypeX env orig_t1 orig_t2 =+    case go env orig_t1 orig_t2 of+      -- If there are casts then we also need to do a comparison of+      -- the kinds of the types being compared+      TEQX          -> toOrdering $ go env k1 k2+      ty_ordering   -> toOrdering ty_ordering+  where+    k1 = typeKind orig_t1+    k2 = typeKind orig_t2++    toOrdering :: TypeOrdering -> Ordering+    toOrdering TLT  = LT+    toOrdering TEQ  = EQ+    toOrdering TEQX = EQ+    toOrdering TGT  = GT++    liftOrdering :: Ordering -> TypeOrdering+    liftOrdering LT = TLT+    liftOrdering EQ = TEQ+    liftOrdering GT = TGT++    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering+    thenCmpTy TEQ  rel  = rel+    thenCmpTy TEQX rel  = hasCast rel+    thenCmpTy rel  _    = rel++    hasCast :: TypeOrdering -> TypeOrdering+    hasCast TEQ = TEQX+    hasCast rel = rel++    -- Returns both the resulting ordering relation between+    -- the two types and whether either contains a cast.+    go :: RnEnv2 -> Type -> Type -> TypeOrdering++    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = TEQ    -- See Note [Comparing type synonyms]++    go env t1 t2+      | Just t1' <- coreView t1 = go env t1' t2+      | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)       (TyVarTy tv2)+      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2+    go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2)+      = liftOrdering (vis1 `cmpForAllVis` vis2)   -- See Note [ForAllTy and type equality]+        `thenCmpTy` go env (varType tv1) (varType tv2)+        `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2++        -- See Note [Equality on AppTys]+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- splitAppTyNoView_maybe ty2+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- splitAppTyNoView_maybe ty1+      = go env s1 s2 `thenCmpTy` go env t1 t2++    go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)+        -- NB: nonDepCmpTypeX does the kind check requested by+        -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep+      = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2)+          `thenCmpTy` go env w1 w2+        -- Comparing multiplicities last because the test is usually true++    go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2++    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (nonDetCmpTyLit l1 l2)+    go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2+    go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2++    go _   (CoercionTy {})     (CoercionTy {})     = TEQ++        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy+    go _ ty1 ty2+      = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)+      where get_rank :: Type -> Int+            get_rank (CastTy {})+              = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2])+            get_rank (TyVarTy {})    = 0+            get_rank (CoercionTy {}) = 1+            get_rank (AppTy {})      = 3+            get_rank (LitTy {})      = 4+            get_rank (TyConApp {})   = 5+            get_rank (FunTy {})      = 6+            get_rank (ForAllTy {})   = 7++    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering+    gos _   []         []         = TEQ+    gos _   []         _          = TLT+    gos _   _          []         = TGT+    gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2+++-------------+-- | Compare two 'TyCon's.+-- See Note [nonDetCmpType nondeterminism]+nonDetCmpTc :: TyCon -> TyCon -> Ordering+nonDetCmpTc tc1 tc2+  = u1 `nonDetCmpUnique` u2+  where+    u1  = tyConUnique tc1+    u2  = tyConUnique tc2+++{- *********************************************************************+*                                                                      *+                  mayLookIdentical+*                                                                      *+********************************************************************* -}++mayLookIdentical :: Type -> Type -> Bool+-- | Returns True if the /visible/ part of the types+-- might look equal, even if they are really unequal (in the invisible bits)+--+-- This function is very similar to tc_eq_type but it is much more+-- heuristic.  Notably, it is always safe to return True, even with types+-- that might (in truth) be unequal  -- this affects error messages only+-- (Originally this test was done by eqType with an extra flag, but the result+--  was hard to understand.)+mayLookIdentical orig_ty1 orig_ty2+  = go orig_env orig_ty1 orig_ty2+  where+    orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]++    go :: RnEnv2 -> Type -> Type -> Bool++    go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)+      | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms]+      = gos env (tyConBinders tc1) ts1 ts2++    go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2+    go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)   (TyVarTy tv2)   = rnOccL env tv1 == rnOccR env tv2+    go _   (LitTy lit1)    (LitTy lit2)    = lit1 == lit2+    go env (CastTy t1 _)   t2              = go env t1 t2+    go env t1              (CastTy t2 _)   = go env t1 t2+    go _   (CoercionTy {}) (CoercionTy {}) = True++    go env (ForAllTy (Bndr tv1 vis1) ty1)+           (ForAllTy (Bndr tv2 vis2) ty2)+      =  vis1 `eqForAllVis` vis2  -- See Note [ForAllTy and type equality]+      && go (rnBndr2 env tv1 tv2) ty1 ty2+         -- Visible stuff only: ignore kinds of binders++    -- If we have (forall (r::RunTimeRep). ty1  ~   blah) then respond+    -- with True.  Reason: the type pretty-printer defaults RuntimeRep+    -- foralls (see Ghc.Iface.Type.hideNonStandardTypes).  That can make,+    -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the+    -- same as a very different type (#24553).  By responding True, we+    -- tell GHC (see calls of mayLookIdentical) to display without defaulting.+    -- See Note [Showing invisible bits of types in error messages]+    -- in GHC.Tc.Errors.Ppr+    go _ (ForAllTy b _) _ | isDefaultableBndr b = True+    go _ _ (ForAllTy b _) | isDefaultableBndr b = True++    go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)+      = go env arg1 arg2 && go env res1 res2 && go env w1 w2+        -- Visible stuff only: ignore agg kinds++      -- See Note [Equality on AppTys] in GHC.Core.Type+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2+      = go env s1 s2 && go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1+      = go env s1 s2 && go env t1 t2++    go env (TyConApp tc1 ts1)   (TyConApp tc2 ts2)+      = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2++    go _ _ _ = False++    gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool+    gos _   _         []       []      = True+    gos env bs (t1:ts1) (t2:ts2)+      | (invisible, bs') <- case bs of+                               []     -> (False,                    [])+                               (b:bs) -> (isInvisibleTyConBinder b, bs)+      = (invisible || go env t1 t2) && gos env bs' ts1 ts2++    gos _ _ _ _ = False+++isDefaultableBndr :: ForAllTyBinder -> Bool+-- This function should line up with the defaulting done+--   by GHC.Iface.Type.defaultIfaceTyVarsOfKind+-- See Note [Showing invisible bits of types in error messages]+--   in GHC.Tc.Errors.Ppr+isDefaultableBndr (Bndr tv vis)+  = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)+  where+    is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki  || isMultiplicityTy ki+
+ GHC/Core/TyCo/FVs.hs view
@@ -0,0 +1,1264 @@+{-# LANGUAGE MultiWayIf #-}++module GHC.Core.TyCo.FVs+  (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,+        tyCoVarsOfType,        tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet,++        tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,+        tyCoFVsOfType, tyCoVarsOfTypeList,+        tyCoFVsOfTypes, tyCoVarsOfTypesList,+        deepTcvFolder,++        shallowTyCoVarsOfTyVarEnv, shallowTyCoVarsOfCoVarEnv,++        shallowTyCoVarsOfCo, shallowTyCoVarsOfCos,+        tyCoVarsOfCo, tyCoVarsOfCos, tyCoVarsOfMCo,+        coVarsOfType, coVarsOfTypes,+        coVarsOfCo, coVarsOfCos,+        tyCoVarsOfCoDSet,+        tyCoFVsOfCo, tyCoFVsOfCos,+        tyCoVarsOfCoList,+        coVarsOfCoDSet, coVarsOfCosDSet,++        almostDevoidCoVarOfCo,++        -- Injective free vars+        injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType,+        invisibleVarsOfType, invisibleVarsOfTypes,++        -- Any and No Free vars+        anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,+        noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,++        -- * Free type constructors+        tyConsOfType, tyConsOfTypes,++        -- * Free vars with visible/invisible separate+        visVarsOfTypes, visVarsOfType,++        -- * Occurrence-check expansion+        occCheckExpand,++        -- * Closing over kinds+        closeOverKindsDSet, closeOverKindsList,+        closeOverKinds,++        -- * Raw materials+        Endo(..), runTyCoVars+  ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView )+import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind )++import GHC.Builtin.Types.Prim( funTyFlagTyCon )++import Data.Monoid as DM ( Any(..) )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom( CoAxiomRule(..), BuiltInFamRewrite(..), coAxiomTyCon )+import GHC.Utils.FV++import GHC.Types.Var+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set++import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Utils.Misc+import GHC.Data.Pair++import Data.Semigroup++{-+%************************************************************************+%*                                                                      *+                 Free variables of types and coercions+%*                                                                      *+%************************************************************************+-}++{- Note [Shallow and deep free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definitions++* Shallow free variables of a type: the variables+  affected by substitution. Specifically, the (TyVarTy tv)+  and (CoVar cv) that appear+    - In the type and coercions appearing in the type+    - In shallow free variables of the kind of a Forall binder+  but NOT in the kind of the /occurrences/ of a type variable.++* Deep free variables of a type: shallow free variables, plus+  the deep free variables of the kinds of those variables.+  That is,  deepFVs( t ) = closeOverKinds( shallowFVs( t ) )++Examples:++  Type                     Shallow     Deep+  ---------------------------------+  (a : (k:Type))           {a}        {a,k}+  forall (a:(k:Type)). a   {k}        {k}+  (a:k->Type) (b:k)        {a,b}      {a,b,k}+-}+++{- Note [Free variables of types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns+a VarSet that is closed over the types of its variables.  More precisely,+  if    S = tyCoVarsOfType( t )+  and   (a:k) is in S+  then  tyCoVarsOftype( k ) is a subset of S++Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}.++We could /not/ close over the kinds of the variable occurrences, and+instead do so at call sites, but it seems that we always want to do+so, so it's easiest to do it here.++It turns out that getting the free variables of types is performance critical,+so we profiled several versions, exploring different implementation strategies.++1. Baseline version: uses FV naively. Essentially:++   tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty++   This is not nice, because FV introduces some overhead to implement+   determinism, and through its "interesting var" function, neither of which+   we need here, so they are a complete waste.++2. UnionVarSet version: instead of reusing the FV-based code, we simply used+   VarSets directly, trying to avoid the overhead of FV. E.g.:++   -- FV version:+   tyCoFVsOfType (AppTy fun arg)    a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c++   -- UnionVarSet version:+   tyCoVarsOfType (AppTy fun arg)    = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg)++   This looks deceptively similar, but while FV internally builds a list- and+   set-generating function, the VarSet functions manipulate sets directly, and+   the latter performs a lot worse than the naive FV version.++3. Accumulator-style VarSet version: this is what we use now. We do use VarSet+   as our data structure, but delegate the actual work to a new+   ty_co_vars_of_...  family of functions, which use accumulator style and the+   "in-scope set" filter found in the internals of FV, but without the+   determinism overhead.++See #14880.++Note [Closing over free variable kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over+free variable kinds. In previous GHC versions, this happened naively: whenever+we would encounter an occurrence of a free type variable, we would close over+its kind. This, however is wrong for two reasons (see #14880):++1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then+   we don't want to have to traverse k more than once.++2. Correctness. Imagine we have forall k. b -> k, where b has+   kind k, for some k bound in an outer scope. If we look at b's kind inside+   the forall, we'll collect that k is free and then remove k from the set of+   free variables. This is plain wrong. We must instead compute that b is free+   and then conclude that b's kind is free.++An obvious first approach is to move the closing-over-kinds from the+occurrences of a type variable to after finding the free vars - however, this+turns out to introduce performance regressions, and isn't even entirely+correct.++In fact, it isn't even important *when* we close over kinds; what matters is+that we handle each type var exactly once, and that we do it in the right+context.++So the next approach we tried was to use the "in-scope set" part of FV or the+equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to+say "don't bother with variables we have already closed over". This should work+fine in theory, but the code is complicated and doesn't perform well.++But there is a simpler way, which is implemented here. Consider the two points+above:++1. Efficiency: we now have an accumulator, so the second time we encounter 'a',+   we'll ignore it, certainly not looking at its kind - this is why+   pre-checking set membership before inserting ends up not only being faster,+   but also being correct.++2. Correctness: we have an "in-scope set" (I think we should call it it a+  "bound-var set"), specifying variables that are bound by a forall in the type+  we are traversing; we simply ignore these variables, certainly not looking at+  their kind.++So now consider:++    forall k. b -> k++where b :: k->Type is free; but of course, it's a different k! When looking at+b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose+this is our first encounter with b; we want the free vars of its kind. But we+want to behave as if we took the free vars of its kind at the end; that is,+with no bound vars in scope.++So the solution is easy. The old code was this:++  ty_co_vars_of_type (TyVarTy v) is acc+    | v `elemVarSet` is  = acc+    | v `elemVarSet` acc = acc+    | otherwise          = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v)++Now all we need to do is take the free vars of tyVarKind v *with an empty+bound-var set*, thus:++ty_co_vars_of_type (TyVarTy v) is acc+  | v `elemVarSet` is  = acc+  | v `elemVarSet` acc = acc+  | otherwise          = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v)+                                                          ^^^^^^^^^^^++And that's it. This works because a variable is either bound or free. If it is bound,+then we won't look at it at all. If it is free, then all the variables free in its+kind are free -- regardless of whether some local variable has the same Unique.+So if we're looking at a variable occurrence at all, then all variables in its+kind are free.++Note [Free vars and synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When finding free variables we generally do not expand synonyms.  So given+   type T a = Int+the type (T [b]) will return `b` as a free variable, even though expanding the+synonym would get rid of it.  Expanding synonyms might lead to types that look+ill-scoped; an alternative we have not explored.++But see `occCheckExpand` in this module for a function that does, selectively,+expand synonyms to reduce free-var occurences.+-}++{- *********************************************************************+*                                                                      *+          Endo for free variables+*                                                                      *+********************************************************************* -}++{- Note [Accumulating parameter free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can use foldType to build an accumulating-parameter version of a+free-var finder, thus:++    fvs :: Type -> TyCoVarSet+    fvs ty = appEndo (foldType folder ty) emptyVarSet++Recall that+    foldType :: TyCoFolder env a -> env -> Type -> a++    newtype Endo a = Endo (a -> a)   -- In Data.Monoid+    instance Monoid a => Monoid (Endo a) where+       (Endo f) `mappend` (Endo g) = Endo (f.g)++    appEndo :: Endo a -> a -> a+    appEndo (Endo f) x = f x++So `mappend` for Endos is just function composition.++It's very important that, after optimisation, we end up with+* an arity-three function+* that is strict in the accumulator++   fvs env (TyVarTy v) acc+      | v `elemVarSet` env = acc+      | v `elemVarSet` acc = acc+      | otherwise          = acc `extendVarSet` v+   fvs env (AppTy t1 t2)   = fvs env t1 (fvs env t2 acc)+   ...++The "strict in the accumulator" part is to ensure that in the+AppTy equation we don't build a thunk for (fvs env t2 acc).++The optimiser does do all this, but not very robustly. It depends+critically on the basic arity-2 function not being exported, so that+all its calls are visibly to three arguments. This analysis is+done by the Call Arity pass.++TL;DR: check this regularly!+-}++runTyCoVars :: Endo TyCoVarSet -> TyCoVarSet+{-# INLINE runTyCoVars #-}+runTyCoVars f = appEndo f emptyVarSet++{- *********************************************************************+*                                                                      *+          Deep free variables+          See Note [Shallow and deep free variables]+*                                                                      *+********************************************************************* -}++tyCoVarsOfType :: Type -> TyCoVarSet+-- The "deep" TyCoVars of the the type+tyCoVarsOfType ty = runTyCoVars (deep_ty ty)+-- Alternative:+--   tyCoVarsOfType ty = closeOverKinds (shallowTyCoVarsOfType ty)++tyCoVarsOfTypes :: [Type] -> TyCoVarSet+-- The "deep" TyCoVars of the the type+tyCoVarsOfTypes tys = runTyCoVars (deep_tys tys)+-- Alternative:+--   tyCoVarsOfTypes tys = closeOverKinds (shallowTyCoVarsOfTypes tys)++tyCoVarsOfCo :: Coercion -> TyCoVarSet+-- The "deep" TyCoVars of the the coercion+-- See Note [Free variables of types]+tyCoVarsOfCo co = runTyCoVars (deep_co co)++tyCoVarsOfMCo :: MCoercion -> TyCoVarSet+tyCoVarsOfMCo MRefl    = emptyVarSet+tyCoVarsOfMCo (MCo co) = tyCoVarsOfCo co++tyCoVarsOfCos :: [Coercion] -> TyCoVarSet+tyCoVarsOfCos cos = runTyCoVars (deep_cos cos)++deep_ty  :: Type       -> Endo TyCoVarSet+deep_tys :: [Type]     -> Endo TyCoVarSet+deep_co  :: Coercion   -> Endo TyCoVarSet+deep_cos :: [Coercion] -> Endo TyCoVarSet+(deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet++deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)+deepTcvFolder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]+                           , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                           , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = appEndo (deep_ty (varType v)) $+                                         acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole is hole  = do_tcv is (coHoleCoVar hole)+                       -- See Note [CoercionHoles and coercion free variables]+                       -- in GHC.Core.TyCo.Rep++{- *********************************************************************+*                                                                      *+          Shallow free variables+          See Note [Shallow and deep free variables]+*                                                                      *+********************************************************************* -}+++shallowTyCoVarsOfType :: Type -> TyCoVarSet+-- See Note [Free variables of types]+shallowTyCoVarsOfType ty = runTyCoVars (shallow_ty ty)++shallowTyCoVarsOfTypes :: [Type] -> TyCoVarSet+shallowTyCoVarsOfTypes tys = runTyCoVars (shallow_tys tys)++shallowTyCoVarsOfCo :: Coercion -> TyCoVarSet+shallowTyCoVarsOfCo co = runTyCoVars (shallow_co co)++shallowTyCoVarsOfCos :: [Coercion] -> TyCoVarSet+shallowTyCoVarsOfCos cos = runTyCoVars (shallow_cos cos)++-- | Returns free variables of types, including kind variables as+-- a non-deterministic set. For type synonyms it does /not/ expand the+-- synonym.+shallowTyCoVarsOfTyVarEnv :: TyVarEnv Type -> TyCoVarSet+-- See Note [Free variables of types]+shallowTyCoVarsOfTyVarEnv tys = shallowTyCoVarsOfTypes (nonDetEltsUFM tys)+  -- It's OK to use nonDetEltsUFM here because we immediately+  -- forget the ordering by returning a set++shallowTyCoVarsOfCoVarEnv :: CoVarEnv Coercion -> TyCoVarSet+shallowTyCoVarsOfCoVarEnv cos = shallowTyCoVarsOfCos (nonDetEltsUFM cos)+  -- It's OK to use nonDetEltsUFM here because we immediately+  -- forget the ordering by returning a set++shallow_ty  :: Type       -> Endo TyCoVarSet+shallow_tys :: [Type]     -> Endo TyCoVarSet+shallow_co  :: Coercion   -> Endo TyCoVarSet+shallow_cos :: [Coercion] -> Endo TyCoVarSet+(shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet++shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)+shallowTcvFolder = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]+                              , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                              , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole _ _  = mempty   -- Ignore coercion holes+++{- *********************************************************************+*                                                                      *+          Free coercion variables+*                                                                      *+********************************************************************* -}+++{- Note [Finding free coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here we are only interested in the free /coercion/ variables.+We can achieve this through a slightly different TyCo folder.++Notice that we look deeply, into kinds.++See #14880.+-}++-- See Note [Finding free coercion variables]+coVarsOfType  :: Type       -> CoVarSet+coVarsOfTypes :: [Type]     -> CoVarSet+coVarsOfCo    :: Coercion   -> CoVarSet+coVarsOfCos   :: [Coercion] -> CoVarSet++coVarsOfType  ty  = runTyCoVars (deep_cv_ty ty)+coVarsOfTypes tys = runTyCoVars (deep_cv_tys tys)+coVarsOfCo    co  = runTyCoVars (deep_cv_co co)+coVarsOfCos   cos = runTyCoVars (deep_cv_cos cos)++deep_cv_ty  :: Type       -> Endo CoVarSet+deep_cv_tys :: [Type]     -> Endo CoVarSet+deep_cv_co  :: Coercion   -> Endo CoVarSet+deep_cv_cos :: [Coercion] -> Endo CoVarSet+(deep_cv_ty, deep_cv_tys, deep_cv_co, deep_cv_cos) = foldTyCo deepCoVarFolder emptyVarSet++deepCoVarFolder :: TyCoFolder TyCoVarSet (Endo CoVarSet)+deepCoVarFolder = TyCoFolder { tcf_view = noView+                             , tcf_tyvar = do_tyvar, tcf_covar = do_covar+                             , tcf_hole  = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tyvar _ _  = mempty+      -- This do_tyvar means we won't see any CoVars in this+      -- TyVar's kind.   This may be wrong; but it's the way it's+      -- always been.  And its awkward to change, because+      -- the tyvar won't end up in the accumulator, so+      -- we'd look repeatedly.  Blargh.++    do_covar is v = Endo do_it+      where+        do_it acc | v `elemVarSet` is  = acc+                  | v `elemVarSet` acc = acc+                  | otherwise          = appEndo (deep_cv_ty (varType v)) $+                                         acc `extendVarSet` v++    do_bndr is tcv _ = extendVarSet is tcv+    do_hole is hole  = do_covar is (coHoleCoVar hole)+                       -- See Note [CoercionHoles and coercion free variables]+                       -- in GHC.Core.TyCo.Rep++------- Same again, but for DCoVarSet ----------+--    But this time the free vars are shallow++coVarsOfCosDSet :: [Coercion] -> DCoVarSet+coVarsOfCosDSet cos = fvDVarSetSome isCoVar (tyCoFVsOfCos cos)++coVarsOfCoDSet :: Coercion -> DCoVarSet+coVarsOfCoDSet co = fvDVarSetSome isCoVar (tyCoFVsOfCo co)+++{- *********************************************************************+*                                                                      *+          Closing over kinds+*                                                                      *+********************************************************************* -}++------------- Closing over kinds -----------------++closeOverKinds :: TyCoVarSet -> TyCoVarSet+-- For each element of the input set,+-- add the deep free variables of its kind+closeOverKinds vs = nonDetStrictFoldVarSet do_one vs vs+  where+    do_one v acc = appEndo (deep_ty (varType v)) acc++{- --------------- Alternative version 1 (using FV) ------------+closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet+-}++{- ---------------- Alternative version 2 -------------++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a non-deterministic set.+closeOverKinds :: TyCoVarSet -> TyCoVarSet+closeOverKinds vs+   = go vs vs+  where+    go :: VarSet   -- Work list+       -> VarSet   -- Accumulator, always a superset of wl+       -> VarSet+    go wl acc+      | isEmptyVarSet wl = acc+      | otherwise        = go wl_kvs (acc `unionVarSet` wl_kvs)+      where+        k v inner_acc = ty_co_vars_of_type (varType v) acc inner_acc+        wl_kvs = nonDetFoldVarSet k emptyVarSet wl+        -- wl_kvs = union of shallow free vars of the kinds of wl+        --          but don't bother to collect vars in acc++-}++{- ---------------- Alternative version 3 -------------+-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a non-deterministic set.+closeOverKinds :: TyVarSet -> TyVarSet+closeOverKinds vs = close_over_kinds vs emptyVarSet+++close_over_kinds :: TyVarSet  -- Work list+                 -> TyVarSet  -- Accumulator+                 -> TyVarSet+-- Precondition: in any call (close_over_kinds wl acc)+--  for every tv in acc, the shallow kind-vars of tv+--  are either in the work list wl, or in acc+-- Postcondition: result is the deep free vars of (wl `union` acc)+close_over_kinds wl acc+  = nonDetFoldVarSet do_one acc wl+  where+    do_one :: Var -> TyVarSet -> TyVarSet+    -- (do_one v acc) adds v and its deep free-vars to acc+    do_one v acc | v `elemVarSet` acc+                 = acc+                 | otherwise+                 = close_over_kinds (shallowTyCoVarsOfType (varType v)) $+                   acc `extendVarSet` v+-}+++{- *********************************************************************+*                                                                      *+          The FV versions return deterministic results+*                                                                      *+********************************************************************* -}++-- | Given a list of tyvars returns a deterministic FV computation that+-- returns the given tyvars with the kind variables free in the kinds of the+-- given tyvars.+closeOverKindsFV :: [TyVar] -> FV+closeOverKindsFV tvs =+  mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministically ordered list.+closeOverKindsList :: [TyVar] -> [TyVar]+closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs++-- | Add the kind variables free in the kinds of the tyvars in the given set.+-- Returns a deterministic set.+closeOverKindsDSet :: DTyVarSet -> DTyVarSet+closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems++-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic+-- set. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty++-- | `tyCoFVsOfType` that returns free variables of a type in deterministic+-- order. For explanation of why using `VarSet` is not deterministic see+-- Note [Deterministic FV] in "GHC.Utils.FV".+tyCoVarsOfTypeList :: Type -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty++-- | Returns free variables of types, including kind variables as+-- a deterministic set. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys++-- | Returns free variables of types, including kind variables as+-- a deterministically ordered list. For type synonyms it does /not/ expand the+-- synonym.+tyCoVarsOfTypesList :: [Type] -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys++-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`.+-- The previous implementation used `unionVarSet` which is O(n+m) and can+-- make the function quadratic.+-- It's exported, so that it can be composed with+-- other functions that compute free variables.+-- See Note [FV naming conventions] in "GHC.Utils.FV".+--+-- Eta-expanded because that makes it run faster (apparently)+-- See Note [FV eta expansion] in "GHC.Utils.FV" for explanation.+tyCoFVsOfType :: Type -> FV+-- See Note [Free variables of types]+tyCoFVsOfType (TyVarTy v)        f bound_vars (acc_list, acc_set)+  | not (f v) = (acc_list, acc_set)+  | v `elemVarSet` bound_vars = (acc_list, acc_set)+  | v `elemVarSet` acc_set = (acc_list, acc_set)+  | otherwise = tyCoFVsOfType (tyVarKind v) f+                               emptyVarSet   -- See Note [Closing over free variable kinds]+                               (v:acc_list, extendVarSet acc_set v)+tyCoFVsOfType (TyConApp _ tys)   f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc+                                                    -- See Note [Free vars and synonyms]+tyCoFVsOfType (LitTy {})         f bound_vars acc = emptyFV f bound_vars acc+tyCoFVsOfType (AppTy fun arg)    f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc+tyCoFVsOfType (FunTy _ w arg res)  f bound_vars acc = (tyCoFVsOfType w `unionFV` tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc+tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty)  f bound_vars acc+tyCoFVsOfType (CastTy ty co)     f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc+tyCoFVsOfType (CoercionTy co)    f bound_vars acc = tyCoFVsOfCo co f bound_vars acc++tyCoFVsBndr :: ForAllTyBinder -> FV -> FV+-- Free vars of (forall b. <thing with fvs>)+tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs++tyCoFVsVarBndrs :: [Var] -> FV -> FV+tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars++tyCoFVsVarBndr :: Var -> FV -> FV+tyCoFVsVarBndr var fvs+  = tyCoFVsOfType (varType var)   -- Free vars of its type/kind+    `unionFV` delFV var fvs       -- Delete it from the thing-inside++tyCoFVsOfTypes :: [Type] -> FV+-- See Note [Free variables of types]+tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc+tyCoFVsOfTypes []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc++-- | Get a deterministic set of the vars free in a coercion+tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet+-- See Note [Free variables of types]+tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co++tyCoVarsOfCoList :: Coercion -> [TyCoVar]+-- See Note [Free variables of types]+tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co++tyCoFVsOfMCo :: MCoercion -> FV+tyCoFVsOfMCo MRefl    = emptyFV+tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co++tyCoFVsOfCo :: Coercion -> FV+-- Extracts type and coercion variables from a coercion+-- See Note [Free variables of types]+tyCoFVsOfCo (Refl ty) fv_cand in_scope acc+  = tyCoFVsOfType ty fv_cand in_scope acc+tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc+  = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc+tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc+tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc+  = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc+  = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc+tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc+  = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc+tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc+  = tyCoFVsOfCoVar v fv_cand in_scope acc+tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc+  = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc+    -- See Note [CoercionHoles and coercion free variables]+tyCoFVsOfCo (AxiomCo _ cs)    fv_cand in_scope acc = tyCoFVsOfCos cs  fv_cand in_scope acc+tyCoFVsOfCo (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps}) fv_cand in_scope acc+  = (tyCoFVsOfCos deps `unionFV` tyCoFVsOfType t1+                      `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc+tyCoFVsOfCo (SymCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (TransCo co1 co2)   fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc+tyCoFVsOfCo (SelCo _ co)        fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (LRCo _ co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (InstCo co arg)     fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc+tyCoFVsOfCo (KindCo co)         fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc+tyCoFVsOfCo (SubCo co)          fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc++tyCoFVsOfCoVar :: CoVar -> FV+tyCoFVsOfCoVar v fv_cand in_scope acc+  = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc++tyCoFVsOfCos :: [Coercion] -> FV+tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc+tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc+++----- Whether a covar is /Almost Devoid/ in a type or coercion ----++-- | Given a covar and a coercion, returns True if covar is almost devoid in+-- the coercion. That is, covar can only appear in Refl and GRefl.+-- See (FC6) in Note [ForAllCo] in "GHC.Core.TyCo.Rep"+almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool+almostDevoidCoVarOfCo cv co =+  almost_devoid_co_var_of_co co cv++almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool+almost_devoid_co_var_of_co (Refl {}) _ = True   -- covar is allowed in Refl and+almost_devoid_co_var_of_co (GRefl {}) _ = True  -- GRefl, so we don't look into+                                                -- the coercions+almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv+  = almost_devoid_co_var_of_cos cos cv+almost_devoid_co_var_of_co (AppCo co arg) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_co arg cv+almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv+  = almost_devoid_co_var_of_co kind_co cv+  && (v == cv || almost_devoid_co_var_of_co co cv)+almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv+  =  almost_devoid_co_var_of_co w   cv+  && almost_devoid_co_var_of_co co1 cv+  && almost_devoid_co_var_of_co co2 cv+almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv+almost_devoid_co_var_of_co (HoleCo h)  cv = (coHoleCoVar h) /= cv+almost_devoid_co_var_of_co (AxiomCo _ cs) cv+  = almost_devoid_co_var_of_cos cs cv+almost_devoid_co_var_of_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps }) cv+  =  almost_devoid_co_var_of_cos deps cv+  && almost_devoid_co_var_of_type t1 cv+  && almost_devoid_co_var_of_type t2 cv+almost_devoid_co_var_of_co (SymCo co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (TransCo co1 co2) cv+  = almost_devoid_co_var_of_co co1 cv+  && almost_devoid_co_var_of_co co2 cv+almost_devoid_co_var_of_co (SelCo _ co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (LRCo _ co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (InstCo co arg) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_co arg cv+almost_devoid_co_var_of_co (KindCo co) cv+  = almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_co (SubCo co) cv+  = almost_devoid_co_var_of_co co cv++almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool+almost_devoid_co_var_of_cos [] _ = True+almost_devoid_co_var_of_cos (co:cos) cv+  = almost_devoid_co_var_of_co co cv+  && almost_devoid_co_var_of_cos cos cv++almost_devoid_co_var_of_type :: Type -> CoVar -> Bool+almost_devoid_co_var_of_type (TyVarTy _) _ = True+almost_devoid_co_var_of_type (TyConApp _ tys) cv+  = almost_devoid_co_var_of_types tys cv+almost_devoid_co_var_of_type (LitTy {}) _ = True+almost_devoid_co_var_of_type (AppTy fun arg) cv+  = almost_devoid_co_var_of_type fun cv+  && almost_devoid_co_var_of_type arg cv+almost_devoid_co_var_of_type (FunTy _ w arg res) cv+  = almost_devoid_co_var_of_type w cv+  && almost_devoid_co_var_of_type arg cv+  && almost_devoid_co_var_of_type res cv+almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv+  = almost_devoid_co_var_of_type (varType v) cv+  && (v == cv || almost_devoid_co_var_of_type ty cv)+almost_devoid_co_var_of_type (CastTy ty co) cv+  = almost_devoid_co_var_of_type ty cv+  && almost_devoid_co_var_of_co co cv+almost_devoid_co_var_of_type (CoercionTy co) cv+  = almost_devoid_co_var_of_co co cv++almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool+almost_devoid_co_var_of_types [] _ = True+almost_devoid_co_var_of_types (ty:tys) cv+  = almost_devoid_co_var_of_type ty cv+  && almost_devoid_co_var_of_types tys cv++++{-+%************************************************************************+%*                                                                      *+        Free tyvars, but with visible/invisible info+%*                                                                      *+%************************************************************************++-}+-- | Retrieve the free variables in this type, splitting them based+-- on whether they are used visibly or invisibly. Invisible ones come+-- first.+visVarsOfType :: Type -> Pair TyCoVarSet+visVarsOfType orig_ty = Pair invis_vars vis_vars+  where+    Pair invis_vars1 vis_vars = go orig_ty+    invis_vars = invis_vars1 `minusVarSet` vis_vars++    go (TyVarTy tv)      = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv)+    go (AppTy t1 t2)     = go t1 `mappend` go t2+    go (TyConApp tc tys) = go_tc tc tys+    go (FunTy _ w t1 t2) = go w `mappend` go t1 `mappend` go t2+    go (ForAllTy (Bndr tv _) ty)+      = ((`delVarSet` tv) <$> go ty) `mappend`+        (invisible (tyCoVarsOfType $ varType tv))+    go (LitTy {}) = mempty+    go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co)+    go (CoercionTy co) = invisible $ tyCoVarsOfCo co++    invisible vs = Pair vs emptyVarSet++    go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in+                   invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis++visVarsOfTypes :: [Type] -> Pair TyCoVarSet+visVarsOfTypes = foldMap visVarsOfType+++{- *********************************************************************+*                                                                      *+                 Injective free vars+*                                                                      *+********************************************************************* -}++isInjectiveInType :: TyVar -> Type -> Bool+-- True <=> tv /definitely/ appears injectively in ty+-- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty)+-- Ignore occurrence in coercions, and even in injective positions of+-- type families.+isInjectiveInType tv ty+  = go ty+  where+    go ty | Just ty' <- rewriterView ty = go ty'+    go (TyVarTy tv')                    = tv' == tv+    go (AppTy f a)                      = go f || go a+    go (FunTy _ w ty1 ty2)              = go w || go ty1 || go ty2+    go (TyConApp tc tys)                = go_tc tc tys+    go (ForAllTy (Bndr tv' _) ty)       = go (tyVarKind tv')+                                          || (tv /= tv' && go ty)+    go LitTy{}                          = False+    go (CastTy ty _)                    = go ty+    go CoercionTy{}                     = False++    go_tc tc tys | isTypeFamilyTyCon tc = False+                 | otherwise            = any go tys++-- | Returns the free variables of a 'Type' that are in injective positions.+-- Specifically, it finds the free variables while:+--+-- * Expanding type synonyms+--+-- * Ignoring the coercion in @(ty |> co)@+--+-- * Ignoring the non-injective fields of a 'TyConApp'+--+--+-- For example, if @F@ is a non-injective type family, then:+--+-- @+-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c}+-- @+--+-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@.+-- More formally, if+-- @a@ is in @'injectiveVarsOfType' ty@+-- and  @S1(ty) ~ S2(ty)@,+-- then @S1(a)  ~ S2(a)@,+-- where @S1@ and @S2@ are arbitrary substitutions.+--+-- See @Note [When does a tycon application need an explicit kind signature?]@.+injectiveVarsOfType :: Bool   -- ^ Should we look under injective type families?+                              -- See Note [Coverage condition for injective type families]+                              -- in "GHC.Tc.Instance.Family".+                    -> Type -> FV+injectiveVarsOfType look_under_tfs = go+  where+    go ty | Just ty' <- rewriterView ty = go ty'+    go (TyVarTy v)                      = unitFV v `unionFV` go (tyVarKind v)+    go (AppTy f a)                      = go f `unionFV` go a+    go (FunTy _ w ty1 ty2)              = go w `unionFV` go ty1 `unionFV` go ty2+    go (TyConApp tc tys)                = go_tc tc tys+    go (ForAllTy (Bndr tv _) ty)        = go (tyVarKind tv) `unionFV` delFV tv (go ty)+    go LitTy{}                          = emptyFV+    go (CastTy ty _)                    = go ty+    go CoercionTy{}                     = emptyFV++    go_tc tc tys+      | isTypeFamilyTyCon tc+      = if | look_under_tfs+           , Injective flags <- tyConInjectivityInfo tc+           -> mapUnionFV go $+              filterByList (flags ++ repeat True) tys+                         -- Oversaturated arguments to a tycon are+                         -- always injective, hence the repeat True+           | otherwise   -- No injectivity info for this type family+           -> emptyFV++      | otherwise        -- Data type, injective in all positions+      = mapUnionFV go tys++-- | Returns the free variables of a 'Type' that are in injective positions.+-- Specifically, it finds the free variables while:+--+-- * Expanding type synonyms+--+-- * Ignoring the coercion in @(ty |> co)@+--+-- * Ignoring the non-injective fields of a 'TyConApp'+--+-- See @Note [When does a tycon application need an explicit kind signature?]@.+injectiveVarsOfTypes :: Bool -- ^ look under injective type families?+                             -- See Note [Coverage condition for injective type families]+                             -- in "GHC.Tc.Instance.Family".+                     -> [Type] -> FV+injectiveVarsOfTypes look_under_tfs = mapUnionFV (injectiveVarsOfType look_under_tfs)+++{- *********************************************************************+*                                                                      *+                 Invisible vars+*                                                                      *+********************************************************************* -}+++-- | Returns the set of variables that are used invisibly anywhere within+-- the given type. A variable will be included even if it is used both visibly+-- and invisibly. An invisible use site includes:+--   * In the kind of a variable+--   * In the kind of a bound variable in a forall+--   * In a coercion+--   * In a Specified or Inferred argument to a function+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"+invisibleVarsOfType :: Type -> FV+invisibleVarsOfType = go+  where+    go ty                 | Just ty' <- coreView ty+                          = go ty'+    go (TyVarTy v)        = go (tyVarKind v)+    go (AppTy f a)        = go f `unionFV` go a+    go (FunTy _ w ty1 ty2) = go w `unionFV` go ty1 `unionFV` go ty2+    go (TyConApp tc tys)  = tyCoFVsOfTypes invisibles `unionFV`+                            invisibleVarsOfTypes visibles+      where (invisibles, visibles) = partitionInvisibleTypes tc tys+    go (ForAllTy tvb ty)  = tyCoFVsBndr tvb $ go ty+    go LitTy{}            = emptyFV+    go (CastTy ty co)     = tyCoFVsOfCo co `unionFV` go ty+    go (CoercionTy co)    = tyCoFVsOfCo co++-- | Like 'invisibleVarsOfType', but for many types.+invisibleVarsOfTypes :: [Type] -> FV+invisibleVarsOfTypes = mapUnionFV invisibleVarsOfType+++{- *********************************************************************+*                                                                      *+                 Any free vars+*                                                                      *+********************************************************************* -}++{-# INLINE afvFolder #-}   -- so that specialization to (const True) works+afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any+-- 'afvFolder' is short for "any-free-var folder", good for checking+-- if any free var of a type satisfies a predicate `check_fv`+afvFolder check_fv = TyCoFolder { tcf_view = noView  -- See Note [Free vars and synonyms]+                                , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                                , tcf_hole = do_hole, tcf_tycobinder = do_bndr }+  where+    do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv)+    do_hole _ _  = Any False    -- I'm unsure; probably never happens+    do_bndr is tv _ = is `extendVarSet` tv++anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool+anyFreeVarsOfType check_fv ty = DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet++anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool+anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet++anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool+anyFreeVarsOfCo check_fv co = DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet++noFreeVarsOfType :: Type -> Bool+noFreeVarsOfType ty = not $ DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet++noFreeVarsOfTypes :: [Type] -> Bool+noFreeVarsOfTypes tys = not $ DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet++noFreeVarsOfCo :: Coercion -> Bool+noFreeVarsOfCo co = not $ DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet+++{-+************************************************************************+*                                                                      *+            Free type constructors+*                                                                      *+************************************************************************+-}++{- Note [tyConsOfType]+~~~~~~~~~~~~~~~~~~~~~~+It is slightly odd to find the TyCons of a type.  Especially since, via a type+family reduction or axiom, a type that doesn't mention T might start to mention T.++This function is used in only three places:+* In GHC.Tc.Validity.validDerivPred, when identifying "exotic" predicates.+* In GHC.Tc.Errors.Ppr.pprTcSolverReportMsg, when trying to print a helpful+  error about overlapping instances+* In utils/dump-decls/Main.hs, an ill-documented module.++None seem critical. Currently tyConsOfType looks inside coercions, but perhaps+it doesn't even need to do that.+-}++-- | All type constructors occurring in the type; looking through type+--   synonyms, but not newtypes.+--  When it finds a Class, it returns the class TyCon.+tyConsOfType :: Type -> UniqSet TyCon+tyConsOfType ty+  = go ty+  where+     go :: Type -> UniqSet TyCon  -- The UniqSet does duplicate elim+     go ty | Just ty' <- coreView ty = go ty'+     go (TyVarTy {})                = emptyUniqSet+     go (LitTy {})                  = emptyUniqSet+     go (TyConApp tc tys)           = go_tc tc `unionUniqSets` tyConsOfTypes tys+     go (AppTy a b)                 = go a `unionUniqSets` go b+     go (FunTy af w a b)            = go w `unionUniqSets`+                                      go a `unionUniqSets` go b+                                      `unionUniqSets` go_tc (funTyFlagTyCon af)+     go (ForAllTy (Bndr tv _) ty)   = go ty `unionUniqSets` go (varType tv)+     go (CastTy ty co)              = go ty `unionUniqSets` go_co co+     go (CoercionTy co)             = go_co co++     go_co (Refl ty)               = go ty+     go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco+     go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args+     go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg+     go_co (ForAllCo { fco_kind = kind_co, fco_body = co })+                                   = go_co kind_co `unionUniqSets` go_co co+     go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })+                                   = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r+     go_co (AxiomCo ax args)       = go_ax ax `unionUniqSets` go_cos args+     go_co (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = cos })+                                   = go t1 `unionUniqSets` go t2 `unionUniqSets` go_cos cos+     go_co (CoVarCo {})            = emptyUniqSet+     go_co (HoleCo {})             = emptyUniqSet+     go_co (SymCo co)              = go_co co+     go_co (TransCo co1 co2)       = go_co co1 `unionUniqSets` go_co co2+     go_co (SelCo _ co)            = go_co co+     go_co (LRCo _ co)             = go_co co+     go_co (InstCo co arg)         = go_co co `unionUniqSets` go_co arg+     go_co (KindCo co)             = go_co co+     go_co (SubCo co)              = go_co co++     go_mco MRefl    = emptyUniqSet+     go_mco (MCo co) = go_co co++     go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos++     go_tc tc = unitUniqSet tc++     go_ax (UnbranchedAxiom ax) = go_tc $ coAxiomTyCon ax+     go_ax (BranchedAxiom ax _) = go_tc $ coAxiomTyCon ax+     go_ax (BuiltInFamRew  bif) = go_tc $ bifrw_fam_tc bif+     go_ax (BuiltInFamInj {})   = emptyUniqSet  -- A free-floating axiom++tyConsOfTypes :: [Type] -> UniqSet TyCon+tyConsOfTypes tys = foldr (unionUniqSets . tyConsOfType) emptyUniqSet tys++{- **********************************************************************+*                                                                       *+           Occurs check expansion+%*                                                                      *+%********************************************************************* -}++{- Note [Occurs check expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid+of occurrences of tv outside type function arguments, if that is+possible; otherwise, it returns Nothing.++For example, suppose we have+  type F a b = [a]+Then+  occCheckExpand b (F Int b) = Just [Int]+but+  occCheckExpand a (F a Int) = Nothing++We don't promise to do the absolute minimum amount of expanding+necessary, but we try not to do expansions we don't need to.  We+prefer doing inner expansions first.  For example,+  type F a b = (a, Int, a, [a])+  type G b   = Char+We have+  occCheckExpand b (F (G b)) = Just (F Char)+even though we could also expand F to get rid of b.++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.++occCheckExpand tries to expand type synonyms to remove+unnecessary occurrences of a variable, and thereby get past an+occurs-check failure.  This is good; but+     we can't do it in the /kind/ of a variable /occurrence/++For example #18451 built an infinite type:+    type Const a b = a+    data SameKind :: k -> k -> Type+    type T (k :: Const Type a) = forall (b :: k). SameKind a b++We have+  b :: k+  k :: Const Type a+  a :: k   (must be same as b)++So if we aren't careful, a's kind mentions a, which is bad.+And expanding an /occurrence/ of 'a' doesn't help, because the+/binding site/ is the master copy and all the occurrences should+match it.++Here's a related example:+   f :: forall a b (c :: Const Type b). Proxy '[a, c]++The list means that 'a' gets the same kind as 'c'; but that+kind mentions 'b', so the binders are out of order.++Bottom line: in occCheckExpand, do not expand inside the kinds+of occurrences.  See bad_var_occ in occCheckExpand.  And+see #18451 for more debate.+-}++occCheckExpand :: [Var] -> Type -> Maybe Type+-- See Note [Occurs check expansion]+-- We may have needed to do some type synonym unfolding in order to+-- get rid of the variable (or forall), so we also return the unfolded+-- version of the type, which is guaranteed to be syntactically free+-- of the given type variable.  If the type is already syntactically+-- free of the variable, then the same type is returned.+occCheckExpand vs_to_avoid ty+  | null vs_to_avoid  -- Efficient shortcut+  = Just ty           -- Can happen, eg. GHC.Core.Utils.mkSingleAltCase++  | otherwise+  = go (mkVarSet vs_to_avoid, emptyVarEnv) ty+  where+    go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type+          -- The VarSet is the set of variables we are trying to avoid+          -- The VarEnv carries mappings necessary+          -- because of kind expansion+    go (as, env) ty@(TyVarTy tv)+      | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv')+      | bad_var_occ as tv               = Nothing+      | otherwise                       = return ty++    go _   ty@(LitTy {}) = return ty+    go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1+                                ; ty2' <- go cxt ty2+                                ; return (AppTy ty1' ty2') }+    go cxt ty@(FunTy _ w ty1 ty2)+       = do { w'   <- go cxt w+            ; ty1' <- go cxt ty1+            ; ty2' <- go cxt ty2+            ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) }+    go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)+       = do { ki' <- go cxt (varType tv)+            ; let tv'  = setVarType tv ki'+                  env' = extendVarEnv env tv tv'+                  as'  = as `delVarSet` tv+            ; body' <- go (as', env') body_ty+            ; return (ForAllTy (Bndr tv' vis) body') }++    -- For a type constructor application, first try expanding away the+    -- offending variable from the arguments.  If that doesn't work, next+    -- see if the type constructor is a type synonym, and if so, expand+    -- it and try again.+    go cxt ty@(TyConApp tc tys)+      = case mapM (go cxt) tys of+          Just tys' -> return (TyConApp tc tys')+          Nothing | Just ty' <- coreView ty -> go cxt ty'+                  | otherwise               -> Nothing+                      -- Failing that, try to expand a synonym++    go cxt (CastTy ty co) =  do { ty' <- go cxt ty+                                ; co' <- go_co cxt co+                                ; return (CastTy ty' co') }+    go cxt (CoercionTy co) = do { co' <- go_co cxt co+                                ; return (CoercionTy co') }++    ------------------+    bad_var_occ :: VarSet -> Var -> Bool+    -- Works for TyVar and CoVar+    -- See Note [Occurrence checking: look inside kinds]+    bad_var_occ vs_to_avoid v+       =  v                          `elemVarSet`       vs_to_avoid+       || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid++    ------------------+    go_mco _   MRefl = return MRefl+    go_mco ctx (MCo co) = MCo <$> go_co ctx co++    ------------------+    go_co cxt (Refl ty)                 = do { ty' <- go cxt ty+                                             ; return (Refl ty') }+    go_co cxt (GRefl r ty mco)          = do { mco' <- go_mco cxt mco+                                             ; ty' <- go cxt ty+                                             ; return (GRefl r ty' mco') }+      -- Note: Coercions do not contain type synonyms+    go_co cxt (TyConAppCo r tc args)    = do { args' <- mapM (go_co cxt) args+                                             ; return (TyConAppCo r tc args') }+    go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co+                                             ; arg' <- go_co cxt arg+                                             ; return (AppCo co' arg') }+    go_co cxt (SymCo co)                = do { co' <- go_co cxt co+                                             ; return (SymCo co') }+    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1+                                             ; co2' <- go_co cxt co2+                                             ; return (TransCo co1' co2') }+    go_co cxt (SelCo n co)              = do { co' <- go_co cxt co+                                             ; return (SelCo n co') }+    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co+                                             ; return (LRCo lr co') }+    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co+                                             ; arg' <- go_co cxt arg+                                             ; return (InstCo co' arg') }+    go_co cxt (KindCo co)               = do { co' <- go_co cxt co+                                             ; return (KindCo co') }+    go_co cxt (SubCo co)                = do { co' <- go_co cxt co+                                             ; return (SubCo co') }++    go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })+      = do { kind_co' <- go_co cxt kind_co+           ; let tv' = setVarType tv $+                       coercionLKind kind_co'+                 env' = extendVarEnv env tv tv'+                 as'  = as `delVarSet` tv+           ; body' <- go_co (as', env') body_co+           ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }++    go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })+      = do { co1' <- go_co cxt co1+           ; co2' <- go_co cxt co2+           ; w' <- go_co cxt w+           ; return (co { fco_mult = w', fco_arg = co1', fco_res = co2' })}++    go_co (as,env) co@(CoVarCo c)+      | Just c' <- lookupVarEnv env c   = return (CoVarCo c')+      | bad_var_occ as c                = Nothing+      | otherwise                       = return co++    go_co (as,_) co@(HoleCo h)+      | bad_var_occ as (ch_co_var h)    = Nothing+      | otherwise                       = return co++    go_co cxt (AxiomCo ax cs)           = do { cs' <- mapM (go_co cxt) cs+                                             ; return (AxiomCo ax cs') }+    go_co cxt co@(UnivCo { uco_lty = ty1, uco_rty = ty2, uco_deps = cos })+      = do { ty1' <- go cxt ty1+           ; ty2' <- go cxt ty2+           ; cos' <- mapM (go_co cxt) cos+           ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = cos' }) }+
+ GHC/Core/TyCo/FVs.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Core.TyCo.FVs where++import GHC.Prelude ( Bool )+import GHC.Types.Var.Set( TyCoVarSet )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )++noFreeVarsOfType :: Type -> Bool+tyCoVarsOfType   :: Type -> TyCoVarSet
+ GHC/Core/TyCo/Ppr.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE PatternSynonyms #-}++-- | Pretty-printing types and coercions.+module GHC.Core.TyCo.Ppr+  (+        -- * Precedence+        PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen,++        -- * Pretty-printing types+        pprType, pprParendType, pprTidiedType, pprPrecType, pprPrecTypeX,+        pprTypeApp, pprTCvBndr, pprTCvBndrs,+        pprSigmaType,+        pprTheta, pprParendTheta, pprForAll, pprUserForAll,+        pprTyVar, pprTyVars,+        pprThetaArrowTy, pprClassPred,+        pprKind, pprParendKind, pprTyLit,+        pprDataCons, pprWithInvisibleBitsWhen,+        pprWithTYPE, pprSourceTyCon,+++        -- * Pretty-printing coercions+        pprCo, pprParendCo,++        debugPprType,+  ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.CoreToIface+   ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs+   , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )++import {-# SOURCE #-} GHC.Core.DataCon+   ( dataConFullSig , dataConUserTyVarBinders, DataCon )++import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern OneTy, pattern ManyTy,+                       splitForAllReqTyBinders, splitForAllInvisTyBinders )++import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.FVs+import GHC.Core.Class+import GHC.Core.Predicate( scopedSort )+import GHC.Core.Multiplicity( pprArrowWithMultiplicity )++import GHC.Types.Var++import GHC.Iface.Type++import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec+                       , funPrec, appPrec, maybeParen )++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing types++       Defined very early because of debug printing in assertions+%*                                                                      *+%************************************************************************++@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is+defined to use this.  @pprParendType@ is the same, except it puts+parens around the type, except for the atomic cases.  @pprParendType@+works just by setting the initial context precedence very high.++Note that any function which pretty-prints a @Type@ first converts the @Type@+to an @IfaceType@. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr.++See Note [Precedence in types] in GHC.Types.Basic.+-}++pprType, pprParendType, pprTidiedType :: Type -> SDoc+pprType       = pprPrecType topPrec+pprParendType = pprPrecType appPrec++-- already pre-tidied+pprTidiedType = pprIfaceType . toIfaceTypeX emptyVarSet++pprPrecType :: PprPrec -> Type -> SDoc+pprPrecType = pprPrecTypeX emptyTidyEnv++pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc+pprPrecTypeX env prec ty+  = getPprStyle $ \sty ->+    getPprDebug $ \debug ->+    if debug                    -- Use debugPprType when in+    then debug_ppr_ty prec ty   -- when in debug-style+    else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty)+    -- NB: debug-style is used for -dppr-debug+    --     dump-style  is used for -ddump-tc-trace etc++tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType+tidyToIfaceTypeStyX env ty sty+  | userStyle sty = tidyToIfaceTypeX env ty+  | otherwise     = toIfaceTypeX (tyCoVarsOfType ty) ty+     -- in latter case, don't tidy, as we'll be printing uniques.+++pprTyLit :: TyLit -> SDoc+pprTyLit = pprIfaceTyLit . toIfaceTyLit++pprKind, pprParendKind :: Kind -> SDoc+pprKind       = pprType+pprParendKind = pprParendType++tidyToIfaceType :: Type -> IfaceType+tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv++tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType+-- It's vital to tidy before converting to an IfaceType+-- or nested binders will become indistinguishable!+--+-- Also for the free type variables, tell toIfaceTypeX to+-- leave them as IfaceFreeTyVar.  This is super-important+-- for debug printing.+tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty)+  -- NB: if the type has /already/ been tidied (for example by the typechecker)+  --     the tidy step here is a no-op.  See Note [Tidying is idempotent]+  --     in GHC.Core.TyCo.Tidy+  where+    env'      = tidyFreeTyCoVars env free_tcvs+    free_tcvs = tyCoVarsOfTypeList ty++------------+pprCo, pprParendCo :: Coercion -> SDoc+pprCo       co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty)+pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty)++tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion+tidyToIfaceCoSty co sty+  | userStyle sty = tidyToIfaceCo co+  | otherwise     = toIfaceCoercionX (tyCoVarsOfCo co) co+     -- in latter case, don't tidy, as we'll be printing uniques.++tidyToIfaceCo :: Coercion -> IfaceCoercion+-- It's vital to tidy before converting to an IfaceType+-- or nested binders will become indistinguishable!+--+-- Also for the free type variables, tell toIfaceCoercionX to+-- leave them as IfaceFreeCoVar.  This is super-important+-- for debug printing.+tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co)+  where+    env       = tidyFreeTyCoVars emptyTidyEnv free_tcvs+    free_tcvs = scopedSort $ tyCoVarsOfCoList co+------------+pprClassPred :: Class -> [Type] -> SDoc+pprClassPred clas tys = pprTypeApp (classTyCon clas) tys++------------+pprTheta :: ThetaType -> SDoc+pprTheta = pprIfaceContext topPrec . map tidyToIfaceType++pprParendTheta :: ThetaType -> SDoc+pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType++pprThetaArrowTy :: ThetaType -> SDoc+pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType++------------------+pprSigmaType :: Type -> SDoc+pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType++pprForAll :: [ForAllTyBinder] -> SDoc+pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs)++-- | Print a user-level forall; see @Note [When to print foralls]@ in+-- "GHC.Iface.Type".+pprUserForAll :: [ForAllTyBinder] -> SDoc+pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs++pprTCvBndrs :: [ForAllTyBinder] -> SDoc+pprTCvBndrs tvs = sep (map pprTCvBndr tvs)++pprTCvBndr :: ForAllTyBinder -> SDoc+pprTCvBndr = pprTyVar . binderVar++pprTyVars :: [TyVar] -> SDoc+pprTyVars tvs = sep (map pprTyVar tvs)++pprTyVar :: TyVar -> SDoc+-- Print a type variable binder with its kind (but not if *)+-- Here we do not go via IfaceType, because the duplication with+-- pprIfaceTvBndr is minimal, and the loss of uniques etc in+-- debug printing is disastrous+pprTyVar tv+  | pickyIsLiftedTypeKind kind = ppr tv  -- See Note [Suppressing * kinds]+  | otherwise                  = parens (ppr tv <+> dcolon <+> ppr kind)+  where+    kind = tyVarKind tv++{- Note [Suppressing * kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally we want to print+      forall a. a->a+not   forall (a::*). a->a+or    forall (a::Type). a->a+That is, for brevity we suppress a kind ascription of '*' (or Type).++But what if the kind is (Const Type x)?+   type Const p q = p++Then (Const Type x) is just a long way of saying Type.  But it may be+jolly confusing to suppress the 'x'.  Suppose we have (polykinds/T18451a)+   foo :: forall a b (c :: Const Type b). Proxy '[a, c]++Then this error message+    • These kind and type variables: a b (c :: Const Type b)+      are out of dependency order. Perhaps try this ordering:+        (b :: k) (a :: Const (*) b) (c :: Const (*) b)+would be much less helpful if we suppressed the kind ascription on 'a'.++Hence the use of pickyIsLiftedTypeKind.+-}++-----------------+debugPprType :: Type -> SDoc+-- ^ debugPprType is a simple pretty printer that prints a type+-- without going through IfaceType.  It does not format as prettily+-- as the normal route, but it's much more direct, and that can+-- be useful for debugging.  E.g. with -dppr-debug it prints the+-- kind on type-variable /occurrences/ which the normal route+-- fundamentally cannot do.+debugPprType ty = debug_ppr_ty topPrec ty++debug_ppr_ty :: PprPrec -> Type -> SDoc+debug_ppr_ty _ (LitTy l)+  = ppr l++debug_ppr_ty _ (TyVarTy tv)+  = ppr tv  -- With -dppr-debug we get (tv :: kind)++debug_ppr_ty prec (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })+  = maybeParen prec funPrec $+    sep [debug_ppr_ty funPrec arg, arr <+> debug_ppr_ty prec res]+  where+    arr = pprArrowWithMultiplicity af $+          case mult of+            OneTy  -> Left True+            ManyTy -> Left False+            _      -> Right (debug_ppr_ty appPrec mult)++debug_ppr_ty prec (TyConApp tc tys)+  | null tys  = ppr tc+  | otherwise = maybeParen prec appPrec $+                hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys))++debug_ppr_ty _ (AppTy t1 t2)+  = hang (debug_ppr_ty appPrec t1)  -- Print parens so we see ((a b) c)+       2 (debug_ppr_ty appPrec t2)  -- so that we can distinguish+                                    -- TyConApp from AppTy++debug_ppr_ty prec (CastTy ty co)+  = maybeParen prec topPrec $+    hang (debug_ppr_ty topPrec ty)+       2 (text "|>" <+> ppr co)++debug_ppr_ty _ (CoercionTy co)+  = parens (text "CO" <+> ppr co)++-- Invisible forall:  forall {k} (a :: k). t+debug_ppr_ty prec t+  | (bndrs, body) <- splitForAllInvisTyBinders t+  , not (null bndrs)+  = maybeParen prec funPrec $+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,+          ppr body ]+  where+    -- (ppr tv) will print the binder kind-annotated+    -- when in debug-style+    ppr_bndr (Bndr tv InferredSpec)  = braces (ppr tv)+    ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv++-- Visible forall:  forall x y -> t+debug_ppr_ty prec t+  | (bndrs, body) <- splitForAllReqTyBinders t+  , not (null bndrs)+  = maybeParen prec funPrec $+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,+          ppr body ]+  where+    -- (ppr tv) will print the binder kind-annotated+    -- when in debug-style+    ppr_bndr (Bndr tv ()) = ppr tv++-- Impossible case: neither visible nor invisible forall.+debug_ppr_ty _ ForAllTy{}+  = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders"++{-+Note [Infix type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+With TypeOperators you can say++   f :: (a ~> b) -> b++and the (~>) is considered a type variable.  However, the type+pretty-printer in this module will just see (a ~> b) as++   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")++So it'll print the type in prefix form.  To avoid confusion we must+remember to parenthesise the operator, thus++   (~>) a b -> b++See #2766.+-}++pprDataCons :: TyCon -> SDoc+pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons+  where+    sepWithVBars [] = empty+    sepWithVBars docs = sep (punctuate (space <> vbar) docs)++pprDataConWithArgs :: DataCon -> SDoc+pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]+  where+    (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc+    user_bndrs = dataConUserTyVarBinders dc+    forAllDoc  = pprUserForAll user_bndrs+    thetaDoc   = pprThetaArrowTy theta+    argsDoc    = hsep (fmap pprParendType (map scaledThing arg_tys))+++pprTypeApp :: TyCon -> [Type] -> SDoc+pprTypeApp tc tys+  = pprIfaceTypeApp topPrec (toIfaceTyCon tc)+                            (toIfaceTcArgs tc tys)+    -- TODO: toIfaceTcArgs seems rather wasteful here++------------------+-- | Display all foralls, runtime-reps, and kind information+-- when provided 'Bool' argument is 'True'.  See GHC.Tc.Errors.Ppr+-- Note [Showing invisible bits of types in error messages]+pprWithInvisibleBitsWhen :: Bool -> SDoc -> SDoc+pprWithInvisibleBitsWhen b+  = updSDocContext $ \ctx ->+      if b then ctx { sdocPrintExplicitKinds   = True+                    , sdocPrintExplicitRuntimeReps = True }+           else ctx++-- | This variant preserves any use of TYPE in a type, effectively+-- locally setting -fprint-explicit-runtime-reps.+pprWithTYPE :: Type -> SDoc+pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $+                 ppr ty++-- | Pretty prints a 'TyCon', using the family instance in case of a+-- representation tycon.  For example:+--+-- > data T [a] = ...+--+-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon'+pprSourceTyCon :: TyCon -> SDoc+pprSourceTyCon tycon+  | Just (fam_tc, tys) <- tyConFamInst_maybe tycon+  = ppr $ fam_tc `TyConApp` tys        -- can't be FunTyCon+  | otherwise+  = ppr tycon
+ GHC/Core/TyCo/Ppr.hs-boot view
@@ -0,0 +1,12 @@+module GHC.Core.TyCo.Ppr where++import {-# SOURCE #-} GHC.Types.Var ( TyVar )+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, Coercion, TyLit)+import GHC.Utils.Outputable ( SDoc )++pprType :: Type -> SDoc+debugPprType :: Type -> SDoc+pprKind :: Kind -> SDoc+pprCo :: Coercion -> SDoc+pprTyLit :: TyLit -> SDoc+pprTyVar :: TyVar -> SDoc
+ GHC/Core/TyCo/Rep.hs view
@@ -0,0 +1,2060 @@+{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_HADDOCK not-home #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface}++Note [The Type-related module hierarchy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  GHC.Core.Class+  GHC.Core.Coercion.Axiom+  GHC.Core.TyCon           imports GHC.Core.{Class, Coercion.Axiom}+  GHC.Core.TyCo.Rep        imports GHC.Core.{Class, Coercion.Axiom, TyCon}+  GHC.Core.TyCo.Ppr        imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.FVs        imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.Subst      imports GHC.Core.TyCo.{Rep, FVs, Ppr}+  GHC.Core.TyCo.Tidy       imports GHC.Core.TyCo.{Rep, FVs}+  GHC.Builtin.Types.Prim   imports GHC.Core.TyCo.Rep ( including mkTyConTy )+  GHC.Core.Coercion        imports GHC.Core.Type+-}++-- We expose the relevant stuff from this module via the Type module+module GHC.Core.TyCo.Rep (++        -- * Types+        Type(..),++        TyLit(..),+        KindOrType, Kind,+        RuntimeRepType, LevityType,+        KnotTied,+        PredType, ThetaType, FRRType,     -- Synonyms+        ForAllTyFlag(..), FunTyFlag(..),++        -- * Coercions+        Coercion(..), CoSel(..), FunSel(..),+        UnivCoProvenance(..),+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,+        CoercionN, CoercionR, CoercionP, KindCoercion,+        MCoercion(..), MCoercionR, MCoercionN,++        -- * Functions over types+        mkNakedTyConTy, mkTyVarTy, mkTyVarTys,+        mkTyCoVarTy, mkTyCoVarTys,+        mkFunTy, mkNakedFunTy,+        mkVisFunTy, mkScaledFunTys,+        mkInvisFunTy, mkInvisFunTys,+        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,+        mkForAllTy, mkForAllTys, mkInvisForAllTys,+        mkPiTy, mkPiTys,+        mkVisFunTyMany, mkVisFunTysMany,+        nonDetCmpTyLit, cmpTyLit,++        -- * Functions over coercions+        pickLR,++        -- ** Analyzing types+        TyCoFolder(..), foldTyCo, noView,++        -- * Sizes+        typeSize, typesSize, coercionSize,++        -- * Multiplicities+        Scaled(..), scaledMult, scaledThing, mapScaledType, Mult+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )+import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions+import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint )++   -- Transitively pulls in a LOT of stuff, better to break the loop++-- friends:+import GHC.Types.Var+import GHC.Types.Var.Set( elemVarSet )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom++-- others+import GHC.Builtin.Names++import GHC.Types.Basic ( LeftOrRight(..), pickLR )+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Binary++-- libraries+import qualified Data.Data as Data hiding ( TyCon )+import Data.IORef ( IORef )   -- for CoercionHole+import Control.DeepSeq++{- **********************************************************************+*                                                                       *+                        Type+*                                                                       *+********************************************************************** -}++-- | The key representation of types within the compiler++type KindOrType = Type -- See Note [Arguments to type constructors]++-- | The key type representing kinds in the compiler.+type Kind = Type++-- | Type synonym used for types of kind RuntimeRep.+type RuntimeRepType = Type++-- | Type synonym used for types of kind Levity.+type LevityType = Type++-- A type with a syntactically fixed RuntimeRep, in the sense+-- of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+type FRRType = Type++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Type+  -- See Note [Non-trivial definitional equality]+  = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)++  | AppTy+        Type+        Type            -- ^ Type application to something other than a 'TyCon'. Parameters:+                        --+                        --  1) Function: must /not/ be a 'TyConApp' or 'CastTy',+                        --     must be another 'AppTy', or 'TyVarTy'+                        --     See Note [Respecting definitional equality] \(EQ1) about the+                        --     no 'CastTy' requirement+                        --+                        --  2) Argument type++  | TyConApp+        TyCon+        [KindOrType]    -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+                        -- Invariant: saturated applications of 'FunTyCon' must+                        -- use 'FunTy' and saturated synonyms must use their own+                        -- constructors. However, /unsaturated/ 'FunTyCon's+                        -- do appear as 'TyConApp's.+                        -- Parameters:+                        --+                        -- 1) Type constructor being applied to.+                        --+                        -- 2) Type arguments. Might not have enough type arguments+                        --    here to saturate the constructor.+                        --    Even type synonyms are not necessarily saturated;+                        --    for example unsaturated type synonyms+                        --    can appear as the right hand side of a type synonym.++  | ForAllTy  -- See Note [ForAllTy]+        {-# UNPACK #-} !ForAllTyBinder+           -- ForAllTyBinder: see GHC.Types.Var+           --    Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]+        Type+           -- INVARIANT: If the binder is a coercion variable, it must+           --            be mentioned in the Type.+           --            See Note [Unused coercion variable in ForAllTy]+           -- See Note [Why ForAllTy can quantify over a coercion variable]++  | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case+                -- See Note [Function types]+     { ft_af   :: FunTyFlag    -- Is this (->/FUN) or (=>) or (==>)?+                                 -- This info is fully specified by the kinds in+                                 --      ft_arg and ft_res+                                 -- Note [FunTyFlag] in GHC.Types.Var++     , ft_mult :: Mult           -- Multiplicity; always Many for (=>) and (==>)+     , ft_arg  :: Type           -- Argument type+     , ft_res  :: Type }         -- Result type++  | LitTy TyLit     -- ^ Type literals are similar to type constructors.++  | CastTy+        Type+        KindCoercion  -- ^ A kind cast. The coercion is always nominal.+                      -- INVARIANT: The cast is never reflexive \(EQ2)+                      -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3)+                      -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4)+                      -- See Note [Respecting definitional equality]++  | CoercionTy+        Coercion    -- ^ Injection of a Coercion into a type+                    -- This should only ever be used in the RHS of an AppTy,+                    -- in the list of a TyConApp, when applying a promoted+                    -- GADT data constructor++  deriving Data.Data++instance Outputable Type where+  ppr = pprType++-- NOTE:  Other parts of the code assume that type literals do not contain+-- types or type variables.+data TyLit+  = NumTyLit Integer+  | StrTyLit FastString+  | CharTyLit Char+  deriving (Eq, Data.Data)++-- Non-determinism arises due to uniqCompareFS+nonDetCmpTyLit :: TyLit -> TyLit -> Ordering+nonDetCmpTyLit = cmpTyLitWith NonDetFastString++-- Slower than nonDetCmpTyLit but deterministic+cmpTyLit :: TyLit -> TyLit -> Ordering+cmpTyLit = cmpTyLitWith LexicalFastString++{-# INLINE cmpTyLitWith #-}+cmpTyLitWith :: Ord r => (FastString -> r) -> TyLit -> TyLit -> Ordering+cmpTyLitWith _ (NumTyLit  x) (NumTyLit  y) = compare x y+cmpTyLitWith w (StrTyLit  x) (StrTyLit  y) = compare (w x) (w y)+cmpTyLitWith _ (CharTyLit x) (CharTyLit y) = compare x y+cmpTyLitWith _ a b = compare (tag a) (tag b)+  where+    tag :: TyLit -> Int+    tag NumTyLit{}  = 0+    tag StrTyLit{}  = 1+    tag CharTyLit{} = 2++instance Outputable TyLit where+   ppr = pprTyLit++{- Note [Function types]+~~~~~~~~~~~~~~~~~~~~~~~~+FunTy is the constructor for a function type.  Here are the details:++* The primitive function type constructor FUN has kind+     FUN :: forall (m :: Multiplicity) ->+            forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}.+            TYPE r1 ->+            TYPE r2 ->+            Type+  mkTyConApp ensures that we convert a saturated application+    TyConApp FUN [m,r1,r2,t1,t2] into FunTy FTF_T_T m t1 t2+  dropping the 'r1' and 'r2' arguments; they are easily recovered+  from 't1' and 't2'. The FunTyFlag is always FTF_T_T, because+  we build constraint arrows (=>) with e.g. mkPhiTy and friends,+  never `mkTyConApp funTyCon args`.++* For the time being its RuntimeRep quantifiers are left+  inferred. This is to allow for it to evolve.++* Because the RuntimeRep args came first historically (that is,+  the arrow type constructor gained these arguments before gaining+  the Multiplicity argument), we wanted to be able to say+    type (->) = FUN Many+  which we do in library module GHC.Types. This means that the+  Multiplicity argument must precede the RuntimeRep arguments --+  and it means changing the name of the primitive constructor from+  (->) to FUN.++* The multiplicity argument is dependent, because Typeable does not+  support a type such as `Multiplicity -> forall {r1 r2 :: RuntimeRep}. ...`.+  There is a plan to change the argument order and make the+  multiplicity argument nondependent in #20164.++* Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var+  See Note [Types for coercions, predicates, and evidence] in+  GHC.Core.Predicate.  This visibility info makes no difference in Core;+  it matter only when we regard the type as a Haskell source type.++Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the typing rules for ForAllTy:++tyvar : Type+inner : TYPE r+tyvar does not occur in r+------------------------------------+ForAllTy (Bndr tyvar vis) inner : TYPE r++inner : TYPE r+------------------------------------+ForAllTy (Bndr covar vis) inner : Type++Note that the kind of the result depends on whether the binder is a+tyvar or a covar. The kind of a forall-over-tyvar is the same as+the kind of the inner type. This is because quantification over types+is erased before runtime. By contrast, the kind of a forall-over-covar+is always Type, because a forall-over-covar is compiled into a function+taking a 0-bit-wide erased coercion argument.++Because the tyvar form above includes r in its result, we must+be careful not to let any variables escape -- thus the last premise+of the rule above.++Note [Arguments to type constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of kind polymorphism, in addition to type application we now+have kind instantiation. We reuse the same notations to do so.++For example:++  Just (* -> *) Maybe+  Right * Nat Zero++are represented by:++  TyConApp (PromotedDataCon Just) [* -> *, Maybe]+  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]++Important note: Nat is used as a *kind* and not as a type. This can be+confusing, since type-level Nat and kind-level Nat are identical. We+use the kind of (PromotedDataCon Right) to know if its arguments are+kinds or types.++This kind instantiation only happens in TyConApp currently.++Note [Non-trivial definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is ((IO |> co1) Int |> co2) equal to (IO Int)?+Assume+   co1 :: (Type->Type) ~ (Type->Wombat)+   co2 :: Wombat ~ Type+Well, yes.  The casts are just getting in the way.+See also Note [Respecting definitional equality].++So we do this:++(EQTYPE)+  The `eqType` function, which defines Core's type equality relation,+  - /ignores/ casts, and+  - /ignores/ coercion arguments+  - /provided/ two types have the same kind++This allows us to be a little sloppier in keeping track of coercions, which is a+good thing. It also means that eqType does not depend on eqCoercion, which is+also a good thing.++Why is this sensible? That is, why is something different than α-equivalence+appropriate for the implementation of eqType?++Anything smaller than ~ and homogeneous is an appropriate definition for+equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any+expression of type τ can be transmuted to one of type σ at any point by+casting. The same is true of expressions of type σ. So in some sense, τ and σ+are interchangeable.++But let's be more precise. If we examine the typing rules of FC (say, those in+https://richarde.dev/papers/2015/equalities/equalities.pdf)+there are several places where the same metavariable is used in two different+premises to a rule. (For example, see Ty_App.) There is an implicit equality+check here. What definition of equality should we use? By convention, we use+α-equivalence. Take any rule with one (or more) of these implicit equality+checks. Then there is an admissible rule that uses ~ instead of the implicit+check, adding in casts as appropriate.++The only problem here is that ~ is heterogeneous. To make the kinds work out+in the admissible rule that uses ~, it is necessary to homogenize the+coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η;+we use η |> kind η, which is homogeneous.++The effect of this all is that eqType, the implementation of the implicit+equality check, can use any homogeneous relation that is smaller than ~, as+those rules must also be admissible.++A more drawn out argument around all of this is presented in Section 7.2 of+Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf).++What would go wrong if we insisted on the casts matching? See the beginning of+Section 8 in the unpublished paper above. Theoretically, nothing at all goes+wrong. But in practical terms, getting the coercions right proved to be+nightmarish. And types would explode: during kind-checking, we often produce+reflexive kind coercions. When we try to cast by these, mkCastTy just discards+them. But if we used an eqType that distinguished between Int and Int |> <*>,+then we couldn't discard -- the output of kind-checking would be enormous,+and we would need enormous casts with lots of CoherenceCo's to straighten+them out.++Would anything go wrong if eqType looked through type families? No, not at+all. But that makes eqType rather hard to implement.++Thus, the guideline for eqType is that it should be the largest+easy-to-implement relation that is still smaller than ~ and homogeneous. The+precise choice of relation is somewhat incidental, as long as the smart+constructors and destructors in Type respect whatever relation is chosen.++Another helpful principle with eqType is this:++ (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere.++This principle also tells us that eqType must relate only types with the+same kinds.++Interestingly, it must be the case that the free variables of t1 and t2+might be different, even if t1 `eqType` t2. A simple example of this is+if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment.+Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free+vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement+eqType to be just α-equivalence, this wrinkle around free variables+remains.++Yet not all is lost: we can say that any two equal types share the same+*relevant* free variables. Here, a relevant variable is a shallow+free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs)+that does not appear within a coercion. Note that type variables can+appear within coercions (in, say, a Refl node), but that coercion variables+cannot appear outside a coercion. We do not (yet) have a function to+extract relevant free variables, but it would not be hard to write if+the need arises.++Note [Respecting definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Non-trivial definitional equality] introduces the property (EQ).+How is this upheld?++Any function that pattern matches on all the constructors will have to+consider the possibility of CastTy. Presumably, those functions will handle+CastTy appropriately and we'll be OK.++More dangerous are the splitXXX functions. Let's focus on splitTyConApp.+We don't want it to fail on (T a b c |> co). Happily, if we have+  (T a b c |> co) `eqType` (T d e f)+then co must be reflexive. Why? eqType checks that the kinds are equal, as+well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).+By the kind check, we know that (T a b c |> co) and (T d e f) have the same+kind. So the only way that co could be non-reflexive is for (T a b c) to have+a different kind than (T d e f). But because T's kind is closed (all tycon kinds+are closed), the only way for this to happen is that one of the arguments has+to differ, leading to a contradiction. Thus, co is reflexive.++Accordingly, by eliminating reflexive casts, splitTyConApp need not worry+about outermost casts to uphold (EQ). Eliminating reflexive casts is done+in mkCastTy. This is (EQ2) below.++Unfortunately, that's not the end of the story. Consider comparing+  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)+These two types have the same kind (Type), but the left type is a TyConApp+while the right type is not. To handle this case, we say that the right-hand+type is ill-formed, requiring an AppTy never to have a casted TyConApp+on its left. It is easy enough to pull around the coercions to maintain+this invariant, as done in Type.mkAppTy. In the example above, trying to+form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).+Both the casts there are reflexive and will be dropped. Huzzah.++This idea of pulling coercions to the right works for splitAppTy as well.++However, there is one hiccup: it's possible that a coercion doesn't relate two+Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,+then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't+be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not+`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate+our (EQ) property.++In order to detect reflexive casts reliably, we must make sure not+to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).+This is (EQ3) below.++One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy].+The kind of the body is the same as the kind of the ForAllTy. Accordingly,++  ForAllTy tv (ty |> co)     and     (ForAllTy tv ty) |> co++are `eqType`. But only the first can be split by splitForAllTy. So we forbid+the second form, instead pushing the coercion inside to get the first form.+This is done in mkCastTy.++In sum, in order to uphold (EQ), we need the following invariants:++  (EQ1) No decomposable CastTy to the left of an AppTy,+        where a "decomposable cast" is one that relates+        either a FunTy to a FunTy, or a ForAllTy to a ForAllTy.+  (EQ2) No reflexive casts in CastTy.+  (EQ3) No nested CastTys.+  (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).+        See Note [Weird typing rule for ForAllTy]++These invariants are all documented above, in the declaration for Type.++Note [Equality on FunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+A (FunTy vis mult arg res) is just an abbreviation for a+  TyConApp funTyCon [mult, arg_rep, res_rep, arg, res]+where+  arg :: TYPE arg_rep+  res :: TYPE res_rep+Note that the vis field of a FunTy appears nowhere in the+equivalent TyConApp. In Core, this is OK, because we no longer+care about the visibility of the argument in a FunTy+(the vis distinguishes between arg -> res and arg => res).+In the type-checker, we are careful not to decompose FunTys+with an invisible argument. See also Note [Decomposing fat arrow c=>t]+in GHC.Core.Type.++In order to compare FunTys while respecting how they could+expand into TyConApps, we must check+the kinds of the arg and the res.++Note [ForAllTy]+~~~~~~~~~~~~~~~+A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar.+See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter.++(FT1) Invariant: See Note [Weird typing rule for ForAllTy]++(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty),+      if tcv is a CoVar, then vis = coreTyLamForAllTyFlag.+   Visibility is not important for coercion abstractions,+   because they are not user-visible.++(FT3) Invariant: see Note [Unused coercion variable in ForAllTy]++Note [Why ForAllTy can quantify over a coercion variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely)+a CoVar. We support quantifying over a CoVar here in order to support+a homogeneous (~#) relation (someday -- not yet implemented). Here is+the example:++  type (:~~:) :: forall k1 k2. k1 -> k2 -> Type+  data a :~~: b where+    HRefl :: a :~~: a++Assuming homogeneous equality (that is, with+  (~#) :: forall k. k -> k -> TYPE (TupleRep '[])+) after rejigging to make equalities explicit, we get a constructor that+looks like++  HRefl :: forall k1 k2 (a :: k1) (b :: k2).+           forall (cv :: k1 ~# k2). (a |> cv) ~# b+        => (:~~:) k1 k2 a b++Note that we must cast `a` by a cv bound in the same type in order to+make this work out.++See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2+which gives a general road map that covers this space.  Having this feature in+Core does *not* mean we have it in source Haskell.  See #15710 about that.++Note [Unused coercion variable in ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  \(co:t1 ~# t2). e++What type should we give to the above expression?+  (1) forall (co:t1 ~# t2) -> t+  (2) (t1 ~# t2) -> t++If co is used in t, (1) should be the right choice.+if co is not used in t, we would like to have (1) and (2) equivalent.++However, we want to keep eqType simple and don't want eqType (1) (2) to return+True in any case.++We decide to always construct (2) if co is not used in t.++Thus in mkLamType, we check whether the variable is a coercion+variable (of type (t1 ~# t2), and whether it is un-used in the+body. If so, it returns a FunTy instead of a ForAllTy.++There are cases we want to skip the check. For example, the check is+unnecessary when it is known from the context that the input variable+is a type variable.  In those cases, we use mkForAllTy.++Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the (truncated) typing rule for the dependent ForAllTy:++  inner : TYPE r+  tyvar is not free in r+  ----------------------------------------+  ForAllTy (Bndr tyvar vis) inner : TYPE r++Note that the kind of `inner` is the kind of the overall ForAllTy. This is+necessary because every ForAllTy over a type variable is erased at runtime.+Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in+the kind) must be the same as the representation of the body. We must check+for skolem-escape, though. The skolem-escape would prevent a definition like++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a++because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real+type of undefined is++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a++and that HasCallStack constraint neatly sidesteps the potential skolem-escape+problem.++If the bound variable is a coercion variable:++  inner : TYPE r+  covar is free in inner+  ------------------------------------+  ForAllTy (Bndr covar vis) inner : Type++Here, the kind of the ForAllTy is just Type, because coercion abstractions+are *not* erased. The "covar is free in inner" premise is solely to maintain+the representation invariant documented in+Note [Unused coercion variable in ForAllTy]. Though there is surface similarity+between this free-var check and the one in the tyvar rule, these two restrictions+are truly unrelated.++-}++-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See+-- Note [Type checking recursive type and class declarations] in+-- "GHC.Tc.TyCl"+type KnotTied ty = ty++{- **********************************************************************+*                                                                       *+                        PredType+*                                                                       *+********************************************************************** -}+++-- | A type of the form @p@ of constraint kind represents a value whose type is+-- the Haskell predicate @p@, where a predicate is what occurs before+-- the @=>@ in a Haskell type.+--+-- We use 'PredType' as documentation to mark those types that we guarantee to+-- have this kind.+--+-- It can be expanded into its representation, but:+--+-- * The type checker must treat it as opaque+--+-- * The rest of the compiler treats it as transparent+--+-- Consider these examples:+--+-- > f :: (Eq a) => a -> Int+-- > g :: (?x :: Int -> Int) => a -> Int+-- > h :: (r\l) => {r} => {l::Int | r}+--+-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"+type PredType = Type++-- | A collection of 'PredType's+type ThetaType = [PredType]++{-+(We don't support TREX records yet, but the setup is designed+to expand to allow them.)++A Haskell qualified type, such as that for f,g,h above, is+represented using+        * a FunTy for the double arrow+        * with a type of kind Constraint as the function argument++The predicate really does turn into a real extra argument to the+function.  If the argument has type (p :: Constraint) then the predicate p is+represented by evidence of type p.+++%************************************************************************+%*                                                                      *+            Simple constructors+%*                                                                      *+%************************************************************************++These functions are here so that they can be used by GHC.Builtin.Types.Prim,+which in turn is imported by Type+-}++mkTyVarTy  :: TyVar   -> Type+mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $+              TyVarTy v++mkTyVarTys :: [TyVar] -> [Type]+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy++mkTyCoVarTy :: TyCoVar -> Type+mkTyCoVarTy v+  | isTyVar v+  = TyVarTy v+  | otherwise+  = CoercionTy (CoVarCo v)++mkTyCoVarTys :: [TyCoVar] -> [Type]+mkTyCoVarTys = map mkTyCoVarTy++infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`++mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind+-- See Note [Naked FunTy] in GHC.Builtin.Types+-- Always Many multiplicity; kinds have no linearity+mkNakedFunTy af arg res+ =  FunTy { ft_af   = af, ft_mult = manyDataConTy+          , ft_arg  = arg, ft_res  = res }++mkFunTy :: HasDebugCallStack => FunTyFlag -> Mult -> Type -> Type -> Type+mkFunTy af mult arg res+  = assertPpr (af == chooseFunTyFlag arg res) (vcat+      [ text "af" <+> ppr af+      , text "chooseAAF" <+> ppr (chooseFunTyFlag arg res)+      , text "arg" <+> ppr arg <+> dcolon <+> ppr (typeKind arg)+      , text "res" <+> ppr res <+> dcolon <+> ppr (typeKind res) ]) $+    FunTy { ft_af   = af+          , ft_mult = mult+          , ft_arg  = arg+          , ft_res  = res }++mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type+mkInvisFunTy arg res+  = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res++mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type+mkInvisFunTys args res+  = foldr (mkFunTy af manyDataConTy) res args+  where+    af = invisArg (typeTypeOrConstraint res)++mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type+-- Always TypeLike, user-specified multiplicity.+mkVisFunTy = mkFunTy visArgTypeLike++-- | Make nested arrow types+-- | Special, common, case: Arrow type with mult Many+mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type+-- Always TypeLike, multiplicity Many+mkVisFunTyMany = mkVisFunTy manyDataConTy++mkVisFunTysMany :: [Type] -> Type -> Type+-- Always TypeLike, multiplicity Many+mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys++---------------+mkScaledFunTy :: HasDebugCallStack => FunTyFlag -> Scaled Type -> Type -> Type+mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res++mkScaledFunTys :: HasDebugCallStack => [Scaled Type] -> Type -> Type+-- All visible args+-- Result type can be TypeLike or ConstraintLike+-- Example of the latter: dataConWrapperType for the data con of a class+mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys+  where+    af = visArg (typeTypeOrConstraint ty)++---------------+-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder+-- See Note [Unused coercion variable in ForAllTy]+mkForAllTy :: ForAllTyBinder -> Type -> Type+mkForAllTy bndr body+  = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $+    ForAllTy bndr body+  where+    -- Check ForAllTy invariants+    good_bndr (Bndr cv vis)+      | isCoVar cv = vis == coreTyLamForAllTyFlag+                     -- See (FT2) in Note [ForAllTy]+                  && (cv `elemVarSet` tyCoVarsOfType body)+                     -- See (FT3) in Note [ForAllTy]+      | otherwise = True++-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right+mkForAllTys :: [ForAllTyBinder] -> Type -> Type+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars++-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right+mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type+mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars)++mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type+mkPiTy (Anon ty1 af) ty2  = mkScaledFunTy af ty1 ty2+mkPiTy (Named bndr) ty    = mkForAllTy bndr ty++mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type+mkPiTys tbs ty = foldr mkPiTy ty tbs++-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you+-- should rather use 'GHC.Core.Type.mkTyConTy', which picks the shared+-- nullary TyConApp from inside the TyCon (via tyConNullaryTy.  But+-- we have to build the TyConApp tc [] in that TyCon field; that's+-- what 'mkNakedTyConTy' is for.+mkNakedTyConTy :: TyCon -> Type+mkNakedTyConTy tycon = TyConApp tycon []++tcMkVisFunTy :: Mult -> Type -> Type -> Type+-- Always TypeLike result, user-specified multiplicity.+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkVisFunTy mult arg res+  = FunTy { ft_af = visArgTypeLike, ft_mult = mult+          , ft_arg = arg, ft_res = res }++tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type+-- Always invisible (constraint) argument, result specified by res_torc+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkInvisFunTy res_torc arg res+  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy+          , ft_arg = arg, ft_res = res }++tcMkScaledFunTys :: [Scaled Type] -> Type -> Type+-- All visible args+-- Result type must be TypeLike+-- No mkFunTy assert checking; result kind may not be zonked+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys++tcMkScaledFunTy :: Scaled Type -> Type -> Type+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res++{-+%************************************************************************+%*                                                                      *+            Coercions+%*                                                                      *+%************************************************************************+-}++-- | A 'Coercion' is concrete evidence of the equality/convertibility+-- of two types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Coercion+  -- Each constructor has a "role signature", indicating the way roles are+  -- propagated through coercions.+  --    -  P, N, and R stand for coercions of the given role+  --    -  e stands for a coercion of a specific unknown role+  --           (think "role polymorphism")+  --    -  "e" stands for an explicit role parameter indicating role e.+  --    -   _ stands for a parameter that is not a Role or Coercion.++  -- These ones mirror the shape of types+  = -- Refl :: _ -> N+    -- A special case reflexivity for a very common case: Nominal reflexivity+    -- If you need Representational, use (GRefl Representational ty MRefl)+    --                               not (SubCo (Refl ty))+    Refl Type  -- See Note [Refl invariant]++  -- GRefl :: "e" -> _ -> Maybe N -> e+  -- See Note [Generalized reflexive coercion]+  | GRefl Role Type MCoercionN  -- See Note [Refl invariant]+          -- Use (Refl ty), not (GRefl Nominal ty MRefl)+          -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))++  -- These ones simply lift the correspondingly-named+  -- Type constructors into Coercions++  -- TyConAppCo :: "e" -> _ -> ?? -> e+  -- See Note [TyConAppCo roles]+  | TyConAppCo Role TyCon [Coercion]    -- lift TyConApp+               -- The TyCon is never a synonym;+               -- we expand synonyms eagerly+               -- But it can be a type function+               -- TyCon is never a saturated (->); use FunCo instead++  | AppCo Coercion CoercionN             -- lift AppTy+          -- AppCo :: e -> N -> e++  -- See Note [ForAllCo]+  | ForAllCo+      { fco_tcv  :: TyCoVar+      , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind+      , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind+                                  -- See (FC7) of Note [ForAllCo]+      , fco_kind :: KindCoercion+      , fco_body :: Coercion }+         -- ForAllCo :: _ -> N -> e -> e++  | FunCo  -- FunCo :: "e" -> N/P -> e -> e -> e+           -- See Note [FunCo] for fco_afl, fco_afr+        { fco_role         :: Role+        , fco_afl          :: FunTyFlag   -- Arrow for coercionLKind+        , fco_afr          :: FunTyFlag   -- Arrow for coercionRKind+        , fco_mult         :: CoercionN+        , fco_arg, fco_res :: Coercion }+       -- (if the role "e" is Phantom, the first coercion is, too)+       -- the first coercion is for the multiplicity++  -- These are special+  | CoVarCo CoVar      -- :: _ -> (N or R)+                       -- result role depends on the tycon of the variable's type++  | AxiomCo CoAxiomRule [Coercion]+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom. If there are+     -- any left over, we use AppCo.+     -- See [Coercion axioms applied to coercions]+     -- The roles of the argument coercions are determined+     -- by the cab_roles field of the relevant branch of the CoAxiom++  | UnivCo  -- See Note [UnivCo]+            -- Of kind (lty ~role rty)+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends+               --   See Note [The importance of tracking UnivCo dependencies]+      }++  | SymCo Coercion             -- :: e -> e+  | TransCo Coercion Coercion  -- :: e -> e -> e++  | SelCo CoSel Coercion  -- See Note [SelCo]++  | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)+    -- :: _ -> N -> N+  | InstCo Coercion CoercionN+    -- :: e -> N -> e+    -- See Note [InstCo roles]++  -- Extract a kind coercion from a (heterogeneous) type coercion+  -- NB: all kind coercions are Nominal+  | KindCo Coercion+     -- :: e -> N++  | SubCo CoercionN                  -- Turns a ~N into a ~R+    -- :: N -> R++  | HoleCo CoercionHole              -- ^ See Note [Coercion holes]+                                     -- Only present during typechecking+  deriving Data.Data++data CoSel  -- See Note [SelCo]+  = SelTyCon Int Role  -- Decomposes (T co1 ... con); zero-indexed+                       -- Invariant: Given: SelCo (SelTyCon i r) co+                       --            we have r == tyConRole (coercionRole co) tc+                       --                and tc1 == tc2+                       --            where T tc1 _ = coercionLKind co+                       --                  T tc2 _ = coercionRKind co+                       -- See Note [SelCo]++  | SelFun FunSel      -- Decomposes (co1 -> co2)++  | SelForAll          -- Decomposes (forall a. co)++  deriving( Eq, Data.Data, Ord )++data FunSel  -- See Note [SelCo]+  = SelMult  -- Multiplicity+  | SelArg   -- Argument of function+  | SelRes   -- Result of function+  deriving( Eq, Data.Data, Ord )++type CoercionN = Coercion       -- always nominal+type CoercionR = Coercion       -- always representational+type CoercionP = Coercion       -- always phantom+type KindCoercion = CoercionN   -- always nominal++instance Outputable Coercion where+  ppr = pprCo++instance Outputable CoSel where+  ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r)+  ppr SelForAll      = text "All"+  ppr (SelFun fs)    = text "Fun" <> parens (ppr fs)++pprOneCharRole :: Role -> SDoc+pprOneCharRole Nominal          = char 'N'+pprOneCharRole Representational = char 'R'+pprOneCharRole Phantom          = char 'P'++instance Outputable FunSel where+  ppr SelMult = text "mult"+  ppr SelArg  = text "arg"+  ppr SelRes  = text "res"++instance NFData FunSel where+  rnf SelMult = ()+  rnf SelArg  = ()+  rnf SelRes  = ()++instance Binary CoSel where+   put_ bh (SelTyCon n r)   = do { putByte bh 0; put_ bh n; put_ bh r }+   put_ bh SelForAll        = putByte bh 1+   put_ bh (SelFun SelMult) = putByte bh 2+   put_ bh (SelFun SelArg)  = putByte bh 3+   put_ bh (SelFun SelRes)  = putByte bh 4++   get bh = do { h <- getByte bh+               ; case h of+                   0 -> do { n <- get bh; r <- get bh; return (SelTyCon n r) }+                   1 -> return SelForAll+                   2 -> return (SelFun SelMult)+                   3 -> return (SelFun SelArg)+                   _ -> return (SelFun SelRes) }++instance NFData CoSel where+  rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` ()+  rnf SelForAll      = ()+  rnf (SelFun fs)    = rnf fs `seq` ()++-- | A semantically more meaningful type to represent what may or may not be a+-- useful 'Coercion'.+data MCoercion+  = MRefl+    -- A trivial Reflexivity coercion+  | MCo Coercion+    -- Other coercions+  deriving Data.Data+type MCoercionR = MCoercion+type MCoercionN = MCoercion++instance Outputable MCoercion where+  ppr MRefl    = text "MRefl"+  ppr (MCo co) = text "MCo" <+> ppr co++{- Note [Refl invariant]+~~~~~~~~~~~~~~~~~~~~~~~~+Invariant 1: Refl lifting+        Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.+    For example+        (Refl T) (Refl a) (Refl b) is normalised (by mkAppCo) to  (Refl (T a b)).++    You might think that a consequences is:+         Every identity coercion has Refl at the root++    But that's not quite true because of coercion variables.  Consider+         g         where g :: Int~Int+         Left h    where h :: Maybe Int ~ Maybe Int+    etc.  So the consequence is only true of coercions that+    have no coercion variables.++Invariant 2: TyConAppCo+   An application of (Refl T) to some coercions, at least one of which is+   NOT the identity, is normalised to TyConAppCo.  (They may not be+   fully saturated however.)  TyConAppCo coercions (like all coercions+   other than Refl) are NEVER the identity.++Note [Generalized reflexive coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GRefl is a generalized reflexive coercion (see #15192). It wraps a kind+coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing+rules for GRefl:++  ty : k1+  ------------------------------------+  GRefl r ty MRefl: ty ~r ty++  ty : k1       co :: k1 ~ k2+  ------------------------------------+  GRefl r ty (MCo co) : ty ~r ty |> co++Consider we have++   g1 :: s ~r t+   s  :: k1+   g2 :: k1 ~ k2++and we want to construct a coercions co which has type++   (s |> g2) ~r t++We can define++   co = Sym (GRefl r s g2) ; g1++It is easy to see that++   Refl == GRefl Nominal ty MRefl :: ty ~n ty++A nominal reflexive coercion is quite common, so we keep the special form Refl to+save allocation.++Note [SelCo]+~~~~~~~~~~~~+The Coercion form SelCo allows us to decompose a structural coercion, one+between ForallTys, or TyConApps, or FunTys.++There are three forms, split by the CoSel field inside the SelCo:+SelTyCon, SelForAll, and SelFun.  The typing rules below are directly+checked by the SelCo case of GHC.Core.Lint.lintCoercion.++* SelTyCon:++      co : (T s1..sn) ~r (T t1..tn)+      T is not a saturated FunTyCon (use SelFun for that)+      T is injective at role r+      ri = tyConRole tc r i+      i < n    (i is zero-indexed)+      ----------------------------------+      SelCo (SelTyCon i ri) co : si ~ri ti++  "Injective at role r": see Note [SelCo and newtypes]+  "Not saturated FunTyCon": see SelFun below++   See Note [SelCo Cached Roles]++* SelForAll:+      co : forall (a:k1).t1 ~r0 forall (a:k2).t2+      ----------------------------------+      SelCo SelForAll co : k1 ~N k2++  NB: SelForAll always gives a Nominal coercion.++* The SelFun form, for functions, has three sub-forms for the three+  components of the function type (multiplicity, argument, result).++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelMult+      ----------------------------------+      SelCo (SelFun SelMult) co : m1 ~r m2++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelArg+      ----------------------------------+      SelCo (SelFun SelArg) co : s1 ~r s2++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelRes+      ----------------------------------+      SelCo (SelFun SelRes) co : t1 ~r t2++Note [FunCo]+~~~~~~~~~~~~+Just as FunTy has a ft_af :: FunTyFlag field, FunCo (which connects+two function types) has two FunTyFlag fields:+     funco_afl, funco_afr :: FunTyFlag+In all cases, the FunTyFlag is recoverable from the kinds of the argument+and result types/coercions; but experiments show that it's better to+cache it.++Why does FunCo need /two/ flags? If we have a single method class,+implemented as a newtype+   class C a where { op :: [a] -> a }+then we can have a coercion+   co :: C Int ~R ([Int]->Int)+So now we can define+   FunCo co <Bool> : (C Int => Bool) ~R (([Int]->Int) -> Bool)+Notice that the left and right arrows are different!  Hence two flags,+one for coercionLKind and one for coercionRKind.++Note [Coercion axioms applied to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The reason coercion axioms can be applied to coercions and not just+types is to allow for better optimization.  There are some cases where+we need to be able to "push transitivity inside" an axiom in order to+expose further opportunities for optimization.++For example, suppose we have++  C a : t[a] ~ F a+  g   : b ~ c++and we want to optimize++  sym (C b) ; t[g] ; C c++which has the kind++  F b ~ F c++(stopping through t[b] and t[c] along the way).++We'd like to optimize this to just F g -- but how?  The key is+that we need to allow axioms to be instantiated by *coercions*,+not just by types.  Then we can (in certain cases) push+transitivity inside the axiom instantiations, and then react+opposite-polarity instantiations of the same axiom.  In this+case, e.g., we match t[g] against the LHS of (C c)'s kind, to+obtain the substitution  a |-> g  (note this operation is sort+of the dual of lifting!) and hence end up with++  C g : t[b] ~ F c++which indeed has the same kind as  t[g] ; C c.++Now we have++  sym (C b) ; C g++which can be optimized to F g.++Note [Required foralls in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty).+It has type+   forall a. e_ty+Note the Specified visibility of (forall a. e_ty); the Core type just isn't able+to express more than one visiblity, and we pick `Specified`.  See `exprType` and+`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreTyLamForAllTyFlag`.++So how can we ever get a term of type (forall a -> e_ty)?  Answer: /only/ via a+cast built with ForAllCo.  See `GHC.Core.Coercion.mkForAllVisCos`,+`GHC.Tc.Types.Evidence.mkWpForAllCast` and `GHC.Core.Make.mkCoreTyLams`.+This does not seem very satisfying, but it does the job.++An alternative would be to put a visibility flag into `Lam` (a huge change),+or into a `TyVar` (a more plausible change), but we leave that for the future.++See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.++Note [ForAllCo]+~~~~~~~~~~~~~~~+See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.++Constructing coercions between forall-types can be a bit tricky,+because the kinds of the bound tyvars can be different.++The typing rule is:++  G |- kind_co : k1 ~N k2+  tv1 \not\in fv(typeKind(t1),typeKind(t2))  -- Skolem escape+  G, tv1:k1 |- co : t1 ~r t2+  if r=N, then vis1=vis2+  ------------------------------------+  G |- ForAllCo (tv1:k1) vis1 vis2 kind_co co+         : forall (tv1:k1) <vis1>. t1+              ~r+           forall (tv1:k2) <vis2>. (t2[tv1 |-> (tv1:k2) |> sym kind_co])++Several things to note here++(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this+  field should be a Name, as its kind is redundant. Thinking of the field as a+  Name is helpful in understanding what a ForAllCo means.  The kind of TyCoVar+  always matches the left-hand kind of the coercion.++  * The idea is that kind_co gives the two kinds of the tyvar. See how, in the+    conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.++  * Of course, a type variable can't have different kinds at the same time.+    So, in `co` itself we use (tv1 : k1); hence the premise+          tv1:k1 |- co : t1 ~r t2++  * The last wrinkle is that we need to fix the kinds in the conclusion. In+    t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+     the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+     (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+    mentions the same name with different kinds, but it *is* well-kinded, noting+     that `(tv1:k2) |> sym kind_co` has kind k1.++  We could instead store just a Name in the ForAllCo, and it might even be+  more efficient to do so. But we can't add Names to, e.g., VarSets, and+  there generally is just an impedance mismatch in a bunch of places. So we+  use tv1. When we need tv2, we can use setTyVarKind.++(FC2) Note that the kind coercion must be Nominal; and that the role `r` of+  the final coercion is the same as that of the body coercion.++(FC3) A ForAllCo allows casting between visibilities.  For example:+         ForAllCo a Required Specified (SubCo (Refl ty))+           : (forall a -> ty) ~R (forall a. ty)+  But you can only cast between visiblities at Representational role;+  Hence the premise+      if r=N, then vis1=vis2+  in the typing rule.  See also Note [ForAllTy and type equality] in+  GHC.Core.TyCo.Compare.++(FC4) See Note [Required foralls in Core].++(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that+  `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy]+  in GHC.Core.TyCo.Rep for the motivation.  If it does not appear free,+  use FunTy.++  However we do /not/ impose the same restriction on ForAllCo in /coercions/.+  Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform+  the check and construct a FunTy when necessary.  Why?+    * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not+       make a difference.+    * Even if cv occurs in body_co, it is possible that cv does not occur in the kind+      of body_co. Therefore the check in coercionKind is inevitable.++(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`,+  we insist that `cv` appears only in positions that are erased. In fact we use+  a conservative approximation of this: we require that+       (almostDevoidCoVarOfCo cv fco_body)+  holds.  This function checks that `cv` appers only within the type in a Refl+  node and under a GRefl node (including in the Coercion stored in a GRefl).+  It's possible other places are OK, too, but this is a safe approximation.++  Why all this fuss?  See Section 5.8.5.2 of Richard's thesis. The idea is that+  we cannot prove that the type system is consistent with unrestricted use of this+  cv; the consistency proof uses an untyped rewrite relation that works over types+  with all coercions and casts removed. So, we can allow the cv to appear only in+  positions that are erased.++  Sadly, with heterogeneous equality, this restriction might be able to be+  violated; Richard's thesis is unable to prove that it isn't. Specifically, the+  liftCoSubst function might create an invalid coercion. Because a violation of+  the restriction might lead to a program that "goes wrong", it is checked all+  the time, even in a production compiler and without -dcore-lint. We *have*+  proved that the problem does not occur with homogeneous equality, so this+  check can be dropped once ~# is made to be homogeneous.++(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then+         fco_visL = fco_visR = coreTyLamForAllTyFlag+  c.f. (FT2) in Note [ForAllTy]++Note [Predicate coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: a~b+How can we coerce between types+   ([c]~a) => [a] -> c+and+   ([c]~b) => [b] -> c+where the equality predicate *itself* differs?++Answer: we simply treat (~) as an ordinary type constructor, so these+types really look like++   ((~) [c] a) -> [a] -> c+   ((~) [c] b) -> [b] -> c++So the coercion between the two is obviously++   ((~) [c] g) -> [g] -> c++Another way to see this to say that we simply collapse predicates to+their representation type (see Type.coreView and Type.predTypeRep).++This collapse is done by mkPredCo; there is no PredCo constructor+in Coercion.  This is important because we need Nth to work on+predicates too:+    SelCo (SelTyCon 1) ((~) [c] g) = g+See Simplify.simplCoercionF, which generates such selections.++Note [Roles]+~~~~~~~~~~~~+Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated+in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see+https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation++Here is one way to phrase the problem:++Given:+newtype Age = MkAge Int+type family F x+type instance F Age = Bool+type instance F Int = Char++This compiles down to:+axAge :: Age ~ Int+axF1 :: F Age ~ Bool+axF2 :: F Int ~ Char++Then, we can make:+(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char++Yikes!++The solution is _roles_, as articulated in "Generative Type Abstraction and+Type-level Computation" (POPL 2010), available at+http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf++The specification for roles has evolved somewhat since that paper. For the+current full details, see the documentation in docs/core-spec. Here are some+highlights.++We label every equality with a notion of type equivalence, of which there are+three options: Nominal, Representational, and Phantom. A ground type is+nominally equivalent only with itself. A newtype (which is considered a ground+type in Haskell) is representationally equivalent to its representation.+Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"+to denote the equivalences.++The axioms above would be:+axAge :: Age ~R Int+axF1 :: F Age ~N Bool+axF2 :: F Age ~N Char++Then, because transitivity applies only to coercions proving the same notion+of equivalence, the above construction is impossible.++However, there is still an escape hatch: we know that any two types that are+nominally equivalent are representationally equivalent as well. This is what+the form SubCo proves -- it "demotes" a nominal equivalence into a+representational equivalence. So, it would seem the following is possible:++sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char   -- WRONG++What saves us here is that the arguments to a type function F, lifted into a+coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and+we are safe.++Roles are attached to parameters to TyCons. When lifting a TyCon into a+coercion (through TyConAppCo), we need to ensure that the arguments to the+TyCon respect their roles. For example:++data T a b = MkT a (F b)++If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know+that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because+the type function F branches on b's *name*, not representation. So, we say+that 'a' has role Representational and 'b' has role Nominal. The third role,+Phantom, is for parameters not used in the type's definition. Given the+following definition++data Q a = MkQ Int++the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we+can construct the coercion Bool ~P Char (using UnivCo).++See the paper cited above for more examples and information.++Note [TyConAppCo roles]+~~~~~~~~~~~~~~~~~~~~~~~+The TyConAppCo constructor has a role parameter, indicating the role at+which the coercion proves equality. The choice of this parameter affects+the required roles of the arguments of the TyConAppCo. To help explain+it, assume the following definition:++  type instance F Int = Bool   -- Axiom axF : F Int ~N Bool+  newtype Age = MkAge Int      -- Axiom axAge : Age ~R Int+  data Foo a = MkFoo a         -- Role on Foo's parameter is Representational++TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool+  For (TyConAppCo Nominal) all arguments must have role Nominal. Why?+  So that Foo Age ~N Foo Int does *not* hold.++TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool+TyConAppCo Representational Foo axAge       : Foo Age     ~R Foo Int+  For (TyConAppCo Representational), all arguments must have the roles+  corresponding to the result of tyConRoles on the TyCon. This is the+  whole point of having roles on the TyCon to begin with. So, we can+  have Foo Age ~R Foo Int, if Foo's parameter has role R.++  If a Representational TyConAppCo is over-saturated (which is otherwise fine),+  the spill-over arguments must all be at Nominal. This corresponds to the+  behavior for AppCo.++TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool+  All arguments must have role Phantom. This one isn't strictly+  necessary for soundness, but this choice removes ambiguity.++The rules here dictate the roles of the parameters to mkTyConAppCo+(should be checked by Lint).++Note [SelCo and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype N a = MkN Int+  type role N representational++This yields axiom++  NTCo:N :: forall a. N a ~R Int++We can then build++  co :: forall a b. N a ~R N b+  co = NTCo:N a ; sym (NTCo:N b)++for any `a` and `b`. Because of the role annotation on N, if we use+SelCo, we'll get out a representational coercion. That is:++  SelCo (SelTyCon 0 r) co :: forall a b. a ~r b++Yikes! Clearly, this is terrible. The solution is simple: forbid+SelCo to be used on newtypes if the internal coercion is representational.+More specifically, we use isInjectiveTyCon to determine whether+T is injective at role r:+* Newtypes and datatypes are both injective at Nominal role, but+* Newtypes are not injective at Representational role+See the SelCo equation for GHC.Core.Lint.lintCoercion.++This is not just some corner case discovered by a segfault somewhere;+it was discovered in the proof of soundness of roles and described+in the "Safe Coercions" paper (ICFP '14).++Note [SelCo Cached Roles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Why do we cache the role of SelCo in the SelCo constructor?+Because computing role(Nth i co) involves figuring out that++  co :: T tys1 ~ T tys2++using coercionKind, and finding (coercionRole co), and then looking+at the tyConRoles of T. Avoiding bad asymptotic behaviour here means+we have to compute the kind and role of a coercion simultaneously,+which makes the code complicated and inefficient.++This only happens for SelCo. Caching the role solves the problem, and+allows coercionKind and coercionRole to be simple.++See #11735++Note [InstCo roles]+~~~~~~~~~~~~~~~~~~~+Here is (essentially) the typing rule for InstCo:++g :: (forall a. t1) ~r (forall a. t2)+w :: s1 ~N s2+------------------------------- InstCo+InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2])++Note that the Coercion w *must* be nominal. This is necessary+because the variable a might be used in a "nominal position"+(that is, a place where role inference would require a nominal+role) in t1 or t2. If we allowed w to be representational, we+could get bogus equalities.++A more nuanced treatment might be able to relax this condition+somewhat, by checking if t1 and/or t2 use their bound variables+in nominal ways. If not, having w be representational is OK.+++%************************************************************************+%*                                                                      *+                UnivCo+%*                                                                      *+%************************************************************************++Note [UnivCo]+~~~~~~~~~~~~~+A UnivCo is a coercion whose proof does not directly express its role+and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof).++The different kinds of UnivCo are described by UnivCoProvenance.  Really each+is entirely separate, but they all share the need to represent these fields:++  UnivCo+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends++Here,+ * uco_role, uco_lty, uco_rty express the type of the coercion+ * uco_prov says where it came from+ * uco_deps specifies the coercions on which this proof (which is not+   explicity given) depends. See+   Note [The importance of tracking UnivCo dependencies]+-}++-- | For simplicity, we have just one UnivCo that represents a coercion from+-- some type to some other type, with (in general) no restrictions on the+-- type. The UnivCoProvenance specifies more exactly what the coercion really+-- is and why a program should (or shouldn't!) trust the coercion.+-- It is reasonable to consider each constructor of 'UnivCoProvenance'+-- as a totally independent coercion form; their only commonality is+-- that they don't tell you what types they coercion between. (That info+-- is in the 'UnivCo' constructor of 'Coercion'.+data UnivCoProvenance+  = PhantomProv    -- ^ See Note [Phantom coercions]. Only in Phantom+                   -- roled coercions++  | ProofIrrelProv -- ^ From the fact that any two coercions are+                   --   considered equivalent. See Note [ProofIrrelProv].+                   -- Can be used in Nominal or Representational coercions++  | PluginProv String+      -- ^ From a plugin, which asserts that this coercion is sound.+      --   The string and the variable set are for the use by the plugin.++  deriving (Eq, Ord, Data.Data)+  -- Why Ord?  See Note [Ord instance of IfaceType] in GHC.Iface.Type++instance Outputable UnivCoProvenance where+  ppr PhantomProv          = text "(phantom)"+  ppr (ProofIrrelProv {})  = text "(proof irrel)"+  ppr (PluginProv str)     = parens (text "plugin" <+> brackets (text str))++instance NFData UnivCoProvenance where+  rnf p = p `seq` ()++instance Binary UnivCoProvenance where+  put_ bh PhantomProv    = putByte bh 1+  put_ bh ProofIrrelProv = putByte bh 2+  put_ bh (PluginProv a) = putByte bh 3 >> put_ bh a+  get bh = do+      tag <- getByte bh+      case tag of+           1 -> return PhantomProv+           2 -> return ProofIrrelProv+           3 -> do a <- get bh+                   return $ PluginProv a+           _ -> panic ("get UnivCoProvenance " ++ show tag)+++{- Note [Phantom coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     data T a = T1 | T2+Then we have+     T s ~R T t+for any old s,t. The witness for this is (TyConAppCo T Rep co),+where (co :: s ~P t) is a phantom coercion built with PhantomProv.+The role of the UnivCo is always Phantom.  The Coercion stored is the+(nominal) kind coercion between the types+   kind(s) ~N kind (t)++Note [ProofIrrelProv]+~~~~~~~~~~~~~~~~~~~~~+A ProofIrrelProv is a coercion between coercions. For example:++  data G a where+    MkG :: G Bool++In core, we get++  G :: * -> *+  MkG :: forall (a :: *). (a ~# Bool) -> G a++Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want+a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be++  TyConAppCo Nominal MkG [co3, co4]+  where+    co3 :: co1 ~ co2+    co4 :: a1 ~ a2++Note that+  co1 :: a1 ~ Bool+  co2 :: a2 ~ Bool++Here,+  co3 = UnivCo ProofIrrelProv Nominal (CoercionTy co1) (CoercionTy co2) [co5]+  where+    co5 :: (a1 ~# Bool) ~# (a2 ~# Bool)+    co5 = TyConAppCo Nominal (~#) [<Consraint#>, <Constraint#>, co4, <Bool>]+++Note [The importance of tracking UnivCo dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is vital that `UnivCo` (a coercion that lacks a proper proof)+tracks the coercions on which it depends. To see why, consider this program:++    type S :: Nat -> Nat++    data T (a::Nat) where+      T1 :: T 0+      T2 :: ...++    f :: T a -> S (a+1) -> S 1+    f = /\a (x:T a) (y:a).+        case x of+          T1 (gco : a ~# 0) -> y |> wco++For this to typecheck we need `wco :: S (a+1) ~# S 1`, given that `gco : a ~# 0`.+To prove that we need to know that `a+1 = 1` if `a=0`, which a plugin might know.+So it solves `wco` by providing a `UnivCo (PluginProv "my-plugin") (a+1) 1 [gco]`.++    But the `uco_deps` in `PluginProv` must mention `gco`!++Why? Otherwise we might float the entire expression (y |> wco) out of the+the case alternative for `T1` which brings `gco` into scope. If this+happens then we aren't far from a segmentation fault or much worse.+See #23923 for a real-world example of this happening.++So it is /crucial/ for the `UnivCo` to mention, in `uco_deps`, the coercion+variables used by the plugin to justify the `UnivCo` that it builds.  You+should think of it like `TyConAppCo`: the `UnivCo` proof constructor is+applied to a list of coercions, just as `TyConAppCo` is++It's very convenient to record a full coercion, not just a set of free coercion+variables, because during typechecking those coercions might contain coercion+holes `HoleCo`, which get filled in later.+-}++{- **********************************************************************+%*                                                                      *+                Coercion holes+%*                                                                      *+%********************************************************************* -}++-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]+data CoercionHole+  = CoercionHole { ch_co_var  :: CoVar+                       -- See Note [CoercionHoles and coercion free variables]++                 , ch_ref :: IORef (Maybe Coercion)+                 }++coHoleCoVar :: CoercionHole -> CoVar+coHoleCoVar = ch_co_var++setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole+setCoHoleCoVar h cv = h { ch_co_var = cv }++instance Data.Data CoercionHole where+  -- don't traverse?+  toConstr _   = abstractConstr "CoercionHole"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoercionHole"++instance Outputable CoercionHole where+  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)++instance Uniquable CoercionHole where+  getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv++{- Note [Coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~+During typechecking, constraint solving for type classes works by+  - Generate an evidence Id,  d7 :: Num a+  - Wrap it in a Wanted constraint, [W] d7 :: Num a+  - Use the evidence Id where the evidence is needed+  - Solve the constraint later+  - When solved, add an enclosing let-binding  let d7 = .... in ....+    which actually binds d7 to the (Num a) evidence++For equality constraints we use a different strategy.  See Note [The+equality types story] in GHC.Builtin.Types.Prim for background on equality constraints.+  - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just+    like type classes above. (Indeed, boxed equality constraints *are* classes.)+  - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)+    we use a different plan++For unboxed equalities:+  - Generate a CoercionHole, a mutable variable just like a unification+    variable+  - Wrap the CoercionHole in a Wanted constraint; see GHC.Tc.Utils.TcEvDest+  - Use the CoercionHole in a Coercion, via HoleCo+  - Solve the constraint later+  - When solved, fill in the CoercionHole by side effect, instead of+    doing the let-binding thing++The main reason for all this is that there may be no good place to let-bind+the evidence for unboxed equalities:++  - We emit constraints for kind coercions, to be used to cast a+    type's kind. These coercions then must be used in types. Because+    they might appear in a top-level type, there is no place to bind+    these (unlifted) coercions in the usual way.++  - A coercion for (forall a. t1) ~ (forall a. t2) will look like+       forall a. (coercion for t1~t2)+    But the coercion for (t1~t2) may mention 'a', and we don't have+    let-bindings within coercions.  We could add them, but coercion+    holes are easier.++  - Moreover, nothing is lost from the lack of let-bindings. For+    dictionaries want to achieve sharing to avoid recomputing the+    dictionary.  But coercions are entirely erased, so there's little+    benefit to sharing. Indeed, even if we had a let-binding, we+    always inline types and coercions at every use site and drop the+    binding.++Other notes about HoleCo:++ * INVARIANT: CoercionHole and HoleCo are used only during type checking,+   and should never appear in Core. Just like unification variables; a Type+   can contain a TcTyVar, but only during type checking. If, one day, we+   use type-level information to separate out forms that can appear during+   type-checking vs forms that can appear in core proper, holes in Core will+   be ruled out.++ * See Note [CoercionHoles and coercion free variables]++ * Coercion holes can be compared for equality like other coercions:+   by looking at the types coerced.+++Note [CoercionHoles and coercion free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why does a CoercionHole contain a CoVar, as well as reference to+fill in?  Because we want to treat that CoVar as a free variable of+the coercion.  See #14584, and Note [What prevents a+constraint from floating] in GHC.Tc.Solver, item (4):++        forall k. [W] co1 :: t1 ~# t2 |> co2+                  [W] co2 :: k ~# *++Here co2 is a CoercionHole. But we /must/ know that it is free in+co1, because that's all that stops it floating outside the+implication.+-}++++{- *********************************************************************+*                                                                      *+                foldType  and   foldCoercion+*                                                                      *+********************************************************************* -}++{- Note [foldType]+~~~~~~~~~~~~~~~~~~+foldType is a bit more powerful than perhaps it looks:++* You can fold with an accumulating parameter, via+     TyCoFolder env (Endo a)+  Recall newtype Endo a = Endo (a->a)++* You can fold monadically with a monad M, via+     TyCoFolder env (M a)+  provided you have+     instance ..  => Monoid (M a)++Note [mapType vs foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We define foldType here, but mapType in module Type. Why?++* foldType is used in GHC.Core.TyCo.FVs for finding free variables.+  It's a very simple function that analyses a type,+  but does not construct one.++* mapType constructs new types, and so it needs to call+  the "smart constructors", mkAppTy, mkCastTy, and so on.+  These are sophisticated functions, and can't be defined+  here in GHC.Core.TyCo.Rep.++Note [Specialising foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inline foldType at every call site (there are not many), so that it+becomes specialised for the particular monoid *and* TyCoFolder at+that site.  This is just for efficiency, but walking over types is+done a *lot* in GHC, so worth optimising.++We were worried that+    TyCoFolder env (Endo a)+might not eta-expand.  Recall newtype Endo a = Endo (a->a).++In particular, given+   fvs :: Type -> TyCoVarSet+   fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet++   tcf :: TyCoFolder enf (Endo a)+   tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = acc `extendVarSet` tv++we want to end up with+   fvs ty = go emptyVarSet ty emptyVarSet+     where+       go env (TyVarTy tv) acc = acc `extendVarSet` tv+       ..etc..++And indeed this happens.+  - Selections from 'tcf' are done at compile time+  - 'go' is nicely eta-expanded.++We were also worried about+   deep_fvs :: Type -> TyCoVarSet+   deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet++   deep_tcf :: TyCoFolder enf (Endo a)+   deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = deep_fvs (varType tv)+                                     `unionVarSet` acc+                                     `extendVarSet` tv++Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf.+But, amazingly, we get good code here too. GHC is careful not to mark+TyCoFolder data constructor for deep_tcf as a loop breaker, so the+record selections still cancel.  And eta expansion still happens too.++Note [Use explicit recursion in foldTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In foldTyCo you'll see things like:+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts+where we use /explicit recursion/.  You might wonder about using foldl instead:+    go_tys env = foldl (\t acc -> go_ty env t `mappend` acc) mempty+Or maybe foldl', or foldr.++But don't do that for two reasons (see #24591)++* We sometimes instantiate `a` to (Endo VarSet). Remembering+     newtype Endo a = Endo (a->a)+  after inlining `foldTyCo` bodily, the explicit recursion looks like+    go_tys _   []     = \acc -> acc+    go_tys env (t:ts) = \acc -> go_ty env t (go_tys env ts acc)+  The strictness analyser has no problem spotting that this function is+  strict in `acc`, provided `go_ty` is.++  But in the foldl form that is /much/ less obvious, and the strictness+  analyser fails utterly.  Result: lots and lots of thunks get built.  In+  !12037, Mikolaj found that GHC allocated /six times/ as much heap+  on test perf/compiler/T9198 as a result of this single problem!++* Second, while I think that using `foldr` would be fine (simple experiments in+  #24591 suggest as much), it builds a local loop (with env free) and I'm not 100%+  confident it'll be lambda lifted in the end. It seems more direct just to write+  the code we want.++  On the other hand in `go_cvs` we might hope that the `foldr` will fuse with the+  `dVarSetElems` so I have used `foldr`.+-}++data TyCoFolder env a+  = TyCoFolder+      { tcf_view  :: Type -> Maybe Type   -- Optional "view" function+                                          -- E.g. expand synonyms+      , tcf_tyvar :: env -> TyVar -> a    -- Does not automatically recur+      , tcf_covar :: env -> CoVar -> a    -- into kinds of variables+      , tcf_hole  :: env -> CoercionHole -> a+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".++      , tcf_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> env+          -- ^ The returned env is used in the extended scope+      }++{-# INLINE foldTyCo  #-}  -- See Note [Specialising foldType]+foldTyCo :: Monoid a => TyCoFolder env a -> env+         -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a)+foldTyCo (TyCoFolder { tcf_view       = view+                     , tcf_tyvar      = tyvar+                     , tcf_tycobinder = tycobinder+                     , tcf_covar      = covar+                     , tcf_hole       = cohole }) env+  = (go_ty env, go_tys env, go_co env, go_cos env)+  where+    go_ty env ty | Just ty' <- view ty = go_ty env ty'+    go_ty env (TyVarTy tv)      = tyvar env tv+    go_ty env (AppTy t1 t2)     = go_ty env t1 `mappend` go_ty env t2+    go_ty _   (LitTy {})        = mempty+    go_ty env (CastTy ty co)    = go_ty env ty `mappend` go_co env co+    go_ty env (CoercionTy co)   = go_co env co+    go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res+    go_ty env (TyConApp _ tys)  = go_tys env tys+    go_ty env (ForAllTy (Bndr tv vis) inner)+      = let !env' = tycobinder env tv vis  -- Avoid building a thunk here+        in go_ty env (varType tv) `mappend` go_ty env' inner++    -- See Note [Use explicit recursion in foldTyCo]+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts++    -- See Note [Use explicit recursion in foldTyCo]+    go_cos _   []     = mempty+    go_cos env (c:cs) = go_co env c `mappend` go_cos env cs++    go_co env (Refl ty)                = go_ty env ty+    go_co env (GRefl _ ty MRefl)       = go_ty env ty+    go_co env (GRefl _ ty (MCo co))    = go_ty env ty `mappend` go_co env co+    go_co env (TyConAppCo _ _ args)    = go_cos env args+    go_co env (AppCo c1 c2)            = go_co env c1 `mappend` go_co env c2+    go_co env (CoVarCo cv)             = covar env cv+    go_co env (AxiomCo _ cos)          = go_cos env cos+    go_co env (HoleCo hole)            = cohole env hole+    go_co env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                       = go_ty env t1 `mappend` go_ty env t2+                                         `mappend` go_cos env deps+    go_co env (SymCo co)               = go_co env co+    go_co env (TransCo c1 c2)          = go_co env c1 `mappend` go_co env c2+    go_co env (SelCo _ co)             = go_co env co+    go_co env (LRCo _ co)              = go_co env co+    go_co env (InstCo co arg)          = go_co env co `mappend` go_co env arg+    go_co env (KindCo co)              = go_co env co+    go_co env (SubCo co)               = go_co env co++    go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })+       = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2++    go_co env (ForAllCo tv _vis1 _vis2 kind_co co)+      = go_co env kind_co `mappend` go_ty env (varType tv)+                          `mappend` go_co env' co+      where+        env' = tycobinder env tv Inferred++-- | A view function that looks through nothing.+noView :: Type -> Maybe Type+noView _ = Nothing++{- *********************************************************************+*                                                                      *+                   typeSize, coercionSize+*                                                                      *+********************************************************************* -}++-- NB: We put typeSize/coercionSize here because they are mutually+--     recursive, and have the CPR property.  If we have mutual+--     recursion across a hi-boot file, we don't get the CPR property+--     and these functions allocate a tremendous amount of rubbish.+--     It's not critical (because typeSize is really only used in+--     debug mode, but I tripped over an example (T5642) in which+--     typeSize was one of the biggest single allocators in all of GHC.+--     And it's easy to fix, so I did.++-- NB: typeSize does not respect `eqType`, in that two types that+--     are `eqType` may return different sizes. This is OK, because this+--     function is used only in reporting, not decision-making.++typeSize :: Type -> Int+-- The size of the syntax tree of a type.  No special treatment+-- for type synonyms or type families.+typeSize (LitTy {})                 = 1+typeSize (TyVarTy {})               = 1+typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2+typeSize (FunTy _ _ t1 t2)          = typeSize t1 + typeSize t2+typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t+typeSize (TyConApp _ ts)            = 1 + typesSize ts+typeSize (CastTy ty co)             = typeSize ty + coercionSize co+typeSize (CoercionTy co)            = coercionSize co++typesSize :: [Type] -> Int+typesSize tys = foldr ((+) . typeSize) 0 tys++coercionSize :: Coercion -> Int+coercionSize (Refl ty)             = typeSize ty+coercionSize (GRefl _ ty MRefl)    = typeSize ty+coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co+coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (AppCo co arg)        = coercionSize co + coercionSize arg+coercionSize (ForAllCo { fco_kind = h, fco_body = co })+                                   = 1 + coercionSize co + coercionSize h+coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2+                                                         + coercionSize w+coercionSize (CoVarCo _)         = 1+coercionSize (HoleCo _)          = 1+coercionSize (AxiomCo _ cs)      = 1 + sum (map coercionSize cs)+coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 })  = 1 + typeSize t1 + typeSize t2+coercionSize (SymCo co)          = 1 + coercionSize co+coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (SelCo _ co)        = 1 + coercionSize co+coercionSize (LRCo  _ co)        = 1 + coercionSize co+coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg+coercionSize (KindCo co)         = 1 + coercionSize co+coercionSize (SubCo co)          = 1 + coercionSize co++{-+************************************************************************+*                                                                      *+                    Multiplicities+*                                                                      *+************************************************************************++These definitions are here to avoid module loops, and to keep+GHC.Core.Multiplicity above this module.++-}++-- | A shorthand for data with an attached 'Mult' element (the multiplicity).+data Scaled a = Scaled !Mult a+  deriving (Data.Data)+  -- You might think that this would be a natural candidate for+  -- Functor, Traversable but Krzysztof says (!3674) "it was too easy+  -- to accidentally lift functions (substitutions, zonking etc.) from+  -- Type -> Type to Scaled Type -> Scaled Type, ignoring+  -- multiplicities and causing bugs".  So we don't.+  --+  -- Being strict in a is worse for performance, so we are only strict on the+  -- Mult part of scaled.+++instance (Outputable a) => Outputable (Scaled a) where+   ppr (Scaled _cnt t) = ppr t+     -- Do not print the multiplicity here because it tends to be too verbose++scaledMult :: Scaled a -> Mult+scaledMult (Scaled m _) = m++scaledThing :: Scaled a -> a+scaledThing (Scaled _ t) = t++-- | Apply a function to both the Mult and the Type in a 'Scaled Type'+mapScaledType :: (Type -> Type) -> Scaled Type -> Scaled Type+mapScaledType f (Scaled m t) = Scaled (f m) (f t)++{- |+Mult is a type alias for Type.++Mult must contain Type because multiplicity variables are mere type variables+(of kind Multiplicity) in Haskell. So the simplest implementation is to make+Mult be Type.++Multiplicities can be formed with:+- One: GHC.Types.One (= oneDataCon)+- Many: GHC.Types.Many (= manyDataCon)+- Multiplication: GHC.Types.MultMul (= multMulTyCon)++So that Mult feels a bit more structured, we provide pattern synonyms and smart+constructors for these.+-}+type Mult = Type
+ GHC/Core/TyCo/Rep.hs-boot view
@@ -0,0 +1,43 @@+{-# LANGUAGE NoPolyKinds #-}+module GHC.Core.TyCo.Rep where++import GHC.Utils.Outputable ( Outputable )+import Data.Data  ( Data )+import {-# SOURCE #-} GHC.Types.Var( Var, VarBndr, FunTyFlag )+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )+import Language.Haskell.Syntax.Specificity (ForAllTyFlag)++data Type+data Coercion+data FunSel+data CoSel+data UnivCoProvenance+data TyLit+data MCoercion++data Scaled a+scaledThing :: Scaled a -> a++type Mult = Type++type PredType = Type+type RuntimeRepType = Type+type Kind = Type+type ThetaType = [PredType]+type CoercionN = Coercion+type MCoercionN = MCoercion++mkForAllTy       :: VarBndr Var ForAllTyFlag -> Type -> Type+mkNakedTyConTy   :: TyCon -> Type+mkNakedFunTy     :: FunTyFlag -> Type -> Type -> Type+++-- To support Data instances in GHC.Core.Coercion.Axiom+instance Data Type++-- To support instances PiTyBinder in Var+instance Data a => Data (Scaled a)++-- To support debug pretty-printing+instance Outputable Type+instance Outputable a => Outputable (Scaled a)
+ GHC/Core/TyCo/Subst.hs view
@@ -0,0 +1,1121 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+Type and Coercion - friends' interface+-}++++-- | Substitution into types and coercions.+module GHC.Core.TyCo.Subst+  (+        -- * Substitutions+        Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,+        emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,+        emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,+        mkSubst, mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,+        getTvSubstEnv, getIdSubstEnv,+        getCvSubstEnv, substInScopeSet, setInScope, getSubstRangeTyCoFVs,+        isInScope, elemSubst, notElemSubst, zapSubst,+        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,+        extendTCvSubst, extendTCvSubstWithClone,+        extendCvSubst, extendCvSubstWithClone,+        extendTvSubst, extendTvSubstWithClone,+        extendTvSubstList, extendTvSubstAndInScope,+        extendTCvSubstList,+        unionSubst, zipTyEnv, zipCoEnv,+        zipTvSubst, zipCvSubst,+        zipTCvSubst,+        mkTvSubstPrs,++        substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars,+        substCoWith,+        substTy, substTyAddInScope, substScaledTy,+        substTyUnchecked, substTysUnchecked, substScaledTysUnchecked, substThetaUnchecked,+        substTyWithUnchecked, substScaledTyUnchecked,+        substCoUnchecked, substCoWithUnchecked,+        substTyWithInScope,+        substTys, substScaledTys, substTheta,+        lookupTyVar,+        substCo, substCos, substCoVar, substCoVars, lookupCoVar,+        cloneTyVarBndr, cloneTyVarBndrs,+        substVarBndr, substVarBndrs,+        substTyVarBndr, substTyVarBndrs,+        substCoVarBndr, substDCoVarSet,+        substTyVar, substTyVars, substTyVarToTyVar,+        substTyCoVars,+        substTyCoBndr, substForAllCoBndr,+        substVarBndrUsing, substForAllCoBndrUsing,+        checkValidSubst, isValidTCvSubst,+  ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.Type+   ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe )+import {-# SOURCE #-} GHC.Core.Coercion+   ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo+   , mkNomReflCo, mkSubCo, mkSymCo+   , mkFunCo2, mkForAllCo, mkUnivCo+   , mkAxiomCo, mkAppCo, mkGReflCo+   , mkInstCo, mkLRCo, mkTyConAppCo+   , mkCoercionType+   , coercionLKind, coVarTypesRole )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprTyVar )+import {-# SOURCE #-} GHC.Core.Ppr ( ) -- instance Outputable CoreExpr+import {-# SOURCE #-} GHC.Core ( CoreExpr )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs++import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Types.Unique.Supply+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List (mapAccumL)++{-+%************************************************************************+%*                                                                      *+                        Substitutions+      Data type defined here to avoid unnecessary mutual recursion+%*                                                                      *+%************************************************************************+-}++-- | Type & coercion & id substitution+--+-- The "Subst" data type defined in this module contains substitution+-- for tyvar, covar and id. However, operations on IdSubstEnv (mapping+-- from "Id" to "CoreExpr") that require the definition of the "Expr"+-- data type are defined in GHC.Core.Subst to avoid circular module+-- dependency.+data Subst+  = Subst InScopeSet  -- Variables in scope (both Ids and TyVars) /after/+                      -- applying the substitution+          IdSubstEnv  -- Substitution from InId    to OutExpr+          TvSubstEnv  -- Substitution from InTyVar to OutType+          CvSubstEnv  -- Substitution from InCoVar to OutCoercion++        -- INVARIANT 1: See Note [The substitution invariant]+        -- This is what lets us deal with name capture properly+        --+        -- INVARIANT 2: The substitution is apply-once;+        --              see Note [Substitutions apply only once]+        --+        -- INVARIANT 3: See Note [Extending the IdSubstEnv] in "GHC.Core.Subst"+        -- and              Note [Extending the TvSubstEnv and CvSubstEnv]+        --+        -- INVARIANT 4: See Note [Substituting types, coercions, and expressions]++-- | A substitution of 'Expr's for non-coercion 'Id's+type IdSubstEnv = IdEnv CoreExpr   -- Domain is NonCoVarIds, i.e. not coercions++-- | A substitution of 'Type's for 'TyVar's+--                 and 'Kind's for 'KindVar's+type TvSubstEnv = TyVarEnv Type+  -- NB: A TvSubstEnv is used+  --   both inside a TCvSubst (with the apply-once invariant+  --        discussed in Note [Substitutions apply only once],+  --   and  also independently in the middle of matching,+  --        and unification (see Types.Unify).+  -- So you have to look at the context to know if it's idempotent or+  -- apply-once or whatever++-- | A substitution of 'Coercion's for 'CoVar's+type CvSubstEnv = CoVarEnv Coercion++{- Note [The substitution invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When calling (substTy subst ty) it should be the case that+the in-scope set in the substitution is a superset of both:++  (SIa) The free vars of the range of the substitution+  (SIb) The free vars of ty minus the domain of the substitution++* Reason for (SIa). Consider+      substTy [a :-> Maybe b] (forall b. b->a)+  we must rename the forall b, to get+      forall b2. b2 -> Maybe b+  Making 'b' part of the in-scope set forces this renaming to+  take place.++* Reason for (SIb). Consider+     substTy [a :-> Maybe b] (forall b. (a,b,x))+  Then if we use the in-scope set {b}, satisfying (SIa), there is+  a danger we will rename the forall'd variable to 'x' by mistake,+  getting this:+      forall x. (Maybe b, x, x)+  Breaking (SIb) caused the bug from #11371.++Note: if the free vars of the range of the substitution are freshly created,+then the problems of (SIa) can't happen, and so it would be sound to+ignore (SIa).++Note [Substitutions apply only once]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use TCvSubsts to instantiate things, and we might instantiate+        forall a b. ty+with the types+        [a, b], or [b, a].+So the substitution might go [a->b, b->a].  A similar situation arises in Core+when we find a beta redex like+        (/\ a /\ b -> e) b a+Then we also end up with a substitution that permutes type variables. Other+variations happen to; for example [a -> (a, b)].++        ********************************************************+        *** So a substitution must be applied precisely once ***+        ********************************************************++A TCvSubst is not idempotent, but, unlike the non-idempotent substitution+we use during unifications, it must not be repeatedly applied.++Note [Extending the TvSubstEnv and CvSubstEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The TvSubstEnv and CvSubstEnv have a binding for each TyCoVar+  - whose unique has changed, OR+  - whose kind has changed++This invariant allows a short-cut when the subst envs are empty:+if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst)+holds --- then (substTy subst ty) does nothing.++For example, consider:+        (/\a. /\b:(a~Int). ...b..) Int+We substitute Int for 'a'.  The Unique of 'b' does not change, but+nevertheless we add 'b' to the TvSubstEnv, because b's kind does change++This invariant has several crucial consequences:++* In substVarBndr, we need extend the TvSubstEnv+        - if the unique has changed+        - or if the kind has changed++* In substTyVar, we do not need to consult the in-scope set;+  the TvSubstEnv is enough++* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty++Note [Substituting types, coercions, and expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Types and coercions are mutually recursive, and either may have variables+"belonging" to the other. Thus, every time we wish to substitute in a+type, we may also need to substitute in a coercion, and vice versa.+Likewise, expressions may contain type variables or coercion variables.+However, we use different constructors for constructing expression variables,+coercion variables, and type variables, so we carry three VarEnvs for each+variable type. Note that it would be possible to use the CoercionTy constructor+and the Type constructor to combine these environments, but that seems like a+false economy.++Note that the domain of the VarEnvs must be respected, despite the fact that+TyVar, Id, and CoVar are all type synonyms of the Var type. For example,+TvSubstEnv should *never* map a CoVar (built with the Id constructor)+and the CvSubstEnv should *never* map a TyVar. Furthermore, the range+of the TvSubstEnv should *never* include a type headed with+CoercionTy.+-}++emptyIdSubstEnv :: IdSubstEnv+emptyIdSubstEnv = emptyVarEnv++emptyTvSubstEnv :: TvSubstEnv+emptyTvSubstEnv = emptyVarEnv++emptyCvSubstEnv :: CvSubstEnv+emptyCvSubstEnv = emptyVarEnv++-- | Composes two substitutions, applying the second one provided first,+-- like in function composition. This function leaves IdSubstEnv untouched+-- because IdSubstEnv is not used during substitution for types.+composeTCvSubst :: Subst -> Subst -> Subst+composeTCvSubst subst1@(Subst is1 ids1 tenv1 cenv1) (Subst is2 _ tenv2 cenv2)+  = Subst is3 ids1 tenv3 cenv3+  where+    is3 = is1 `unionInScope` is2+    tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy extended_subst1) tenv2+    cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo extended_subst1) cenv2++    -- Make sure the in-scope set in the first substitution is wide enough to+    -- cover the free variables in the range of the second substitution before+    -- applying it (#22235).+    extended_subst1 = subst1 `setInScope` is3++emptySubst :: Subst+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv++mkEmptySubst :: InScopeSet -> Subst+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv++isEmptySubst :: Subst -> Bool+isEmptySubst (Subst _ id_env tv_env cv_env)+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env++-- | Checks whether the tyvar and covar environments are empty.+-- This function should be used over 'isEmptySubst' when substituting+-- for types, because types currently do not contain expressions; we can+-- safely disregard the expression environment when deciding whether+-- to skip a substitution. Using 'isEmptyTCvSubst' gives us a non-trivial+-- performance boost (up to 70% less allocation for T18223)+isEmptyTCvSubst :: Subst -> Bool+isEmptyTCvSubst (Subst _ _ tv_env cv_env)+  = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env++mkSubst :: InScopeSet -> IdSubstEnv -> TvSubstEnv -> CvSubstEnv -> Subst+mkSubst = Subst++mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst+mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs++mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst+mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv++mkTvSubst :: InScopeSet -> TvSubstEnv -> Subst+-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst+mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv++mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst+-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst+mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv++getIdSubstEnv :: Subst -> IdSubstEnv+getIdSubstEnv (Subst _ ids _ _) = ids++getTvSubstEnv :: Subst -> TvSubstEnv+getTvSubstEnv (Subst _ _ tenv _) = tenv++getCvSubstEnv :: Subst -> CvSubstEnv+getCvSubstEnv (Subst _ _ _ cenv) = cenv++-- | Find the in-scope set: see Note [The substitution invariant]+substInScopeSet :: Subst -> InScopeSet+substInScopeSet (Subst in_scope _ _ _) = in_scope++setInScope :: Subst -> InScopeSet -> Subst+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs++-- | Returns the free variables of the types in the range of a substitution as+-- a non-deterministic set.+getSubstRangeTyCoFVs :: Subst -> VarSet+getSubstRangeTyCoFVs (Subst _ _ tenv cenv)+  = tenvFVs `unionVarSet` cenvFVs+  where+    tenvFVs = shallowTyCoVarsOfTyVarEnv tenv+    cenvFVs = shallowTyCoVarsOfCoVarEnv cenv++isInScope :: Var -> Subst -> Bool+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope++elemSubst :: Var -> Subst -> Bool+elemSubst v (Subst _ ids tenv cenv)+  | isTyVar v+  = v `elemVarEnv` tenv+  | isCoVar v+  = v `elemVarEnv` cenv+  | otherwise+  = v `elemVarEnv` ids++notElemSubst :: Var -> Subst -> Bool+notElemSubst v = not . elemSubst v++-- | Remove all substitutions that might have been built up+-- while preserving the in-scope set+-- originally called zapSubstEnv+zapSubst :: Subst -> Subst+zapSubst (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv++-- | Add the 'Var' to the in-scope set+extendSubstInScope :: Subst -> Var -> Subst+extendSubstInScope (Subst in_scope ids tvs cvs) v+  = Subst (in_scope `extendInScopeSet` v)+          ids tvs cvs++-- | Add the 'Var's to the in-scope set: see also 'extendInScope'+extendSubstInScopeList :: Subst -> [Var] -> Subst+extendSubstInScopeList (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetList` vs)+          ids tvs cvs++-- | Add the 'Var's to the in-scope set: see also 'extendInScope'+extendSubstInScopeSet :: Subst -> VarSet -> Subst+extendSubstInScopeSet (Subst in_scope ids tvs cvs) vs+  = Subst (in_scope `extendInScopeSetSet` vs)+          ids tvs cvs++extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst+extendTCvSubst subst v ty+  | isTyVar v+  = extendTvSubst subst v ty+  | CoercionTy co <- ty+  = extendCvSubst subst v co+  | otherwise+  = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty)++extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst+extendTCvSubstWithClone subst tcv+  | isTyVar tcv = extendTvSubstWithClone subst tcv+  | otherwise   = extendCvSubstWithClone subst tcv++-- | Add a substitution for a 'TyVar' to the 'Subst'+-- The 'TyVar' *must* be a real TyVar, and not a CoVar+-- You must ensure that the in-scope set is such that+-- Note [The substitution invariant] holds+-- after extending the substitution like this.+extendTvSubst :: Subst -> TyVar -> Type -> Subst+extendTvSubst (Subst in_scope ids tvs cvs) tv ty+  = assert (isTyVar tv) $+    Subst in_scope ids (extendVarEnv tvs tv ty) cvs++extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst+-- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone+-- Does not look in the kind of the new variable;+--   those variables should be in scope already+extendTvSubstWithClone (Subst in_scope idenv tenv cenv) tv tv'+  = Subst (extendInScopeSet in_scope tv')+          idenv+          (extendVarEnv tenv tv (mkTyVarTy tv'))+          cenv++-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst':+-- you must ensure that the in-scope set satisfies+-- Note [The substitution invariant]+-- after extending the substitution like this+extendCvSubst :: Subst -> CoVar -> Coercion -> Subst+extendCvSubst (Subst in_scope ids tvs cvs) v r+  = assert (isCoVar v) $+    Subst in_scope ids tvs (extendVarEnv cvs v r)++extendCvSubstWithClone :: Subst -> CoVar -> CoVar -> Subst+extendCvSubstWithClone (Subst in_scope ids tenv cenv) cv cv'+  = Subst (extendInScopeSetSet in_scope new_in_scope)+             ids+             tenv+             (extendVarEnv cenv cv (mkCoVarCo cv'))+  where+    new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv'++extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst+-- Also extends the in-scope set+extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty+  = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)+             ids+             (extendVarEnv tenv tv ty)+             cenv++-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'+extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst+extendTvSubstList subst vrs+  = foldl' extend subst vrs+  where+    extend subst (v, r) = extendTvSubst subst v r++extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst+extendTCvSubstList subst tvs tys+  = foldl2 extendTCvSubst subst tvs tys++unionSubst :: Subst -> Subst -> Subst+-- Works when the ranges are disjoint+unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2)+  = assert (ids1  `disjointVarEnv` ids2+         && tenv1 `disjointVarEnv` tenv2+         && cenv1 `disjointVarEnv` cenv2 )+    Subst (in_scope1 `unionInScope` in_scope2)+           (ids1      `plusVarEnv`   ids2)+           (tenv1     `plusVarEnv`   tenv2)+           (cenv1     `plusVarEnv`   cenv2)++-- | Generates the in-scope set for the 'Subst' from the types in the incoming+-- environment. No CoVars or Ids, please!+zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> Subst+zipTvSubst tvs tys+  = mkTvSubst (mkInScopeSet (shallowTyCoVarsOfTypes tys)) tenv+  where+    tenv = zipTyEnv tvs tys++-- | Generates the in-scope set for the 'Subst' from the types in the incoming+-- environment.  No TyVars, please!+zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst+zipCvSubst cvs cos+  = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv+  where+    cenv = zipCoEnv cvs cos+++zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst+zipTCvSubst tcvs tys+  = zip_tcvsubst tcvs tys $+    mkEmptySubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys+  where zip_tcvsubst :: [TyCoVar] -> [Type] -> Subst -> Subst+        zip_tcvsubst (tv:tvs) (ty:tys) subst+          = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty)+        zip_tcvsubst [] [] subst = subst -- empty case+        zip_tcvsubst _  _  _     = pprPanic "zipTCvSubst: length mismatch"+                                   (ppr tcvs <+> ppr tys)++-- | Generates the in-scope set for the 'TCvSubst' from the types in the+-- incoming environment. No CoVars, please! The InScopeSet is just a thunk+--  so with a bit of luck it'll never be evaluated+mkTvSubstPrs :: [(TyVar, Type)] -> Subst+mkTvSubstPrs []  = emptySubst+mkTvSubstPrs prs =+    assertPpr onlyTyVarsAndNoCoercionTy (text "prs" <+> ppr prs) $+    mkTvSubst in_scope tenv+  where tenv = mkVarEnv prs+        in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ map snd prs+        onlyTyVarsAndNoCoercionTy =+          and [ isTyVar tv && not (isCoercionTy ty)+              | (tv, ty) <- prs ]++-- | The InScopeSet is just a thunk so with a bit of luck it'll never be evaluated+zipTyEnv :: HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv+zipTyEnv tyvars tys+  | debugIsOn+  , not (all isTyVar tyvars && (tyvars `equalLength` tys))+  = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys)+  | otherwise+  = assert (all (not . isCoercionTy) tys )+    zipToUFM tyvars tys+        -- There used to be a special case for when+        --      ty == TyVarTy tv+        -- (a not-uncommon case) in which case the substitution was dropped.+        -- But the type-tidier changes the print-name of a type variable without+        -- changing the unique, and that led to a bug.   Why?  Pre-tidying, we had+        -- a type {Foo t}, where Foo is a one-method class.  So Foo is really a newtype.+        -- And it happened that t was the type variable of the class.  Post-tiding,+        -- it got turned into {Foo t2}.  The ext-core printer expanded this using+        -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique,+        -- and so generated a rep type mentioning t not t2.+        --+        -- Simplest fix is to nuke the "optimisation"++zipCoEnv :: HasDebugCallStack => [CoVar] -> [Coercion] -> CvSubstEnv+zipCoEnv cvs cos+  | debugIsOn+  , not (all isCoVar cvs)+  = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)+  | otherwise+  = mkVarEnv (zipEqual cvs cos)++-- Pretty printing, for debugging only++instance Outputable Subst where+  ppr (Subst in_scope ids tvs cvs)+        =  text "<InScope =" <+> in_scope_doc+        $$ text " IdSubst   =" <+> ppr ids+        $$ text " TvSubst   =" <+> ppr tvs+        $$ text " CvSubst   =" <+> ppr cvs+         <> char '>'+    where+    in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)++{-+%************************************************************************+%*                                                                      *+                Performing type or kind substitutions+%*                                                                      *+%************************************************************************++Note [Sym and ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~+In OptCoercion, we try to push "sym" out to the leaves of a coercion. But,+how do we push sym into a ForAllCo? It's a little ugly.++Ignoring visibility, here is the typing rule+(see Note [ForAllCo] in GHC.Core.TyCo.Rep).++h : k1 ~# k2+(tv : k1) |- g : ty1 ~# ty2+----------------------------+ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~#+                  (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h]))++Here is what we want:++ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~#+                    (ForAllTy (tv : k1) ty1)+++Because the kinds of the type variables to the right of the colon are the kinds+coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h).++Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want++ForAllCo tv h' g' :+  (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~#+  (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h']))++We thus see that we want++g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h']++and thus g' = sym (g[tv |-> tv |> h']).++Putting it all together, we get this:++sym (ForAllCo tv h g)+==>+ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])++Note [Substituting in a coercion hole]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It seems highly suspicious to be substituting in a coercion that still+has coercion holes. Yet, this can happen in a situation like this:++  f :: forall k. k :~: Type -> ()+  f Refl = let x :: forall (a :: k). [a] -> ...+               x = ...++When we check x's type signature, we require that k ~ Type. We indeed+know this due to the Refl pattern match, but the eager unifier can't+make use of givens. So, when we're done looking at x's type, a coercion+hole will remain. Then, when we're checking x's definition, we skolemise+x's type (in order to, e.g., bring the scoped type variable `a` into scope).+This requires performing a substitution for the fresh skolem variables.++This substitution needs to affect the kind of the coercion hole, too --+otherwise, the kind will have an out-of-scope variable in it. More problematically+in practice (we won't actually notice the out-of-scope variable ever), skolems+in the kind might have too high a level, triggering a failure to uphold the+invariant that no free variables in a type have a higher level than the+ambient level in the type checker. In the event of having free variables in the+hole's kind, I'm pretty sure we'll always have an erroneous program, so we+don't need to worry what will happen when the hole gets filled in. After all,+a hole relating a locally-bound type variable will be unable to be solved. This+is why it's OK not to look through the IORef of a coercion hole during+substitution.++-}++-- | Type substitution, see 'zipTvSubst'+substTyWith :: HasDebugCallStack => [TyVar] -> [Type] -> Type -> Type+-- Works only if the domain of the substitution is a+-- superset of the type being substituted into+substTyWith tvs tys = {-#SCC "substTyWith" #-}+                      assert (tvs `equalLength` tys )+                      substTy (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type+substTyWithUnchecked tvs tys+  = assert (tvs `equalLength` tys )+    substTyUnchecked (zipTvSubst tvs tys)++-- | Substitute tyvars within a type using a known 'InScopeSet'.+-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution+-- invariant]; specifically it should include the free vars of 'tys',+-- and of 'ty' minus the domain of the subst.+substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type+substTyWithInScope in_scope tvs tys ty =+  assert (tvs `equalLength` tys )+  substTy (mkTvSubst in_scope tenv) ty+  where tenv = zipTyEnv tvs tys++-- | Coercion substitution, see 'zipTvSubst'+substCoWith :: HasDebugCallStack => [TyVar] -> [Type] -> Coercion -> Coercion+substCoWith tvs tys = assert (tvs `equalLength` tys )+                      substCo (zipTvSubst tvs tys)++-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion+substCoWithUnchecked tvs tys+  = assert (tvs `equalLength` tys )+    substCoUnchecked (zipTvSubst tvs tys)++++-- | Substitute covars within a type+substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type+substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)++-- | Type substitution, see 'zipTvSubst'+substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith tvs tys = assert (tvs `equalLength` tys )+                       substTys (zipTvSubst tvs tys)++-- | Type substitution, see 'zipTvSubst'+substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )+                             substTys (zipCvSubst cvs cos)++-- | Substitute within a 'Type' after adding the free variables of the type+-- to the in-scope set. This is useful for the case when the free variables+-- aren't already in the in-scope set or easily available.+-- See also Note [The substitution invariant].+substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type+substTyAddInScope subst ty =+  substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty++-- | When calling `substTy` it should be the case that the in-scope set in+-- the substitution is a superset of the free vars of the range of the+-- substitution.+-- See also Note [The substitution invariant].+-- TODO: take into account ids and rename as isValidSubst+isValidTCvSubst :: Subst -> Bool+isValidTCvSubst (Subst in_scope _ tenv cenv) =+  (tenvFVs `varSetInScope` in_scope) &&+  (cenvFVs `varSetInScope` in_scope)+  where+  tenvFVs = shallowTyCoVarsOfTyVarEnv tenv+  cenvFVs = shallowTyCoVarsOfCoVarEnv cenv++-- | This checks if the substitution satisfies the invariant from+-- Note [The substitution invariant].+checkValidSubst :: HasDebugCallStack => Subst -> [Type] -> [Coercion] -> a -> a+checkValidSubst subst@(Subst in_scope _ tenv cenv) tys cos a+  = assertPpr (isValidTCvSubst subst)+              (text "in_scope" <+> ppr in_scope $$+               text "tenv" <+> ppr tenv $$+               text "tenvFVs" <+> ppr (shallowTyCoVarsOfTyVarEnv tenv) $$+               text "cenv" <+> ppr cenv $$+               text "cenvFVs" <+> ppr (shallowTyCoVarsOfCoVarEnv cenv) $$+               text "tys" <+> ppr tys $$+               text "cos" <+> ppr cos) $+    assertPpr tysCosFVsInScope+              (text "in_scope" <+> ppr in_scope $$+               text "tenv" <+> ppr tenv $$+               text "cenv" <+> ppr cenv $$+               text "tys" <+> ppr tys $$+               text "cos" <+> ppr cos $$+               text "needInScope" <+> ppr needInScope)+    a+  where+  substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv+    -- It's OK to use nonDetKeysUFM here, because we only use this list to+    -- remove some elements from a set+  needInScope = (shallowTyCoVarsOfTypes tys `unionVarSet`+                 shallowTyCoVarsOfCos cos)+                `delListFromUniqSet_Directly` substDomain+  tysCosFVsInScope = needInScope `varSetInScope` in_scope+++-- | Substitute within a 'Type'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTy :: HasDebugCallStack => Subst -> Type  -> Type+substTy subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = checkValidSubst subst [ty] [] $+                            subst_ty subst ty++-- | Substitute within a 'Type' disabling the sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substTyUnchecked :: Subst -> Type -> Type+substTyUnchecked subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = subst_ty subst ty++substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type+substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty++substScaledTyUnchecked :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type+substScaledTyUnchecked subst scaled_ty = mapScaledType (substTyUnchecked subst) scaled_ty++-- | Substitute within several 'Type's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTys :: HasDebugCallStack => Subst -> [Type] -> [Type]+substTys subst tys+  | isEmptyTCvSubst subst = tys+  | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys++substScaledTys :: HasDebugCallStack => Subst -> [Scaled Type] -> [Scaled Type]+substScaledTys subst scaled_tys+  | isEmptyTCvSubst subst = scaled_tys+  | otherwise = checkValidSubst subst (map scaledMult scaled_tys ++ map scaledThing scaled_tys) [] $+                map (mapScaledType (subst_ty subst)) scaled_tys++-- | Substitute within several 'Type's disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTysUnchecked to+-- substTys and remove this function. Please don't use in new code.+substTysUnchecked :: Subst -> [Type] -> [Type]+substTysUnchecked subst tys+                 | isEmptyTCvSubst subst = tys+                 | otherwise             = map (subst_ty subst) tys++substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type]+substScaledTysUnchecked subst tys+                 | isEmptyTCvSubst subst = tys+                 | otherwise             = map (mapScaledType (subst_ty subst)) tys++-- | Substitute within a 'ThetaType'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType+substTheta = substTys++-- | Substitute within a 'ThetaType' disabling the sanity checks.+-- The problems that the sanity checks in substTys catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to+-- substTheta and remove this function. Please don't use in new code.+substThetaUnchecked :: Subst -> ThetaType -> ThetaType+substThetaUnchecked = substTysUnchecked+++subst_ty :: Subst -> Type -> Type+-- subst_ty is the main workhorse for type substitution+--+-- Note that the in_scope set is poked only if we hit a forall+-- so it may often never be fully computed+subst_ty subst ty+   = go ty+  where+    go (TyVarTy tv)      = substTyVar subst tv+    go (AppTy fun arg)   = (mkAppTy $! (go fun)) $! (go arg)+                -- The mkAppTy smart constructor is important+                -- we might be replacing (a Int), represented with App+                -- by [Int], represented with TyConApp+    go ty@(TyConApp tc []) = tc `seq` ty  -- avoid allocation in this common case+    go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys+                               -- NB: mkTyConApp, not TyConApp.+                               -- mkTyConApp has optimizations.+                               -- See Note [Using synonyms to compress types]+                               -- in GHC.Core.Type+    go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })+      = let !mult' = go mult+            !arg' = go arg+            !res' = go res+        in ty { ft_mult = mult', ft_arg = arg', ft_res = res' }+    go (ForAllTy (Bndr tv vis) ty)+                         = case substVarBndrUnchecked subst tv of+                             (subst', tv') ->+                               (ForAllTy $! ((Bndr $! tv') vis)) $!+                                            (subst_ty subst' ty)+    go (LitTy n)         = LitTy $! n+    go (CastTy ty co)    = (mkCastTy $! (go ty)) $! (subst_co subst co)+    go (CoercionTy co)   = CoercionTy $! (subst_co subst co)++substTyVar :: Subst -> TyVar -> Type+substTyVar (Subst _ _ tenv _) tv+  = assert (isTyVar tv) $+    case lookupVarEnv tenv tv of+      Just ty -> ty+      Nothing -> TyVarTy tv++substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar+-- Apply the substitution, expecting the result to be a TyVarTy+substTyVarToTyVar (Subst _ _ tenv _) tv+  = assert (isTyVar tv) $+    case lookupVarEnv tenv tv of+      Just ty -> case getTyVar_maybe ty of+                    Just tv -> tv+                    Nothing -> pprPanic "substTyVarToTyVar" (ppr tv $$ ppr ty)+      Nothing -> tv++substTyVars :: Subst -> [TyVar] -> [Type]+substTyVars subst = map $ substTyVar subst++substTyCoVars :: Subst -> [TyCoVar] -> [Type]+substTyCoVars subst = map $ substTyCoVar subst++substTyCoVar :: Subst -> TyCoVar -> Type+substTyCoVar subst tv+  | isTyVar tv = substTyVar subst tv+  | otherwise = CoercionTy $ substCoVar subst tv++lookupTyVar :: Subst -> TyVar  -> Maybe Type+        -- See Note [Extending the TvSubstEnv and CvSubstEnv]+lookupTyVar (Subst _ _ tenv _) tv+  = assert (isTyVar tv )+    lookupVarEnv tenv tv++-- | Substitute within a 'Coercion'+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion+substCo subst co+  | isEmptyTCvSubst subst = co+  | otherwise = checkValidSubst subst [] [co] $ subst_co subst co++-- | Substitute within a 'Coercion' disabling sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substCoUnchecked :: Subst -> Coercion -> Coercion+substCoUnchecked subst co+  | isEmptyTCvSubst subst = co+  | otherwise = subst_co subst co++-- | Substitute within several 'Coercion's+-- The substitution has to satisfy the invariants described in+-- Note [The substitution invariant].+substCos :: HasDebugCallStack => Subst -> [Coercion] -> [Coercion]+substCos subst cos+  | isEmptyTCvSubst subst = cos+  | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos++subst_co :: Subst -> Coercion -> Coercion+subst_co subst co+  = go co+  where+    go_ty :: Type -> Type+    go_ty = subst_ty subst++    go_mco :: MCoercion -> MCoercion+    go_mco MRefl    = MRefl+    go_mco (MCo co) = MCo (go co)++    go :: Coercion -> Coercion+    go (Refl ty)             = mkNomReflCo $! (go_ty ty)+    go (GRefl r ty mco)      = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco)+    go (TyConAppCo r tc args)= mkTyConAppCo r tc $! go_cos args+    go (AxiomCo con cos)     = mkAxiomCo con $! go_cos cos+    go (AppCo co arg)        = (mkAppCo $! go co) $! go arg+    go (ForAllCo tv visL visR kind_co co)+      = case substForAllCoBndrUnchecked subst tv kind_co of+         (subst', tv', kind_co') ->+          ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co+    go (FunCo r afl afr w co1 co2)   = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2+    go (CoVarCo cv)          = substCoVar subst cv+    go (UnivCo { uco_prov = p, uco_role = r+               , uco_lty = t1, uco_rty = t2, uco_deps = deps })+                             = ((((mkUnivCo $! p) $! go_cos deps) $! r) $!+                                  (go_ty t1)) $! (go_ty t2)+    go (SymCo co)            = mkSymCo $! (go co)+    go (TransCo co1 co2)     = (mkTransCo $! (go co1)) $! (go co2)+    go (SelCo d co)          = mkSelCo d $! (go co)+    go (LRCo lr co)          = mkLRCo lr $! (go co)+    go (InstCo co arg)       = (mkInstCo $! (go co)) $! go arg+    go (KindCo co)           = mkKindCo $! (go co)+    go (SubCo co)            = mkSubCo $! (go co)+    go (HoleCo h)            = HoleCo $! go_hole h++    go_cos cos = let cos' = map go cos+                 in cos' `seqList` cos'++    -- See Note [Substituting in a coercion hole]+    go_hole h@(CoercionHole { ch_co_var = cv })+      = h { ch_co_var = updateVarType go_ty cv }++-- | Perform a substitution within a 'DVarSet' of free variables,+-- returning the shallow free coercion variables.+substDCoVarSet :: Subst -> DCoVarSet -> DCoVarSet+substDCoVarSet subst cvs = coVarsOfCosDSet $ map (substCoVar subst) $+                           dVarSetElems cvs++substForAllCoBndr :: Subst -> TyCoVar -> KindCoercion+                  -> (Subst, TyCoVar, Coercion)+substForAllCoBndr subst+  = substForAllCoBndrUsing (substCo subst) subst++-- | Like 'substForAllCoBndr', but disables sanity checks.+-- The problems that the sanity checks in substCo catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substCoUnchecked to+-- substCo and remove this function. Please don't use in new code.+substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion+                           -> (Subst, TyCoVar, Coercion)+substForAllCoBndrUnchecked subst+  = substForAllCoBndrUsing (substCoUnchecked subst) subst++-- See Note [Sym and ForAllCo]+substForAllCoBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co+                       -> Subst -> TyCoVar -> KindCoercion+                       -> (Subst, TyCoVar, KindCoercion)+substForAllCoBndrUsing sco subst old_var+  | isTyVar old_var = substForAllCoTyVarBndrUsing sco subst old_var+  | otherwise       = substForAllCoCoVarBndrUsing sco subst old_var++substForAllCoTyVarBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co+                            -> Subst -> TyVar -> KindCoercion+                            -> (Subst, TyVar, KindCoercion)+substForAllCoTyVarBndrUsing sco (Subst in_scope idenv tenv cenv) old_var old_kind_co+  = assert (isTyVar old_var )+    ( Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv+    , new_var, new_kind_co )+  where+    new_env | no_change = delVarEnv tenv old_var+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    no_kind_change = noFreeVarsOfCo old_kind_co+    no_change = no_kind_change && (new_var == old_var)++    new_kind_co | no_kind_change = old_kind_co+                | otherwise      = sco old_kind_co++    new_ki1 = coercionLKind new_kind_co+    -- We could do substitution to (tyVarKind old_var). We don't do so because+    -- we already substituted new_kind_co, which contains the kind information+    -- we want. We don't want to do substitution once more. Also, in most cases,+    -- new_kind_co is a Refl, in which case coercionKind is really fast.++    new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1)++substForAllCoCoVarBndrUsing :: (Coercion -> Coercion)  -- transformation to kind co+                            -> Subst -> CoVar -> KindCoercion+                            -> (Subst, CoVar, KindCoercion)+substForAllCoCoVarBndrUsing sco (Subst in_scope idenv tenv cenv)+                            old_var old_kind_co+  = assert (isCoVar old_var )+    ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv+    , new_var, new_kind_co )+  where+    new_cenv | no_change = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)++    no_kind_change = noFreeVarsOfCo old_kind_co+    no_change = no_kind_change && (new_var == old_var)++    new_kind_co | no_kind_change = old_kind_co+                | otherwise      = sco old_kind_co++    new_ki1       = coercionLKind new_kind_co+    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1++substCoVar :: Subst -> CoVar -> Coercion+substCoVar (Subst _ _ _ cenv) cv+  = case lookupVarEnv cenv cv of+      Just co -> co+      Nothing -> CoVarCo cv++substCoVars :: Subst -> [CoVar] -> [Coercion]+substCoVars subst cvs = map (substCoVar subst) cvs++lookupCoVar :: Subst -> Var -> Maybe Coercion+lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v++substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar)+substTyVarBndr = substTyVarBndrUsing substTy++substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar])+substTyVarBndrs = mapAccumL substTyVarBndr++substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar)+substVarBndr = substVarBndrUsing substTy++substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar])+substVarBndrs = mapAccumL substVarBndr++substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar)+substCoVarBndr = substCoVarBndrUsing substTy++-- | Like 'substVarBndr', but disables sanity checks.+-- The problems that the sanity checks in substTy catch are described in+-- Note [The substitution invariant].+-- The goal of #11371 is to migrate all the calls of substTyUnchecked to+-- substTy and remove this function. Please don't use in new code.+substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar)+substVarBndrUnchecked = substVarBndrUsing substTyUnchecked++substVarBndrUsing :: (Subst -> Type -> Type)+                  -> Subst -> TyCoVar -> (Subst, TyCoVar)+substVarBndrUsing subst_fn subst v+  | isTyVar v = substTyVarBndrUsing subst_fn subst v+  | otherwise = substCoVarBndrUsing subst_fn subst v++-- | Substitute a tyvar in a binding position, returning an+-- extended subst and a new tyvar.+-- Use the supplied function to substitute in the kind+substTyVarBndrUsing+  :: (Subst -> Type -> Type)  -- ^ Use this to substitute in the kind+  -> Subst -> TyVar -> (Subst, TyVar)+substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var+  = assertPpr _no_capture (pprTyVar old_var $$ pprTyVar new_var $$ ppr subst) $+    assert (isTyVar old_var )+    (Subst (in_scope `extendInScopeSet` new_var) idenv new_env cenv, new_var)+  where+    new_env | no_change = delVarEnv tenv old_var+            | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)++    _no_capture = not (new_var `elemVarSet` shallowTyCoVarsOfTyVarEnv tenv)+    -- Assertion check that we are not capturing something in the substitution++    old_ki = tyVarKind old_var+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed+    no_change = no_kind_change && (new_var == old_var)+        -- no_change means that the new_var is identical in+        -- all respects to the old_var (same unique, same kind)+        -- See Note [Extending the TvSubstEnv and CvSubstEnv]+        --+        -- In that case we don't need to extend the substitution+        -- to map old to new.  But instead we must zap any+        -- current substitution for the variable. For example:+        --      (\x.e) with id_subst = [x |-> e']+        -- Here we must simply zap the substitution for x++    new_var | no_kind_change = uniqAway in_scope old_var+            | otherwise = uniqAway in_scope $+                          setTyVarKind old_var (subst_fn subst old_ki)+        -- The uniqAway part makes sure the new variable is not already in scope++-- | Substitute a covar in a binding position, returning an+-- extended subst and a new covar.+-- Use the supplied function to substitute in the kind+substCoVarBndrUsing+  :: (Subst -> Type -> Type)+  -> Subst -> CoVar -> (Subst, CoVar)+substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var+  = assert (isCoVar old_var)+    (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var)+  where+    new_co         = mkCoVarCo new_var+    no_kind_change = noFreeVarsOfTypes [t1, t2]+    no_change      = new_var == old_var && no_kind_change++    new_cenv | no_change = delVarEnv cenv old_var+             | otherwise = extendVarEnv cenv old_var new_co++    new_var = uniqAway in_scope subst_old_var+    subst_old_var = mkCoVar (varName old_var) new_var_type++    (t1, t2, role) = coVarTypesRole old_var+    t1' = subst_fn subst t1+    t2' = subst_fn subst t2+    new_var_type = mkCoercionType role t1' t2'+                  -- It's important to do the substitution for coercions,+                  -- because they can have free type variables++cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar)+cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq+  = assertPpr (isTyVar tv) (ppr tv)   -- I think it's only called on TyVars+    ( Subst (extendInScopeSet in_scope tv')+            id_env+            (extendVarEnv tv_env tv (mkTyVarTy tv'))+            cv_env+    , tv')+  where+    old_ki = tyVarKind tv+    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed++    tv1 | no_kind_change = tv+        | otherwise      = setTyVarKind tv (substTy subst old_ki)++    tv' = setVarUnique tv1 uniq++cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar])+cloneTyVarBndrs subst []     _usupply = (subst, [])+cloneTyVarBndrs subst (t:ts)  usupply = (subst'', tv:tvs)+  where+    (uniq, usupply') = takeUniqFromSupply usupply+    (subst' , tv )   = cloneTyVarBndr subst t uniq+    (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'++substTyCoBndr :: Subst -> PiTyBinder -> (Subst, PiTyBinder)+substTyCoBndr subst (Anon ty af)          = (subst, Anon (substScaledTy subst ty) af)+substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))+                                          where+                                            (subst', tv') = substVarBndr subst tv
+ GHC/Core/TyCo/Tidy.hs view
@@ -0,0 +1,364 @@+-- | Tidying types and coercions for printing in error messages.+module GHC.Core.TyCo.Tidy+  (+        -- * Tidying type related things up for printing+        tidyType, tidyTypes,+        tidyCo,   tidyCos,+        tidyTopType,++        tidyOpenType,  tidyOpenTypes,+        tidyOpenTypeX, tidyOpenTypesX,+        tidyFreeTyCoVars, tidyFreeTyCoVarX, tidyFreeTyCoVarsX,++        tidyAvoiding,+        tidyVarBndr, tidyVarBndrs, avoidNameClashes,+        tidyForAllTyBinder, tidyForAllTyBinders,+        tidyTyCoVarOcc+  ) where++import GHC.Prelude+import GHC.Data.FastString++import GHC.Core.Predicate( scopedSort )+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Types.Name hiding (varName)+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Utils.Misc (strictMap)++import Data.List (mapAccumL)++{- **********************************************************************++                  TidyType++********************************************************************** -}++{- Note [Tidying open types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When tidying some open types [t1,..,tn], we find their free vars, and tidy them first.++But (tricky point) we restrict the occ_env part of inner_env to just the /free/+vars of [t1..tn], so that we don't gratuitously rename the /bound/ variables.++Example: assume the TidyEnv+      ({"a1","b"} , [a_4 :-> a1, b_7 :-> b])+and call tidyOpenTypes on+      [a_1, forall a_2. Maybe (a_2,a_4), forall b. (b,a_1)]+All the a's have the same OccName, but different uniques.++The TidyOccEnv binding for "b" relates b_7, which doesn't appear free in the+these types at all, so we don't want that to mess up the tidying for the+(forall b...).++So we proceed as follows:+  1. Find the free vars.+     In our example:the free vars are a_1 and a_4:++  2. Use tidyFreeTyCoVars to tidy them (workhorse: `tidyFreeCoVarX`)+     In our example:+      * a_4 already has a tidy form, a1, so don't change that+      * a_1 gets tidied to a2++  3. Trim the TidyOccEnv to OccNames of the tidied free vars (`trimTidyEnv`)+     In our example "a1" and "a2"++  4. Now tidy the types.  In our example we get+      [a2, forall a3. Maybe (a3,a1), forall b. (b, a2)]++Note [Tidying is idempotent]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Key invariant: tidyFreeTyCoVars is idempotent, at least if you start with+an empty TidyEnv. This is important because:++  * The typechecker error message processing carefully tidies types, using+    global knowledge; see for example calls to `tidyCt` in GHC.Tc.Errors.++  * Then the type pretty-printer, GHC.Core.TyCo.Ppr.pprType tidies the type+    again, because that's important for pretty-printing types in general.++But the second tidying is a no-op if the first step has happened, because+all the free vars will have distinct OccNames, so no renaming needs to happen.++Note [tidyAvoiding]+~~~~~~~~~~~~~~~~~~~+Consider tidying this unsolved constraint in GHC.Tc.Errors.report_unsolved.+    C a_33, (forall a. Eq a => D a)+Here a_33 is a free unification variable.  If we firs tidy [a_33 :-> "a"]+then we have no choice but to tidy the `forall a` to something else. But it+is confusing (sometimes very confusing) to gratuitously rename skolems in+this way -- see #24868.  So it is better to :++  * Find the /bound/ skolems (just `a` in this case)+  * Initialise the TidyOccEnv to avoid using "a"+  * Now tidy the free a_33 to, say, "a1"+  * Delete "a" from the TidyOccEnv++This is done by `tidyAvoiding`.++The last step is very important; if we leave "a" in the TidyOccEnv, when+we get to the (forall a. blah) we'll rename `a` to "a2", avoiding "a".+-}++-- | This tidies up a type for printing in an error message, or in+-- an interface file.+--+-- It doesn't change the uniques at all, just the print names.+tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+tidyVarBndrs tidy_env tvs+  = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs++tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+tidyVarBndr tidy_env@(occ_env, subst) var+  = case tidyOccName occ_env (getHelpfulOccName var) of+      (occ_env', occ') -> ((occ_env', subst'), var')+        where+          subst' = extendVarEnv subst var var'+          var'   = updateVarType (tidyType tidy_env) (setVarName var name')+          name'  = tidyNameOcc name occ'+          name   = varName var++avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv+-- Seed the occ_env with clashes among the names, see+-- Note [Tidying multiple names at once] in GHC.Types.Name.Occurrence+avoidNameClashes tvs (occ_env, subst)+  = (avoidClashesOccEnv occ_env occs, subst)+  where+    occs = map getHelpfulOccName tvs++getHelpfulOccName :: TyCoVar -> OccName+-- A TcTyVar with a System Name is probably a+-- unification variable; when we tidy them we give them a trailing+-- "0" (or 1 etc) so that they don't take precedence for the+-- un-modified name. Plus, indicating a unification variable in+-- this way is a helpful clue for users+getHelpfulOccName tv+  | isSystemName name, isTcTyVar tv+  = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0")+  | otherwise+  = occ+  where+   name = varName tv+   occ  = getOccName name++tidyForAllTyBinder :: TidyEnv -> VarBndr TyCoVar vis+                  -> (TidyEnv, VarBndr TyCoVar vis)+tidyForAllTyBinder tidy_env (Bndr tv vis)+  = (tidy_env', Bndr tv' vis)+  where+    (tidy_env', tv') = tidyVarBndr tidy_env tv++tidyForAllTyBinders :: TidyEnv -> [VarBndr TyCoVar vis]+                   -> (TidyEnv, [VarBndr TyCoVar vis])+tidyForAllTyBinders tidy_env tvbs+  = mapAccumL tidyForAllTyBinder+              (avoidNameClashes (binderVars tvbs) tidy_env) tvbs++---------------+tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv+-- ^ Add the free 'TyVar's to the env in tidy form,+-- so that we can tidy the type they are free in+-- Precondition: input free vars are closed over kinds and+-- This function does a scopedSort, so that tidied variables+-- have tidied kinds.+-- See Note [Tidying is idempotent]+tidyFreeTyCoVars tidy_env tyvars = fst (tidyFreeTyCoVarsX tidy_env tyvars)++---------------+tidyFreeTyCoVarsX :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])+-- Precondition: input free vars are closed over kinds and+-- This function does a scopedSort, so that tidied variables+-- have tidied kinds.+-- See Note [Tidying is idempotent]+tidyFreeTyCoVarsX env tyvars = mapAccumL tidyFreeTyCoVarX env $+                               scopedSort tyvars++---------------+tidyFreeTyCoVarX :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name+-- using the environment if one has not already been allocated. See+-- also 'tidyVarBndr'+-- See Note [Tidying is idempotent]+tidyFreeTyCoVarX env@(_, subst) tyvar+  = case lookupVarEnv subst tyvar of+        Just tyvar' -> (env, tyvar')           -- Already substituted+        Nothing     -> tidyVarBndr env tyvar  -- Treat it as a binder++---------------+tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar+tidyTyCoVarOcc env@(_, subst) tcv+  = case lookupVarEnv subst tcv of+        Nothing   -> updateVarType (tidyType env) tcv+        Just tcv' -> tcv'++---------------++{-+Note [Strictness in tidyType and friends]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Since the result of tidying will be inserted into the HPT, a potentially+long-lived structure, we generally want to avoid pieces of the old AST+being retained by the thunks produced by tidying.++For this reason we take great care to ensure that all pieces of the tidied AST+are evaluated strictly.  So you will see lots of strict applications ($!) and+uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`.++In the case of tidying of lists (e.g. lists of arguments) we prefer to use+`strictMap f xs` rather than `seqList (map f xs)` as the latter will+unnecessarily allocate a thunk, which will then be almost-immediately+evaluated, for each list element.++Making `tidyType` strict has a rather large effect on performance: see #14738.+Sometimes as much as a 5% reduction in allocation.+-}++-- | Tidy a list of Types+--+-- See Note [Strictness in tidyType and friends]+tidyTypes :: TidyEnv -> [Type] -> [Type]+tidyTypes env tys = strictMap (tidyType env) tys++---------------+++-- | Tidy a Type+--+-- See Note [Strictness in tidyType and friends]+tidyType :: TidyEnv -> Type -> Type+tidyType _   t@(LitTy {})           = t -- Preserve sharing+tidyType env (TyVarTy tv)           = TyVarTy $! tidyTyCoVarOcc env tv+tidyType _   t@(TyConApp _ [])      = t -- Preserve sharing if possible+tidyType env (TyConApp tycon tys)   = TyConApp tycon $! tidyTypes env tys+tidyType env (AppTy fun arg)        = (AppTy $! (tidyType env fun)) $! (tidyType env arg)+tidyType env (CastTy ty co)         = (CastTy $! tidyType env ty) $! (tidyCo env co)+tidyType env (CoercionTy co)        = CoercionTy $! (tidyCo env co)+tidyType env ty@(FunTy _ w arg res) = let { !w'   = tidyType env w+                                          ; !arg' = tidyType env arg+                                          ; !res' = tidyType env res }+                                      in ty { ft_mult = w', ft_arg = arg', ft_res = res' }+tidyType env (ty@(ForAllTy{}))      = tidyForAllType env ty+++tidyForAllType :: TidyEnv -> Type -> Type+tidyForAllType env ty+   = (mkForAllTys' $! (zip tcvs' vis)) $! tidyType body_env body_ty+  where+    (tcvs, vis, body_ty) = splitForAllTyCoVars' ty+    (body_env, tcvs') = tidyVarBndrs env tcvs++-- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that+-- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but+-- how should they be named?+mkForAllTys' :: [(TyCoVar, ForAllTyFlag)] -> Type -> Type+mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs+  where+    strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty++splitForAllTyCoVars' :: Type -> ([TyCoVar], [ForAllTyFlag], Type)+splitForAllTyCoVars' ty = go ty [] []+  where+    go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)+    go ty                          tvs viss = (reverse tvs, reverse viss, ty)+++---------------+tidyAvoiding :: [OccName]+             -> (TidyEnv -> a -> TidyEnv)+             -> a -> TidyEnv+-- Initialise an empty TidyEnv with some bound vars to avoid,+-- run the do_tidy function, and then remove the bound vars again.+-- See Note [tidyAvoiding]+tidyAvoiding bound_var_avoids do_tidy thing+  = (occs' `delTidyOccEnvList` bound_var_avoids, vars')+  where+    (occs', vars') = do_tidy init_tidy_env thing+    init_tidy_env  = mkEmptyTidyEnv (initTidyOccEnv bound_var_avoids)++---------------+trimTidyEnv :: TidyEnv -> [TyCoVar] -> TidyEnv+trimTidyEnv (occ_env, var_env) tcvs+  = (trimTidyOccEnv occ_env (map getOccName tcvs), var_env)++---------------+-- | Grabs the free type variables, tidies them+-- and then uses 'tidyType' to work over the type itself+tidyOpenTypesX :: TidyEnv -> [Type] -> (TidyEnv, [Type])+-- See Note [Tidying open types]+tidyOpenTypesX env tys+  = (env1, tidyTypes inner_env tys)+  where+    free_tcvs :: [TyCoVar] -- Closed over kinds+    free_tcvs          = tyCoVarsOfTypesList tys+    (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs+    inner_env          = trimTidyEnv env1 free_tcvs'++---------------+tidyOpenTypeX :: TidyEnv -> Type -> (TidyEnv, Type)+-- See Note [Tidying open types]+tidyOpenTypeX env ty+  = (env1, tidyType inner_env ty)+  where+    free_tcvs          = tyCoVarsOfTypeList ty+    (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs+    inner_env          = trimTidyEnv env1 free_tcvs'++---------------+tidyOpenTypes :: TidyEnv -> [Type] -> [Type]+tidyOpenTypes env ty = snd (tidyOpenTypesX env ty)++tidyOpenType :: TidyEnv -> Type -> Type+tidyOpenType env ty = snd (tidyOpenTypeX env ty)++---------------+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)+tidyTopType :: Type -> Type+tidyTopType ty = tidyType emptyTidyEnv ty++---------------++-- | Tidy a Coercion+--+-- See Note [Strictness in tidyType and friends]+tidyCo :: TidyEnv -> Coercion -> Coercion+tidyCo env co+  = go co+  where+    go_mco MRefl    = MRefl+    go_mco (MCo co) = MCo $! go co++    go (Refl ty)             = Refl $! tidyType env ty+    go (GRefl r ty mco)      = (GRefl r $! tidyType env ty) $! go_mco mco+    go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos+    go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2+    go (ForAllCo tv visL visR h co)+      = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)+      where (envp, tvp) = tidyVarBndr env tv+            -- the case above duplicates a bit of work in tidying h and the kind+            -- of tv. But the alternative is to use coercionKind, which seems worse.+    go (FunCo r afl afr w co1 co2) = ((FunCo r afl afr $! go w) $! go co1) $! go co2+    go (CoVarCo cv)          = CoVarCo $! go_cv cv+    go (HoleCo h)            = HoleCo $! go_hole h+    go (AxiomCo ax cos)      = AxiomCo ax $ strictMap go cos+    go (UnivCo prov role t1 t2 cos)+                             = ((UnivCo prov role+                                $! tidyType env t1)+                                $! tidyType env t2)+                                $! strictMap go cos+    go (SymCo co)            = SymCo $! go co+    go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2+    go (SelCo d co)          = SelCo d $! go co+    go (LRCo lr co)          = LRCo lr $! go co+    go (InstCo co ty)        = (InstCo $! go co) $! go ty+    go (KindCo co)           = KindCo $! go co+    go (SubCo co)            = SubCo $! go co++    go_cv cv = tidyTyCoVarOcc env cv++    go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r+    -- Tidy even the holes; tidied types should have tidied kinds++tidyCos :: TidyEnv -> [Coercion] -> [Coercion]+tidyCos env = strictMap (tidyCo env)
+ GHC/Core/TyCon.hs view
@@ -0,0 +1,3188 @@+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @TyCon@ datatype+-}++module GHC.Core.TyCon(+        -- * Main TyCon data types+        TyCon,+        AlgTyConRhs(..), visibleDataCons,+        AlgTyConFlav(..), isNoParent,+        FamTyConFlav(..), Role(..), Injectivity(..),+        PromDataConInfo(..), TyConFlavour(..),++        -- * TyConBinder+        TyConBinder, TyConBndrVis(..),+        mkNamedTyConBinder, mkNamedTyConBinders,+        mkRequiredTyConBinder,+        mkAnonTyConBinder, mkAnonTyConBinders,+        tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,+        isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder,+        isInferredTyConBinder,+        isVisibleTcbVis, isInvisSpecTcbVis,++        -- ** Field labels+        tyConFieldLabels, lookupTyConFieldLabel,++        -- ** Constructing TyCons+        mkAlgTyCon,+        mkClassTyCon,+        mkPrimTyCon,+        mkTupleTyCon,+        mkSumTyCon,+        mkDataTyConRhs,+        mkLevPolyDataTyConRhs,+        mkSynonymTyCon,+        mkFamilyTyCon,+        mkPromotedDataCon,+        mkTcTyCon,+        noTcTyConScopedTyVars,++        -- ** Predicates on TyCons+        isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,+        isUnaryClassTyCon, isUnaryClassTyCon_maybe,+        isFamInstTyCon,+        isPrimTyCon,+        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,+        isUnboxedSumTyCon, isPromotedTupleTyCon,+        isLiftedAlgTyCon,+        isTypeSynonymTyCon,+        tyConMustBeSaturated,+        isPromotedDataCon, isPromotedDataCon_maybe,+        isDataKindsPromotedDataCon,+        isKindTyCon, isKindName, isLiftedTypeKindTyConName,+        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,++        isBoxedDataTyCon,+        isTypeDataTyCon,+        isEnumerationTyCon,+        isNewTyCon, isAbstractTyCon,+        isFamilyTyCon, isOpenFamilyTyCon,+        isTypeFamilyTyCon, isDataFamilyTyCon,+        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,+        tyConInjectivityInfo,+        isBuiltInSynFamTyCon_maybe,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon,+        isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,+        isImplicitTyCon,+        isTyConWithSrcDataCons,+        isTcTyCon, setTcTyConKind,+        tcHasFixedRuntimeRep,+        isConcreteTyCon,+        isValidDTT2TyCon,++        -- ** Extracting information out of TyCons+        tyConName,+        tyConSkolem,+        tyConKind,+        tyConUnique,+        tyConTyVars, tyConVisibleTyVars,+        tyConCType_maybe,+        tyConDataCons, tyConDataCons_maybe,+        tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConFamilySize,+        tyConStupidTheta,+        tyConArity,+        tyConNullaryTy, mkTyConTy,+        tyConRoles,+        tyConFlavour,+        tyConTuple_maybe, tyConClass_maybe, tyConATs,+        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,+        tyConFamilyResVar_maybe,+        synTyConDefn_maybe, synTyConRhs_maybe,+        famTyConFlav_maybe,+        algTyConRhs,+        newTyConRhs, newTyConEtadArity, newTyConEtadRhs,+        unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,+        newTyConDataCon_maybe,+        algTcFields,+        tyConPromDataConInfo,+        tyConBinders, tyConResKind, tyConInvisTVBinders,+        tcTyConScopedTyVars, isMonoTcTyCon,+        tyConHasClosedResKind,+        mkTyConTagMap,++        -- ** Manipulating TyCons+        ExpandSynResult(..),+        expandSynTyCon_maybe,+        newTyConCo, newTyConCo_maybe,+        pprPromotionQuote, mkTyConKind,++        -- ** Predicated on TyConFlavours+        tcFlavourIsOpen,++        -- * Runtime type representation+        TyConRepName, tyConRepName_maybe,+        mkPrelTyConRepName,+        tyConRepModOcc,++        -- * Primitive representations of Types+        PrimRep(..), PrimElemRep(..), Levity(..),+        PrimOrVoidRep(..),+        primElemRepToPrimRep,+        isGcPtrRep,+        primRepSizeB, primRepSizeW64_B,+        primElemRepSizeB, primElemRepSizeW64_B,+        primRepIsFloat,+        primRepsCompatible,+        primRepCompatible,+        primRepIsWord,+        primRepIsInt,++) where++import GHC.Prelude+import GHC.Platform++import {-# SOURCE #-} GHC.Core.TyCo.Rep+   ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy )+import {-# SOURCE #-} GHC.Core.TyCo.FVs+   ( noFreeVarsOfType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr+   ( pprType )+import {-# SOURCE #-} GHC.Builtin.Types+   ( runtimeRepTyCon, constraintKind, levityTyCon+   , multiplicityTyCon+   , vecCountTyCon, vecElemTyCon )+import {-# SOURCE #-} GHC.Core.DataCon+   ( DataCon, dataConFieldLabels+   , dataConTyCon, dataConFullSig+   , isUnboxedSumDataCon, isTypeDataCon )+import {-# SOURCE #-} GHC.Core.Type+   ( isLiftedTypeKind )+import GHC.Builtin.Uniques+  ( tyConRepNameUnique+  , dataConTyRepNameUnique )++import GHC.Utils.Binary+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.Class+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Core.Coercion.Axiom+import GHC.Builtin.Names+import GHC.Data.Maybe+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString.Env+import GHC.Types.FieldLabel+import GHC.Settings.Constants+import GHC.Utils.Misc+import GHC.Types.Unique.Set+import GHC.Unit.Module+import Control.DeepSeq++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import qualified Data.Data as Data++{-+-----------------------------------------------+        Notes about type families+-----------------------------------------------++Note [Type synonym families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Type synonym families, also known as "type functions", map directly+  onto the type functions in FC:++        type family F a :: Type+        type instance F Int = Bool+        ..etc...++* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon++* From the user's point of view (F Int) and Bool are simply+  equivalent types.++* A Haskell 98 type synonym is a degenerate form of a type synonym+  family.++* Type functions can't appear in the LHS of a type function:+        type instance F (F Int) = ...   -- BAD!++* Translation of type family decl:+        type family F a :: Type+  translates to+    a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon++        type family G a :: Type where+          G Int = Bool+          G Bool = Char+          G a = ()+  translates to+    a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the+    appropriate CoAxiom representing the equations++We also support injective type families -- see Note [Injective type families]++Note [Data type families]+~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make++* Data type families are declared thus+        data family T a :: Type+        data instance T Int = T1 | T2 Bool++  Here T is the "family TyCon".++* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon++* The user does not see any "equivalent types" as they did with type+  synonym families.  They just see constructors with types+        T1 :: T Int+        T2 :: Bool -> T Int++* Here's the FC version of the above declarations:++        data T a+        data R:TInt = T1 | T2 Bool+        axiom ax_ti : T Int ~R R:TInt++  Note that this is a *representational* coercion+  The R:TInt is the "representation TyCons".+  It has an AlgTyConFlav of+        DataFamInstTyCon T [Int] ax_ti++* The axiom ax_ti may be eta-reduced; see+  Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom++* Data family instances may have a different arity than the data family.+  See Note [Arity of data families] in GHC.Core.FamInstEnv++* The data constructor T2 has a wrapper (which is what the+  source-level "T2" invokes):++        $WT2 :: Bool -> T Int+        $WT2 b = T2 b `cast` sym ax_ti++* A data instance can declare a fully-fledged GADT:++        data instance T (a,b) where+          X1 :: T (Int,Bool)+          X2 :: a -> b -> T (a,b)++  Here's the FC version of the above declaration:++        data R:TPair a b where+          X1 :: R:TPair Int Bool+          X2 :: a -> b -> R:TPair a b+        axiom ax_pr :: T (a,b)  ~R  R:TPair a b++        $WX1 :: forall a b. a -> b -> T (a,b)+        $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b)++  The R:TPair are the "representation TyCons".+  We have a bit of work to do, to unpick the result types of the+  data instance declaration for T (a,b), to get the result type in the+  representation; e.g.  T (a,b) --> R:TPair a b++  The representation TyCon R:TList, has an AlgTyConFlav of++        DataFamInstTyCon T [(a,b)] ax_pr++* Notice that T is NOT translated to a FC type function; it just+  becomes a "data type" with no constructors, which can be coerced+  into R:TInt, R:TPair by the axioms.  These axioms+  axioms come into play when (and *only* when) you+        - use a data constructor+        - do pattern matching+  Rather like newtype, in fact++  As a result++  - T behaves just like a data type so far as decomposition is concerned++  - (T Int) is not implicitly converted to R:TInt during type inference.+    Indeed the latter type is unknown to the programmer.++  - There *is* an instance for (T Int) in the type-family instance+    environment, but it is looked up (via tcLookupDataFamilyInst)+    in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to+    solve representational equalities like+         T Int ~R# Bool+    Here we look up (T Int), convert it to R:TInt, and then unwrap the+    newtype R:TInt.++    It is also looked up in reduceTyFamApp_maybe.++  - It's fine to have T in the LHS of a type function:+    type instance F (T a) = [a]++  It was this last point that confused me!  The big thing is that you+  should not think of a data family T as a *type function* at all, not+  even an injective one!  We can't allow even injective type functions+  on the LHS of a type function:+        type family injective G a :: Type+        type instance F (G Int) = Bool+  is no good, even if G is injective, because consider+        type instance G Int = Bool+        type instance F Bool = Char++  So a data type family is not an injective type function. It's just a+  data type with some axioms that connect it to other data types.++* The tyConTyVars of the representation tycon are the tyvars that the+  user wrote in the patterns. This is important in GHC.Tc.Deriv, where we+  bring these tyvars into scope before type-checking the deriving+  clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl.++Note [Associated families and their parent class]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Associated* families are just like *non-associated* families, except+that they have a famTcParent field of (Just cls_tc), which identifies the+parent class.++However there is an important sharing relationship between+  * the tyConTyVars of the parent Class+  * the tyConTyVars of the associated TyCon++   class C a b where+     data T p a+     type F a q b++Here the 'a' and 'b' are shared with the 'Class'; that is, they have+the same Unique.++This is important. In an instance declaration we expect+  * all the shared variables to be instantiated the same way+  * the non-shared variables of the associated type should not+    be instantiated at all++  instance C [x] (Tree y) where+     data T p [x] = T1 x | T2 p+     type F [x] q (Tree y) = (x,y,q)++Note [TyCon Role signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every tycon has a role signature, assigning a role to each of the tyConTyVars+(or of equal length to the tyConArity, if there are no tyConTyVars). An+example demonstrates these best: say we have a tycon T, with parameters a at+nominal, b at representational, and c at phantom. Then, to prove+representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have+nominal equality between a1 and a2, representational equality between b1 and+b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This+might happen, say, with the following declaration:++  data T a b c where+    MkT :: b -> T Int b c++Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils),+as do vanilla synonym tycons. Family tycons have all parameters at role N,+though it is conceivable that we could relax this restriction. (->)'s and+tuples' parameters are at role R. Each primitive tycon declares its roles;+it's worth noting that (~#)'s parameters are at role N. Promoted data+constructors' type arguments are at role R. All kind arguments are at role+N.++Note [Unboxed tuple RuntimeRep vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The contents of an unboxed tuple may have any representation. Accordingly,+the kind of the unboxed tuple constructor is runtime-representation+polymorphic.++Type constructor (2 kind arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep).+                   TYPE q -> TYPE r -> TYPE (TupleRep [q, r])+Data constructor (4 type arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep)+                   (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #)++These extra tyvars (q and r) cause some delicate processing around tuples,+where we need to manually insert RuntimeRep arguments.+The same situation happens with unboxed sums: each alternative+has its own RuntimeRep.+For boxed tuples, there is no representation polymorphism, and therefore+we add RuntimeReps only for the unboxed version.++Type constructor (no kind arguments)+   (,) :: Type -> Type -> Type+Data constructor (2 type arguments)+   (,) :: forall a b. a -> b -> (a, b)+++Note [Injective type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow injectivity annotations for type families (both open and closed):++  type family F (a :: k) (b :: k) = r | r -> a+  type family G a b = res | res -> a b where ...++Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`.+`famTcInj` maybe stores a list of Bools, where each entry corresponds to a+single element of `tyConTyVars` (both lists should have identical length). If no+injectivity annotation was provided `famTcInj` is Nothing. From this follows an+invariant that if `famTcInj` is a Just then at least one element in the list+must be True.++See also:+ * [Injectivity annotation] in GHC.Hs.Decls+ * [Renaming injectivity annotation] in GHC.Rename.Module+ * [Verifying injectivity annotation] in GHC.Core.FamInstEnv+ * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality++Note [Sharing nullary TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nullary type constructor applications are extremely common. For this reason+each TyCon carries with it a @TyConApp tycon []@. This ensures that+'mkTyConTy' does not need to allocate and eliminates quite a bit of heap+residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp',+ensuring that this function also benefits from sharing.++This optimisation improves allocations in the Cabal test by around 0.3% and+decreased cache misses measurably.++See #19367.+++************************************************************************+*                                                                      *+                    TyConBinder+*                                                                      *+************************************************************************+-}++type TyConBinder     = VarBndr TyVar   TyConBndrVis++data TyConBndrVis+  = NamedTCB ForAllTyFlag  -- ^ A named, forall-bound variable (invisible or not)+  | AnonTCB                -- ^ an ordinary, visible type argument++instance Outputable TyConBndrVis where+  ppr (NamedTCB flag) = ppr flag+  ppr AnonTCB         = text "AnonTCB"++mkAnonTyConBinder :: TyVar -> TyConBinder+-- Make a visible anonymous TyCon binder+mkAnonTyConBinder tv = assert (isTyVar tv) $+                       Bndr tv AnonTCB++mkAnonTyConBinders :: [TyVar] -> [TyConBinder]+mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs++mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder+-- The odd argument order supports currying+mkNamedTyConBinder vis tv = assert (isTyVar tv) $+                            Bndr tv (NamedTCB vis)++mkNamedTyConBinders :: ForAllTyFlag -> [TyVar] -> [TyConBinder]+-- The odd argument order supports currying+mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs++-- | Make a Required TyConBinder. It chooses between NamedTCB and+-- AnonTCB based on whether the tv is mentioned in the dependent set+mkRequiredTyConBinder :: TyCoVarSet  -- these are used dependently+                      -> TyVar+                      -> TyConBinder+mkRequiredTyConBinder dep_set tv+  | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv+  | otherwise               = mkAnonTyConBinder tv++tyConBinderForAllTyFlag :: VarBndr a TyConBndrVis -> ForAllTyFlag+tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis++tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag+tyConBndrVisForAllTyFlag (NamedTCB vis) = vis+tyConBndrVisForAllTyFlag AnonTCB        = Required++isNamedTyConBinder :: TyConBinder -> Bool+-- Identifies kind variables+-- E.g. data T k (a:k) = blah+-- Here 'k' is a NamedTCB, a variable used in the kind of other binders+isNamedTyConBinder (Bndr _ (NamedTCB {})) = True+isNamedTyConBinder _                      = False++isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis++isVisibleTcbVis :: TyConBndrVis -> Bool+isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis+isVisibleTcbVis AnonTCB        = True++isInvisSpecTcbVis :: TyConBndrVis -> Bool+isInvisSpecTcbVis (NamedTCB Specified) = True+isInvisSpecTcbVis _                    = False++isInvisInferTcbVis :: TyConBndrVis -> Bool+isInvisInferTcbVis (NamedTCB Inferred) = True+isInvisInferTcbVis _                   = False++isInvisSpecTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisSpecTyConBinder (Bndr _ tcb_vis) = isInvisSpecTcbVis tcb_vis++isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)++isInferredTyConBinder :: VarBndr var TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInferredTyConBinder (Bndr _ tcb_vis) = isInvisInferTcbVis tcb_vis++-- Build the 'tyConKind' from the binders and the result kind.+-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type.+mkTyConKind :: [TyConBinder] -> Kind -> Kind+mkTyConKind bndrs res_kind = foldr mk res_kind bndrs+  where+    mk :: TyConBinder -> Kind -> Kind+    mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k+    mk (Bndr tv AnonTCB)        k = mkNakedFunTy FTF_T_T (varType tv) k+    -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types++-- | (mkTyConTy tc) returns (TyConApp tc [])+-- but arranges to share that TyConApp among all calls+-- See Note [Sharing nullary TyConApps]+-- So it's just an alias for tyConNullaryTy!+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = tyConNullaryTy tycon++tyConInvisTVBinders :: [TyConBinder]   -- From the TyCon+                    -> [InvisTVBinder] -- Suitable for the foralls of a term function+-- See Note [Building TyVarBinders from TyConBinders]+tyConInvisTVBinders tc_bndrs+ = map mk_binder tc_bndrs+ where+   mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv+      where+        vis = case tc_vis of+                AnonTCB                  -> SpecifiedSpec+                NamedTCB Required        -> SpecifiedSpec+                NamedTCB (Invisible vis) -> vis++-- Returns only tyvars, as covars are always inferred+tyConVisibleTyVars :: TyCon -> [TyVar]+tyConVisibleTyVars tc+  = [ tv | Bndr tv vis <- tyConBinders tc+         , isVisibleTcbVis vis ]++{- Note [Building TyVarBinders from TyConBinders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We sometimes need to build the quantified type of a value from+the TyConBinders of a type or class.  For that we need not+TyConBinders but TyVarBinders (used in forall-type)  E.g:++ *  From   data T a = MkT (Maybe a)+    we are going to make a data constructor with type+           MkT :: forall a. Maybe a -> T a+    See the ForAllTyBinders passed to buildDataCon++ * From    class C a where { op :: a -> Maybe a }+   we are going to make a default method+           $dmop :: forall a. C a => a -> Maybe a+   See the ForAllTyBinders passed to mkSigmaTy in mkDefaultMethodType++Both of these are user-callable.  (NB: default methods are not callable+directly by the user but rather via the code generated by 'deriving',+which uses visible type application; see mkDefMethBind.)++Since they are user-callable we must get their type-argument visibility+information right; and that info is in the TyConBinders.+Here is an example:++  data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type++The TyCon has++  tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ]++The TyConBinders for App line up with App's kind, given above.++But the DataCon MkApp has the type+  MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b++That is, its ForAllTyBinders should be++  dataConUnivTyVarBinders = [ Bndr (k:Type)    Inferred+                            , Bndr (a:k->Type) Specified+                            , Bndr (b:k)    Specified ]++So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:+  - variable names from the TyConBinders+  - but changing Anon/Required to Specified++The last part about Required->Specified comes from this:+  data T k (a :: k) b = MkT (a b)+Here k is Required in T's kind, but we didn't have Required binders in+types of terms before the advent of the new, experimental RequiredTypeArguments+extension. So we historically changed Required to Specified when making MkT's PiTyBinders+and now continue to do so to avoid a breaking change.+-}+++{- Note [The binders/kind/arity fields of a TyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All TyCons have this group of fields+  tyConBinders   :: [TyConBinder]+  tyConResKind   :: Kind+  tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders+                              --   NB: Currently (Aug 2018), TyCons that own this+                              --   field really only contain TyVars. So it is+                              --   [TyVar] instead of [TyCoVar].+  tyConKind      :: Kind      -- Cached = mkTyConKind tyConBinders tyConResKind+  tyConArity     :: Arity     -- Cached = length tyConBinders++They fit together like so:++* tyConBinders gives the telescope of type variables on the LHS of the+  type declaration.  For example:++    type App a (b :: k) = a b++  tyConBinders = [ Bndr (k::Type)   (NamedTCB Inferred)+                 , Bndr (a:k->Type) AnonTCB+                 , Bndr (b:k)    AnonTCB ]++  Note that there are three binders here, including the+  kind variable k.++  See Note [tyConBinders and lexical scoping]++* See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep+  for what the visibility flag means.++* Each TyConBinder in tyConBinders has a TyVar, and+  that TyVar may scope over some other part of the TyCon's definition. Eg+      type T a = a -> a+  we have+      tyConBinders = [ Bndr (a:Type) AnonTCB ]+      synTcRhs     = a -> a+  So the 'a' scopes over the synTcRhs++* From the tyConBinders and tyConResKind we can get the tyConKind+  E.g for our App example:+      App :: forall k. (k->Type) -> k -> Type++  We get a 'forall' in the kind for each NamedTCB, and an arrow+  for each AnonTCB++  tyConKind is the full kind of the TyCon, not just the result kind++* For type families, tyConArity is the arguments this TyCon must be+  applied to, to be considered saturated.  Here we mean "applied to in+  the actual Type", not surface syntax; i.e. including implicit kind+  variables.  So it's just (length tyConBinders)++* For an algebraic data type, or data instance, the tyConResKind is+  always (TYPE r); that is, the tyConBinders are enough to saturate+  the type constructor.  I'm not quite sure why we have this invariant,+  but it's enforced by splitTyConKind++Note [tyConBinders and lexical scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a TyCon, and a PolyTcTyCon, we obey the following rule:++   The Name of the TyConBinder is precisely+       the lexically scoped Name from the original declaration+       (precisely = both OccName and Unique)++For example,+   data T a (b :: wombat) = MkT+We will get tyConBinders of [k, wombat, a::k, b::wombat]+The 'k' is made up; the user didn't specify it.  But for the kind of 'b'+we must use 'wombat'.++Why do we have this invariant?++* Similarly, when typechecking default definitions for class methods, in+  GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available;+  but the variables bound in that class must be in scope.  Example (#19738):++    type P :: k -> Type+    data P a = MkP++    type T :: k -> Constraint+    class T (a :: j) where+      f :: P a+      f = MkP @j @a  -- 'j' must be in scope when we typecheck 'f'++* When typechecking `deriving` clauses for top-level data declarations, the+  tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs`+  field of GHC.Tc.Deriv.DerivInfo. Example (#16731):++    class C x1 x2++    type T :: a -> Type+    data T (x :: z) deriving (C z)++  When typechecking `C z`, we want `z` to map to `a`, which is exactly what the+  tcTyConScopedTyVars for T give us.+-}++instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where+  ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v)++instance Binary TyConBndrVis where+  put_ bh AnonTCB        = do { putByte bh 0 }+  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> return AnonTCB+                  _ -> do { vis <- get bh; return (NamedTCB vis) } }++instance NFData TyConBndrVis where+  rnf AnonTCB        = ()+  rnf (NamedTCB vis) = rnf vis++++{- *********************************************************************+*                                                                      *+               The TyCon type+*                                                                      *+************************************************************************+-}+++-- | TyCons represent type constructors. Type constructors are introduced by+-- things such as:+--+-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of+--    kind @Type@+--+-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor+--+-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor+--    of kind @Type -> Type@+--+-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor+--    of kind @Constraint@+--+-- This data type also encodes a number of primitive, built in type constructors+-- such as those for function and tuple types.+--+-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data TyCon = TyCon {+        tyConUnique  :: !Unique,  -- ^ A Unique of this TyCon. Invariant:+                                  -- identical to Unique of Name stored in+                                  -- tyConName field.++        tyConName    :: !Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders          :: [TyConBinder],   -- ^ Full binders+        tyConResKind          :: Kind,             -- ^ Result kind+        tyConHasClosedResKind :: Bool,++        -- Cached values+        tyConTyVars    :: [TyVar],       -- ^ TyVar binders+        tyConKind      :: Kind,          -- ^ Kind of this TyCon+        tyConArity     :: Arity,         -- ^ Arity+        tyConNullaryTy :: Type,          -- ^ A pre-allocated @TyConApp tycon []@++        tyConRoles :: [Role],  -- ^ The role for each type variable+                               -- This list has length = tyConArity+                               -- See also Note [TyCon Role signatures]++        tyConDetails :: !TyConDetails }++data TyConDetails =+  -- | Algebraic data types, from+  --     - @data@ declarations+  --     - @newtype@ declarations+  --     - data instance declarations+  --     - type instance declarations+  --     - the TyCon generated by a class declaration+  --     - boxed tuples+  --     - unboxed tuples+  --     - constraint tuples+  --     - unboxed sums+  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.+  -- See 'AlgTyConRhs' for more information.+    AlgTyCon {+              -- The tyConTyVars scope over:+              --+              -- 1. The 'algTcStupidTheta'+              -- 2. The cached types in algTyConRhs.NewTyCon+              -- 3. The family instance types if present+              --+              -- Note that it does /not/ scope over the data+              -- constructors.++        tyConCType   :: Maybe CType,-- ^ The C type that should be used+                                    -- for this type when using the FFI+                                    -- and CAPI++        algTcGadtSyntax  :: Bool,   -- ^ Was the data type declared with GADT+                                    -- syntax?  If so, that doesn't mean it's a+                                    -- true GADT; only that the "where" form+                                    -- was used.  This field is used only to+                                    -- guide pretty-printing++        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data+                                        -- type (always empty for GADTs).  A+                                        -- \"stupid theta\" is the context to+                                        -- the left of an algebraic type+                                        -- declaration, e.g. @Eq a@ in the+                                        -- declaration @data Eq a => T a ...@.+                                        -- See @Note [The stupid context]@ in+                                        -- "GHC.Core.DataCon".++        algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the+                                    -- data constructors of the algebraic type++        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information+                                      -- about the field++        algTcFlavour :: AlgTyConFlav   -- ^ The flavour of this algebraic tycon.+                                       -- Gives the class or family declaration+                                       -- 'TyCon' for derived 'TyCon's representing+                                       -- class or family instances, respectively.++    }++  -- | Represents type synonyms+  | SynonymTyCon {+             -- tyConTyVars scope over: synTcRhs++        synTcRhs     :: Type,    -- ^ Contains information about the expansion+                                 -- of the synonym++        synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not+                                 --          have any foralls, after expanding any+                                 --          nested synonyms+        synIsFamFree  :: Bool,   -- True <=> the RHS of this synonym does not mention+                                 --          any type synonym families (data families+                                 --          are fine), again after expanding any+                                 --          nested synonyms++        synIsForgetful :: Bool,  -- See Note [Forgetful type synonyms]+                                 -- True <=  at least one argument is not mentioned+                                 --          in the RHS (or is mentioned only under+                                 --          forgetful synonyms)+                                 -- Test is conservative, so True does not guarantee+                                 -- forgetfulness. False conveys definite information+                                 -- (definitely not forgetful); True is always safe.++        synIsConcrete :: Bool    -- True <= If 'tys' are concrete then the expansion+                                 --         of (S tys) is definitely concrete+                                 -- But False is always safe+    }++  -- | Represents families (both type and data)+  -- Argument roles are all Nominal+  | FamilyTyCon {+            -- tyConTyVars connect an associated family TyCon+            -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst++        famTcResVar  :: Maybe Name,   -- ^ Name of result type variable, used+                                      -- for pretty-printing with --show-iface+                                      -- and for reifying TyCon in Template+                                      -- Haskell++        famTcFlav    :: FamTyConFlav, -- ^ Type family flavour: open, closed,+                                      -- abstract, built-in. See comments for+                                      -- FamTyConFlav++        famTcParent  :: Maybe TyCon,  -- ^ For *associated* type/data families+                                      -- The class tycon in which the family is declared+                                      -- See Note [Associated families and their parent class]++        famTcInj     :: Injectivity   -- ^ is this a type family injective in+                                      -- its type variables? Nothing if no+                                      -- injectivity annotation was given+    }++  -- | Primitive types; cannot be defined in Haskell. This includes+  -- the usual suspects (such as @Int#@) as well as foreign-imported+  -- types and kinds (@*@, @#@, and @?@)+  | PrimTyCon {+        primRepName :: TyConRepName   -- ^ The 'Typeable' representation.+                                      -- A cached version of+                                      -- @'mkPrelTyConRepName' ('tyConName' tc)@.+    }++  -- | Represents promoted data constructor.+  -- The kind of a promoted data constructor is the *wrapper* type of+  -- the original data constructor. This type must not have constraints+  -- (as checked in GHC.Tc.Gen.HsType.tcTyVar).+  | PromotedDataCon {          -- See Note [Promoted data constructors]+        dataCon       :: DataCon,   -- ^ Corresponding data constructor+        tcRepName     :: TyConRepName,+        promDcInfo    :: PromDataConInfo  -- ^ See comments with 'PromDataConInfo'+    }++  -- | These exist only during type-checking.+  -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl"+  | TcTyCon {+          -- NB: the tyConArity of a TcTyCon must match+          -- the number of Required (positional, user-specified)+          -- arguments to the type constructor; see the use+          -- of tyConArity in generaliseTcTyCon++        tctc_scoped_tvs :: [(Name,TcTyVar)],+          -- ^ Scoped tyvars over the tycon's body+          -- The range is always a skolem or TcTyVar, be+          -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon]++        tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized?+                              -- Used only to make zonking more efficient++        tctc_flavour :: TyConFlavour TyCon+                           -- ^ What sort of 'TyCon' this represents.+      }++{- Note [Scoped tyvars in a TcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The tcTyConScopedTyVars field records the lexicial-binding connection+between the original, user-specified Name (i.e. thing in scope) and+the TcTyVar that the Name is bound to.++Order *does* matter; the tcTyConScopedTyVars list consists of+     specified_tvs ++ required_tvs++where+   * specified ones first+   * required_tvs the same as tyConTyVars+   * tyConArity = length required_tvs++tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons.+See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl++Note [Representation-polymorphic TyCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To check for representation-polymorphism directly in the typechecker,+e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep,+we need to compute whether a type has a syntactically fixed RuntimeRep,+as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++It's useful to have a quick way to check whether a saturated application+of a type constructor has a fixed RuntimeRep. That is, we want+to know, given a TyCon 'T' of arity 'n', does++  T a_1 ... a_n++always have a fixed RuntimeRep? That is, is it always the case+that this application has a kind of the form++  T a_1 ... a_n :: TYPE rep++in which 'rep' is a concrete 'RuntimeRep'?+('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete:+it contains no type-family applications or type variables.)++To answer this question, we have 'tcHasFixedRuntimeRep'.+If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that+every saturated application of `T` has a fixed RuntimeRep.+However, if it returns 'False', we don't know: perhaps some application might not+have a fixed RuntimeRep.++Examples:++  - For type families, we won't know in general whether an application+    will have a fixed RuntimeRep:++      type F :: k -> k+      type family F a where {..}++    `tcHasFixedRuntimeRep F = False'++  - For newtypes, we're usually OK:++      newtype N a b c = MkN Int++    No matter what arguments we apply `N` to, we always get something of+    kind `Type`, which has a fixed RuntimeRep.+    Thus `tcHasFixedRuntimeRep N = True`.++    However, with `-XUnliftedNewtypes`, we can have representation-polymorphic+    newtypes:++      type UN :: TYPE rep -> TYPE rep+      newtype UN a = MkUN a++    `tcHasFixedRuntimeRep UN = False`++    For example, `UN @Int8Rep Int8#` is represented by an 8-bit value,+    while `UN @LiftedRep Int` is represented by a heap pointer.++    To distinguish whether we are dealing with a representation-polymorphic newtype,+    we keep track of which situation we are in using the 'nt_fixed_rep'+    field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field+    to compute 'tcHasFixedRuntimeRep'.++  - A similar story can be told for datatypes: we're usually OK,+    except with `-XUnliftedDatatypes` which allows for levity polymorphism,+    e.g.:++      type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l)+      type UC a = MkUC a++    `tcHasFixedRuntimeRep UC = False`++    Here, we keep track of whether we are dealing with a levity-polymorphic+    unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon'+    constructor of 'AlgTyConRhs'.++    N.B.: technically, the representation of a datatype is fixed,+    as it is always a pointer. However, we currently require that we+    know the specific `RuntimeRep`: knowing that it's `BoxedRep l`+    for a type-variable `l` isn't enough. See #15532.+-}++-- | Represents right-hand-sides of 'TyCon's for algebraic types+data AlgTyConRhs++    -- | Says that we know nothing about this data type, except that+    -- it's represented by a pointer.  Used when we export a data type+    -- abstractly into an .hi file.+  = AbstractTyCon++    -- | Information about those 'TyCon's derived from a @data@+    -- declaration. This includes data types with no constructors at+    -- all.+  | DataTyCon {+        data_cons :: [DataCon],+                          -- ^ The data type constructors; can be empty if the+                          --   user declares the type to have no constructors+                          --+                          -- INVARIANT: Kept in order of increasing 'DataCon'+                          -- tag (see the tag assignment in mkTyConTagMap)+        data_cons_size :: Int,+                          -- ^ Cached value: length data_cons+        is_enum :: Bool,  -- ^ Cached value: is this an enumeration type?+                          --   See Note [Enumeration types]+        is_type_data :: Bool,+                        -- from a "type data" declaration+                        -- See Note [Type data declarations] in GHC.Rename.Module+        data_fixed_lev :: Bool+                        -- ^ 'True' if the data type constructor has+                        -- a known, fixed levity when fully applied+                        -- to its arguments, False otherwise.+                        --+                        -- This can only be 'False' with UnliftedDatatypes,+                        -- e.g.+                        --+                        -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A }+                        --+                        -- This boolean is cached to make it cheaper to check+                        -- for levity and representation-polymorphism in+                        -- tcHasFixedRuntimeRep.+    }++  | TupleTyCon {                   -- A boxed, unboxed, or constraint tuple+        data_con :: DataCon,       -- NB: it can be an *unboxed* tuple+        tup_sort :: TupleSort      -- ^ Is this a boxed, unboxed or constraint+                                   -- tuple?+    }++  -- | An unboxed sum type.+  | SumTyCon {+        data_cons :: [DataCon],+        data_cons_size :: Int  -- ^ Cached value: length data_cons+    }++  -- | Information about those 'TyCon's derived from a @newtype@ declaration+  | NewTyCon {+        data_con :: DataCon,    -- ^ The unique constructor for the @newtype@.+                                --   It has no existentials++        nt_rhs :: Type,         -- ^ Cached value: the argument type of the+                                -- constructor, which is just the representation+                                -- type of the 'TyCon' (remember that @newtype@s+                                -- do not exist at runtime so need a different+                                -- representation type).+                                --+                                -- The free 'TyVar's of this type are the+                                -- 'tyConTyVars' from the corresponding 'TyCon'++        nt_etad_rhs :: ([TyVar], Type),+                        -- ^ Same as the 'nt_rhs', but this time eta-reduced.+                        -- Hence the list of 'TyVar's in this field may be+                        -- shorter than the declared arity of the 'TyCon'.++                        -- See Note [Newtype eta]+        nt_co :: CoAxiom Unbranched,+                             -- The axiom coercion that creates the @newtype@+                             -- from the representation 'Type'.  The axiom witnesses+                             -- a representational coercion:+                             --   nt_co :: N ty1 ~R# rep_tys++                             -- See Note [Newtype coercions]+                             -- Invariant: arity = #tvs in nt_etad_rhs;+                             -- See Note [Newtype eta]+                             -- Watch out!  If any newtypes become transparent+                             -- again check #1072.+        nt_fixed_rep :: Bool+                        -- ^ 'True' if the newtype has a known, fixed representation+                        -- when fully applied to its arguments, 'False' otherwise.+                        -- This can only ever be 'False' with UnliftedNewtypes.+                        --+                        -- Example:+                        --+                        -- > newtype N (a :: TYPE r) = MkN a+                        --+                        -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt)+                        --+                        -- This boolean is cached to make it cheaper to check if a+                        -- variable binding is representation-polymorphic+                        -- in tcHasFixedRuntimeRep.+    }++  | UnaryClassTyCon {  -- See Note [Unary class magic], esp (UCM2)+                       -- INVARIANT: the algTcFlavour of this TyCon is ClassTyCon+      data_con :: DataCon+      }++mkSumTyConRhs :: [DataCon] -> AlgTyConRhs+mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons)++-- | Create an 'AlgTyConRhs' from the data constructors,+-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`).+mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity+                      -> Bool -- ^ True if this is a "type data" declaration+                              -- See Note [Type data declarations]+                              -- in GHC.Rename.Module+                      -> [DataCon]+                      -> AlgTyConRhs+mkLevPolyDataTyConRhs fixed_lev type_data cons+  = DataTyCon {+        data_cons = cons,+        data_cons_size = length cons,+        is_enum = not (null cons) && all is_enum_con cons,+                  -- See Note [Enumeration types] in GHC.Core.TyCon+        is_type_data = type_data,+        data_fixed_lev = fixed_lev+    }+  where+    is_enum_con con+       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)+           <- dataConFullSig con+       = null ex_tvs && null eq_spec && null theta && null arg_tys++-- | Create an 'AlgTyConRhs' from the data constructors.+--+-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic+-- or if it comes from a "data type" declaration+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs = mkLevPolyDataTyConRhs True False++-- | Some promoted datacons signify extra info relevant to GHC. For example,+-- the `IntRep` constructor of `RuntimeRep` corresponds to the 'IntRep'+-- constructor of 'PrimRep'. This data structure allows us to store this+-- information right in the 'TyCon'. The other approach would be to look+-- up things like `RuntimeRep`'s `PrimRep` by known-key every time.+-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType"+data PromDataConInfo+  = NoPromInfo       -- ^ an ordinary promoted data con+  | RuntimeRep ([Type] -> [PrimRep])+      -- ^ A constructor of `RuntimeRep`. The argument to the function should+      -- be the list of arguments to the promoted datacon.++  | VecCount Int         -- ^ A constructor of `VecCount`++  | VecElem PrimElemRep  -- ^ A constructor of `VecElem`++  | Levity Levity        -- ^ A constructor of `Levity`++-- | Extract those 'DataCon's that we are able to learn about.  Note+-- that visibility in this sense does not correspond to visibility in+-- the context of any particular user program!+visibleDataCons :: AlgTyConRhs -> [DataCon]+visibleDataCons (AbstractTyCon {})                = []+visibleDataCons (DataTyCon{ data_cons = cs })     = cs+visibleDataCons (NewTyCon{ data_con = c })        = [c]+visibleDataCons (UnaryClassTyCon{ data_con = c }) = [c]+visibleDataCons (TupleTyCon{ data_con = c })      = [c]+visibleDataCons (SumTyCon{ data_cons = cs })      = cs++-- | Describes the flavour of an algebraic type constructor. For+-- classes and data families, this flavour includes a reference to+-- the parent 'TyCon'.+data AlgTyConFlav+  = -- | An ordinary algebraic type constructor. This includes unlifted and+    -- representation-polymorphic datatypes and newtypes and unboxed tuples,+    -- but NOT unboxed sums; see UnboxedSumTyCon.+    VanillaAlgTyCon+       TyConRepName   -- For Typeable++    -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon+    -- because we currently don't allow unboxed sums to be Typeable since+    -- there are too many of them. See #13276.+  | UnboxedSumTyCon++  -- | Type constructors representing a class dictionary.+  -- See Note [ATyCon for classes] in "GHC.Types.TyThing"+  -- INVARIANT: the algTcRhs is never NewTyCon; it could be+  --            TupleTyCon, DataTyCon, UnaryClassTyCon+  | ClassTyCon+        Class           -- INVARIANT: the classTyCon of this Class is the+                        -- current tycon+        TyConRepName++  -- | Type constructors representing an *instance* of a *data* family.+  -- Parameters:+  --+  --  1) The type family in question+  --+  --  2) Instance types; free variables are the 'tyConTyVars'+  --  of the current 'TyCon' (not the family one). INVARIANT:+  --  the number of types matches the arity of the family 'TyCon'+  --+  --  3) A 'CoTyCon' identifying the representation+  --  type with the type instance family+  | DataFamInstTyCon          -- See Note [Data type families]+        (CoAxiom Unbranched)  -- The coercion axiom.+               -- A *Representational* coercion,+               -- of kind   T ty1 ty2   ~R   R:T a b c+               -- where T is the family TyCon,+               -- and R:T is the representation TyCon (ie this one)+               -- and a,b,c are the tyConTyVars of this TyCon+               --+               -- BUT may be eta-reduced; see+               --     Note [Eta reduction for data families] in+               --     GHC.Core.Coercion.Axiom++          -- Cached fields of the CoAxiom, but adjusted to+          -- use the tyConTyVars of this TyCon+        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++        -- E.g.  data instance T [a] = ...+        -- gives a representation tycon:+        --      data R:TList a = ...+        --      axiom co a :: T [a] ~ R:TList a+        -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co++instance Outputable AlgTyConFlav where+    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"+    ppr (UnboxedSumTyCon {})        = text "Unboxed sum"+    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls+    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"+                                      <+> ppr tc <+> sep (map pprType tys)++-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class+-- name, if any+okParent :: Name -> AlgTyConFlav -> Bool+okParent _       (VanillaAlgTyCon {})            = True+okParent _       (UnboxedSumTyCon {})            = True+okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)+okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc++isNoParent :: AlgTyConFlav -> Bool+isNoParent (VanillaAlgTyCon {}) = True+isNoParent _                   = False++--------------------++data Injectivity+  = NotInjective+  | Injective [Bool]   -- 1-1 with tyConTyVars (incl kind vars)+  deriving( Eq )++-- | Information pertaining to the expansion of a type synonym (@type@)+data FamTyConFlav+  = -- | Represents an open type family without a fixed right hand+    -- side.  Additional instances can appear at any time.+    --+    -- These are introduced by either a top level declaration:+    --+    -- > data family T a :: Type+    --+    -- Or an associated data type declaration, within a class declaration:+    --+    -- > class C a b where+    -- >   data T b :: Type+     DataFamilyTyCon+       TyConRepName++     -- | An open type synonym family  e.g. @type family F x y :: Type -> Type@+   | OpenSynFamilyTyCon++   -- | A closed type synonym family  e.g.+   -- @type family F x where { F Int = Bool }@+   | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))+     -- See Note [Closed type families]++   -- | A closed type synonym family declared in an hs-boot file with+   -- type family F a where ..+   | AbstractClosedSynFamilyTyCon++   -- | Built-in type family used by the TypeNats solver+   | BuiltInSynFamTyCon BuiltInSynFamily++instance Outputable FamTyConFlav where+    ppr (DataFamilyTyCon n) = text "data family" <+> ppr n+    ppr OpenSynFamilyTyCon = text "open type family"+    ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"+    ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax+    ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"+    ppr (BuiltInSynFamTyCon _) = text "built-in type family"++{- Note [Closed type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* In an open type family you can add new instances later.  This is the+  usual case.++* In a closed type family you can only put equations where the family+  is defined.++A non-empty closed type family has a single axiom with multiple+branches, stored in the 'ClosedSynFamilyTyCon' constructor.  A closed+type family with no equations does not have an axiom, because there is+nothing for the axiom to prove!+++Note [Promoted data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All data constructors can be promoted to become a type constructor,+via the PromotedDataCon alternative in GHC.Core.TyCon.++* The TyCon promoted from a DataCon has the *same* Name and Unique as+  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78)+  is promoted to a TyCon whose name is      Data.Maybe.Just(unique 78)++* We promote the *user* type of the DataCon.  Eg+     data T = MkT {-# UNPACK #-} !(Bool, Bool)+  The promoted kind is+     'MkT :: (Bool,Bool) -> T+  *not*+     'MkT :: Bool -> Bool -> T++* Similarly for GADTs:+     data G a where+       MkG :: forall b. b -> G [b]+  The promoted data constructor has kind+       'MkG :: forall b. b -> G [b]+  *not*+       'MkG :: forall a b. (a ~# [b]) => b -> G a++Note [Enumeration types]+~~~~~~~~~~~~~~~~~~~~~~~~+We define datatypes with no constructors to *not* be+enumerations; this fixes #2578,  Otherwise we+end up generating an empty table for+  <mod>_<type>_closure_tbl+which is used by tagToEnum# to map Int# to constructors+in an enumeration. The empty table apparently upset+the linker.++Moreover, all the data constructor must be enumerations, meaning+they have type  (forall abc. T a b c).  GADTs are not enumerations.+For example consider+    data T a where+      T1 :: T Int+      T2 :: T Bool+      T3 :: T a+What would [T1 ..] be?  [T1,T3] :: T Int? Easiest thing is to exclude them.+See #4528.++Note [Newtype coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+The NewTyCon field nt_co is a CoAxiom which is used for coercing from+the representation type of the newtype, to the newtype itself. For+example,++   newtype T a = MkT (a -> a)++the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a.++We might also eta-contract the axiom: see Note [Newtype eta].++Note [Newtype eta]+~~~~~~~~~~~~~~~~~~+Consider+        newtype Parser a = MkParser (IO a) deriving Monad+Are these two types equal? That is, does a coercion exist between them?+        Monad Parser+        Monad IO+(We need this coercion to make the derived instance for Monad Parser.)++Well, yes.  But to see that easily we eta-reduce the RHS type of+Parser, in this case to IO, so that even unsaturated applications of+Parser will work right.  So instead of+   axParser :: forall a. Parser a ~ IO a+we generate an eta-reduced axiom+   axParser :: Parser ~ IO++This eta reduction is done when the type constructor is built, in+GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon.++Here's an example that I think showed up in practice.+Source code:+        newtype T a = MkT [a]+        newtype Foo m = MkFoo (forall a. m a -> Int)++        w1 :: Foo []+        w1 = ...++        w2 :: Foo T+        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)++After desugaring, and discarding the data constructors for the newtypes,+we would like to get:+        w2 = w1 `cast` Foo axT++so that w2 and w1 share the same code. To do this, the coercion axiom+axT must have+        kind:    axT :: T ~ []+ and    arity:   0++See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build.++Note [Unary class magic]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider a class with just one method, or with no methods and one+superclass:+  class UC a where { op :: a -> a }+  class Eq a => UD a where {}+Such a class is called a /unary class/.++We could represent the dictionary for a unary class with a data type:+  data UC a where { MkUC :: (a->a) -> UC a }+  data UD a where { MkUD :: Eq a =>  UD a }+But it would be more efficent to use a newtype; and for decades GHC did+exactly that, because:++  * Unary classes are surprisingly common, so it's a useful optimisation.++  * The `reflection` library uses `unsafeCoerce` to /rely/ on the fact that+    a unary class is ultimately represented by its payload.  We may not like+    it, and I hope to ultimately eliminate the necessity for this by using+    `withDict` (see Note [withDict] in GHC.Tc.Instance.Class).  But meanwhile+    we'd prefer not to break this usage.++But alas, using a newtype representation (surprisingly) led multiple, subtle,+Bad Things: see Note [Representing unary classes with newtypes: bad, bad, bad].++This Note explains what GHC now does for unary classes.++(UCM0) Throughout the compiler, right up to the code generator, GHC thinks that a+  unary class is just like a non-unary class:+    - Represented by a data type,+    - with one constructor,+    - which has one field++(UCM1) Then when converting from Core to STG, in GHC.CoreToStg, we effectively+  transform+    - op   ta tb tc dict_arg  -->  dict_arg+    - MkUC ta tb tc meth_arg  -->  meth_arg++  Note that we do this transformation well /after/ generating an interface file,+  so importing modules only see the data constructor.++  This late transformation has a lot in common with the treatment of+  `unsafeEqualityProof`; see (U2) in Note [Implementing unsafeCoerce]+  in GHC.Internal.Unsafe.Coerce.++In this way we get the efficiency of a newtype without the bugs that we get+by exposing the newtype representation too early.++There are a number of wrinkles++(UCM2) The TyCon for a unary class is /not/ identified as a newtype.+   Rather, it has its own AlgTyConRhs, namely `UnaryClassTyCon`++(UCM3) Unlike non-unary classes, a value of type (C ty), where `C` is a unary+   class, might be bottom, because it is represented by the method type alone.+   See GHC.Core.Type.isTerminatingType.++   Similarly in exprOkForSpeculation/exprOkToDiscard/exprOkForSpecEval,+   in GHC.Core.Utils.  In the utility funcion `app_ok` we need a special+   case for the DFunIds; they generally terminate, but not for unary classes.++(UMC4) To avoid regressions, in Core we want to remember that+             (MkUC x) is really just  x+             (op d)   is really just  d+    We account for this in several places:++    - `GHC.Core.Utils.exprIsTrivial` treats the above two forms as trivial++    - `GHC.Core.Unfold.sizeExpr` (which computes the size of an expression to+      guide inlining) treats (MkUC e) as the same size as `e`, and similarly+      (op d).++    - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we+      always-inline (MkUC op), even into a boring context. See (IB6)+      in Note [inlineBoringOk]++(UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for+   non-unary classes, but just an /ordinary/ unfolding for unary classes.+       instance Num a => Num [a] where { .. }       -- (I1)+       instance UC a => UC [a] where { op = $cop }  -- (I2)+   From (I1) we get+       $fNumList = /\a \(d:Num a). MkNum (..) (..) (..)+         -- $fNumList has a DFunUnfolding+    But from (I2) we get+       $fUCList = /\a (d:UC a). MkUC ($cop a d)+       -- $fUCList has a regular CoreUnfolding++    Why?  Because we can safely inline $fUCList without code-size blow-up.+    Just one less indirection. It'd probably work ok with a DFunUnfolding;+    and it'd add another case for (UCM4) to spot.++(UCM6) In the constraint solver, when constructing evidence for a unary class+    (e.g. implicit parameters, withDict) be careful to use+    - the data constructor to build it: see `evDictApp`, `evUnaryDictAppE`+    - the class op to take it apart: see `evUnwrapIP`++(UCM7) You might worry about+           class UC1 a where { op :: Int# }    -- Single unboxed field+           class (a ~# b) => UC2 a b where {}  -- Unboxed equality superclass+  But these are illegal: predicates are always boxed, and all classes must have+  lifted fields.++(UCM8) The data constructor for a unary class has no wrapper, just a worker.+  (And the worker is turned into a cast by GHC.CoreToStg.Prep.isUnaryClassApp,+  as described above.)++(UCM9) Unary classes are treated as injective by `isInjectiveTyCon`, just like+  non-unary classes (which are TupleTyCons or DataTyCons).  This matters,+  because of the injectivity check done by lintCoercion (SelCo cs co)+  in GHC.Core.Lint.  There is a similar injectivity check in+  GHC.Core.Opt.Arity.pushCoDataCon.++  Generally, we want unary classes to behave like ordinary non-unary ones.++(UCM10) When, precisely, is a class unary?  It is unary iff+                  it has one field (superclass or method)+                  of boxed type+  The boxed-ness important. Consider+          class (a ~# b) => a ~ b where {}+  which is `eqClass` in GHC.Builtin.Types.  This has only one field, but it is+  definitely not a unary class: it is definitely represented by an ordinary+  algebraic data type with a single field of type (a ~# b).++  See `unary_class` in `GHC.Tc.TyCl.tcClassDecl1`++(UCM11) When building evidence for classes (unary or not) and implicit parameters,+  the constraint solver is careful to use functions that hide the precise+  evidence construction method.  Eg.g `evWrapIPE`.++(UCM12) In an interface-file description of a Class, we record whether or not+  the class is unary.  In theory this field is redundant, but because its value+  depends on the superclass and method fields, it's very easy to end up with+  a black hole when rehydrating interface the interface file. Easiest just to+  store the bit!  See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody.+++Note [Representing unary classes with newtypes: bad, bad, bad]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the past we represented a unary class with a newtype, but that led to+some at least three really subtle bad consequences.++* Problem 1: When we represented unary classes via a newtype, the+    newtype axiom looked like+           t1::CONSTRAINT r ~ t2::TYPE r+    If TYPE and CONSTRAINT are apart, this can create unsoundness, via KindCo;+    see #21623.  Now we never make such a coercion, so that worry about TYPE+    being apart from CONSTRAINT has gone away entirely.  Hooray.++* Problem 2: a horrible hack in GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap;+  see Historical Note [Care with binder-swap on dictionaries].+  Now the hack is gone.++* Problem 3: bogus specialisation.  The gory details are explained+  at https://gitlab.haskell.org/ghc/ghc/-/issues/23109#note_499130++  We had (using newtype classes)+     newtype SNat a = MKSNat Natural           -- axiom  snCo a :: SNat a ~ Natural+     class KNat a where { natSing :: SNat a }  -- axiom  knCo a :: KNat a ~ SNat a+  and a pattern match+    K @a (g : 32 ~ a+1) -> ...(foo @a (d :: KNat a))...+  where K is a data constructor binding `a` as an existential.++  In the code I was looking at, after lots of inlining an simplification, we find+  that (d::KNat a) is built like this:+    (d1 :: KNat 32)    = 32 |> sym (snCo 32) |> sym (knCo 32)+    (d2 :: SNat (a+1)) = d1 |> knCo g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 - 1+    (d  :: KNat a)     = d4 |> sym (snCo a) |> sym (knCo a)++  But d3 :: Natural = 32 |> (co's involving g) :: Natural ~ Natural+  and that is just Refl.  So we drop all the co's, including the crucial `g`,+  and just say d3 = 32; and+        d :: KNat a = (32-1) |> sym (snCo a) |> sym (knCo a)+  Now, we can float `d` outwards, crucially aided by polymorphic specialisation,+  (Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise)+  and use that evidence to get an utterly bogus specialisation for the function+      foo :: forall b. KNat b => blah++  Solution: don't use newtype classes.  Then we get+    (d1 :: KNat 32)    = MkKN @32 (32 |> sym (snCo 32))+    (d2 :: SNat (a+1)) = natSing d1 |> SN g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 -1+    (d  :: KNat a)     = MkKN @a (d4 |> sym (snCo a))+  Now we don't get cancelling-out coercions.+++************************************************************************+*                                                                      *+                 TyConRepName+*                                                                      *+********************************************************************* -}++type TyConRepName = Name+   -- The Name of the top-level declaration for the Typeable world+   --    $tcMaybe :: Data.Typeable.Internal.TyCon+   --    $tcMaybe = TyCon { tyConName = "Maybe", ... }++tyConRepName_maybe :: TyCon -> Maybe TyConRepName+tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details+  where+    get_rep_nm (PrimTyCon  { primRepName = rep_nm })+      = Just rep_nm+    get_rep_nm (AlgTyCon { algTcFlavour = parent })+      = case parent of+           VanillaAlgTyCon rep_nm -> Just rep_nm+           UnboxedSumTyCon        -> Nothing+           ClassTyCon _ rep_nm    -> Just rep_nm+           DataFamInstTyCon {}    -> Nothing+    get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })+      = Just rep_nm+    get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })+      | isUnboxedSumDataCon dc   -- see #13276+      = Nothing+      | otherwise+      = Just rep_nm+    get_rep_nm _ = Nothing++-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type+mkPrelTyConRepName :: Name -> TyConRepName+-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,+                            -- so nameModule will work+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)+  where+    name_occ  = nameOccName tc_name+    name_mod  = nameModule  tc_name+    name_uniq = nameUnique  tc_name+    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq+             | otherwise        = dataConTyRepNameUnique name_uniq+    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ++-- | The name (and defining module) for the Typeable representation (TyCon) of a+-- type constructor.+--+-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".+tyConRepModOcc :: Module -> OccName -> (Module, OccName)+tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ)+  where+    rep_module+      | tc_module == gHC_PRIM = gHC_TYPES+      | otherwise             = tc_module+++{- *********************************************************************+*                                                                      *+                 PrimRep+*                                                                      *+************************************************************************++Note [rep swamp]+~~~~~~~~~~~~~~~~+GHC has a rich selection of types that represent "primitive types" of+one kind or another.  Each of them makes a different set of+distinctions, and mostly the differences are for good reasons,+although it's probably true that we could merge some of these.++Roughly in order of "includes more information":++ - A Width ("GHC.Cmm.Type") is simply a binary value with the specified+   number of bits.  It may represent a signed or unsigned integer, a+   floating-point value, or an address.++    data Width = W8 | W16 | W32 | W64  | W128++ - Size, which is used in the native code generator, is Width ++   floating point information.++   data Size = II8 | II16 | II32 | II64 | FF32 | FF64++   it is necessary because e.g. the instruction to move a 64-bit float+   on x86 (movsd) is different from the instruction to move a 64-bit+   integer (movq), so the mov instruction is parameterised by Size.++ - CmmType wraps Width with more information: GC ptr, float, or+   other value.++    data CmmType = CmmType CmmCat Width++    data CmmCat     -- "Category" (not exported)+       = GcPtrCat   -- GC pointer+       | BitsCat    -- Non-pointer+       | FloatCat   -- Float++   It is important to have GcPtr information in Cmm, since we generate+   info tables containing pointerhood for the GC from this.  As for+   why we have float (and not signed/unsigned) here, see Note [Signed+   vs unsigned].++ - ArgRep makes only the distinctions necessary for the call and+   return conventions of the STG machine.  It is essentially CmmType+   + void.++ - PrimRep makes a few more distinctions than ArgRep: it divides+   non-GC-pointers into signed/unsigned and addresses, information+   that is necessary for passing these values to foreign functions.++There's another tension here: whether the type encodes its size in+bytes, or whether its size depends on the machine word size.  Width+and CmmType have the size built-in, whereas ArgRep and PrimRep do not.++This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.++On the other hand, CmmType includes some "nonsense" values, such as+CmmType GcPtrCat W32 on a 64-bit machine.++The PrimRep type is closely related to the user-visible RuntimeRep type.+See Note [RuntimeRep and PrimRep] in GHC.Types.RepType.++-}+++-- | A 'PrimRep' is an abstraction of a /non-void/ type.+-- (Use 'PrimRepOrVoidRep' if you want void types too.)+-- It contains information that the code generator needs+-- in order to pass arguments, return results,+-- and store values of this type. See also Note [RuntimeRep and PrimRep] in+-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType".+data PrimRep+-- Unpacking of sum types is only supported since 9.6.1+  = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value+  | Int8Rep       -- ^ Signed, 8-bit value+  | Int16Rep      -- ^ Signed, 16-bit value+  | Int32Rep      -- ^ Signed, 32-bit value+  | Int64Rep      -- ^ Signed, 64 bit value+  | IntRep        -- ^ Signed, word-sized value+  | Word8Rep      -- ^ Unsigned, 8 bit value+  | Word16Rep     -- ^ Unsigned, 16 bit value+  | Word32Rep     -- ^ Unsigned, 32 bit value+  | Word64Rep     -- ^ Unsigned, 64 bit value+  | WordRep       -- ^ Unsigned, word-sized value+  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep')+  | FloatRep+  | DoubleRep+  | VecRep Int PrimElemRep  -- ^ A vector+  deriving( Data.Data, Eq, Ord, Show )++data PrimOrVoidRep = VoidRep | NVRep PrimRep+  -- See Note [VoidRep] in GHC.Types.RepType+  deriving (Data.Data, Eq, Ord, Show)++data PrimElemRep+  = Int8ElemRep+  | Int16ElemRep+  | Int32ElemRep+  | Int64ElemRep+  | Word8ElemRep+  | Word16ElemRep+  | Word32ElemRep+  | Word64ElemRep+  | FloatElemRep+  | DoubleElemRep+   deriving( Data.Data, Eq, Ord, Show, Enum )++instance Outputable PrimRep where+  ppr r = text (show r)++instance Outputable PrimElemRep where+  ppr r = text (show r)++instance Binary PrimRep where+  put_ bh (BoxedRep ml)  = case ml of+    -- cheaper storage of the levity than using+    -- the Binary (Maybe Levity) instance+    Nothing       -> putByte bh 0+    Just Lifted   -> putByte bh 1+    Just Unlifted -> putByte bh 2+  put_ bh Int8Rep        = putByte bh 3+  put_ bh Int16Rep       = putByte bh 4+  put_ bh Int32Rep       = putByte bh 5+  put_ bh Int64Rep       = putByte bh 6+  put_ bh IntRep         = putByte bh 7+  put_ bh Word8Rep       = putByte bh 8+  put_ bh Word16Rep      = putByte bh 9+  put_ bh Word32Rep      = putByte bh 10+  put_ bh Word64Rep      = putByte bh 11+  put_ bh WordRep        = putByte bh 12+  put_ bh AddrRep        = putByte bh 13+  put_ bh FloatRep       = putByte bh 14+  put_ bh DoubleRep      = putByte bh 15+  put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per+  get  bh = do+    h <- getByte bh+    case h of+      0  -> pure $ BoxedRep Nothing+      1  -> pure $ BoxedRep (Just Lifted)+      2  -> pure $ BoxedRep (Just Unlifted)+      3  -> pure Int8Rep+      4  -> pure Int16Rep+      5  -> pure Int32Rep+      6  -> pure Int64Rep+      7  -> pure IntRep+      8  -> pure Word8Rep+      9  -> pure Word16Rep+      10 -> pure Word32Rep+      11 -> pure Word64Rep+      12 -> pure WordRep+      13 -> pure AddrRep+      14 -> pure FloatRep+      15 -> pure DoubleRep+      16 -> VecRep <$> get bh <*> get bh+      _  -> pprPanic "Binary:PrimRep" (int (fromIntegral h))++instance Binary PrimElemRep where+  put_ bh per = putByte bh (fromIntegral (fromEnum per))+  get  bh = toEnum . fromIntegral <$> getByte bh++isGcPtrRep :: PrimRep -> Bool+isGcPtrRep (BoxedRep _) = True+isGcPtrRep _            = False++-- A PrimRep is compatible with another iff one can be coerced to the other.+-- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.+primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool+primRepCompatible platform rep1 rep2 =+    (isUnboxed rep1 == isUnboxed rep2) &&+    (primRepSizeB platform rep1 == primRepSizeB platform rep2) &&+    (primRepIsFloat rep1 == primRepIsFloat rep2)+  where+    isUnboxed = not . isGcPtrRep++-- More general version of `primRepCompatible` for types represented by zero or+-- more than one PrimReps.+primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool+primRepsCompatible platform reps1 reps2 =+    length reps1 == length reps2 &&+    and (zipWith (primRepCompatible platform) reps1 reps2)++-- | The size of a 'PrimRep' in bytes.+--+-- This applies also when used in a constructor, where we allow packing the+-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will+-- take only 8 bytes, which for 64-bit arch will be equal to 1 word.+-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are+-- laid out.+primRepSizeB :: Platform -> PrimRep -> Int+primRepSizeB platform = \case+   IntRep           -> platformWordSizeInBytes platform+   WordRep          -> platformWordSizeInBytes platform+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> platformWordSizeInBytes platform+   BoxedRep _       -> platformWordSizeInBytes platform+   (VecRep len rep) -> len * primElemRepSizeB platform rep++-- | Like primRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primRepSizeW64_B :: PrimRep -> Int+primRepSizeW64_B = \case+   IntRep           -> 8+   WordRep          -> 8+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> 8+   BoxedRep{}       -> 8+   (VecRep len rep) -> len * primElemRepSizeW64_B rep++primElemRepSizeB :: Platform -> PrimElemRep -> Int+primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep++-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primElemRepSizeW64_B :: PrimElemRep -> Int+primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep++primElemRepToPrimRep :: PrimElemRep -> PrimRep+primElemRepToPrimRep Int8ElemRep   = Int8Rep+primElemRepToPrimRep Int16ElemRep  = Int16Rep+primElemRepToPrimRep Int32ElemRep  = Int32Rep+primElemRepToPrimRep Int64ElemRep  = Int64Rep+primElemRepToPrimRep Word8ElemRep  = Word8Rep+primElemRepToPrimRep Word16ElemRep = Word16Rep+primElemRepToPrimRep Word32ElemRep = Word32Rep+primElemRepToPrimRep Word64ElemRep = Word64Rep+primElemRepToPrimRep FloatElemRep  = FloatRep+primElemRepToPrimRep DoubleElemRep = DoubleRep++-- | Return if Rep stands for floating type,+-- returns Nothing for vector types.+primRepIsFloat :: PrimRep -> Maybe Bool+primRepIsFloat  FloatRep     = Just True+primRepIsFloat  DoubleRep    = Just True+primRepIsFloat  (VecRep _ _) = Nothing+primRepIsFloat  _            = Just False++-- Rep is one of the word reps.+primRepIsWord :: PrimRep -> Bool+primRepIsWord WordRep = True+primRepIsWord (Word8Rep) = True+primRepIsWord (Word16Rep) = True+primRepIsWord (Word32Rep) = True+primRepIsWord (Word64Rep) = True+primRepIsWord _ = False++-- Rep is one of the int reps.+primRepIsInt :: PrimRep -> Bool+primRepIsInt (IntRep) = True+primRepIsInt (Int8Rep) = True+primRepIsInt (Int16Rep) = True+primRepIsInt (Int32Rep) = True+primRepIsInt (Int64Rep) = True+primRepIsInt _ = False++{-+************************************************************************+*                                                                      *+                             Field labels+*                                                                      *+************************************************************************+-}++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabels :: TyCon -> [FieldLabel]+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabelEnv :: TyCon -> FieldLabelEnv+tyConFieldLabelEnv (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFields = fields } <- details = fields+  | otherwise                                    = emptyDFsEnv++-- | Look up a field label belonging to this 'TyCon'+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl)++-- | Make a map from strings to FieldLabels from all the data+-- constructors of this algebraic tycon+fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl)+                                | fl <- dataConsFields (visibleDataCons rhs) ]+  where+    -- Duplicates in this list will be removed by 'mkFsEnv'+    dataConsFields dcs = concatMap dataConFieldLabels dcs+++{-+************************************************************************+*                                                                      *+\subsection{TyCon Construction}+*                                                                      *+************************************************************************++Note: the TyCon constructors all take a Kind as one argument, even though+they could, in principle, work out their Kind from their other arguments.+But to do so they need functions from Types, and that makes a nasty+module mutual-recursion.  And they aren't called from many places.+So we compromise, and move their Kind calculation to the call site.+-}++mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon+mkTyCon name binders res_kind roles details+  = tc+  where+    -- Recurisve binding because of tcNullaryTy+    tc = TyCon { tyConName             = name+               , tyConUnique           = nameUnique name+               , tyConBinders          = binders+               , tyConResKind          = res_kind+               , tyConRoles            = roles+               , tyConDetails          = details++                 -- Cached things+               , tyConKind             = mkTyConKind binders res_kind+               , tyConArity            = length binders+               , tyConNullaryTy        = mkNakedTyConTy tc+               , tyConHasClosedResKind = noFreeVarsOfType res_kind+               , tyConTyVars           = binderVars binders }++-- | This is the making of an algebraic 'TyCon'.+mkAlgTyCon :: Name+           -> [TyConBinder]  -- ^ Binders of the 'TyCon'+           -> Kind              -- ^ Result kind+           -> [Role]            -- ^ The roles for each TyVar+           -> Maybe CType       -- ^ The C type this type corresponds to+                                --   when using the CAPI FFI+           -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'+           -> AlgTyConRhs       -- ^ Information about data constructors+           -> AlgTyConFlav      -- ^ What flavour is it?+                                -- (e.g. vanilla, type family)+           -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?+           -> TyCon+mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn+  = mkTyCon name binders res_kind roles $+    AlgTyCon { tyConCType       = cType+             , algTcStupidTheta = stupid+             , algTcRhs         = rhs+             , algTcFields      = fieldsOfAlgTcRhs rhs+             , algTcFlavour     = assertPpr (okParent name parent)+                                            (ppr name $$ ppr parent) parent+             , algTcGadtSyntax  = gadt_syn }++-- | Simpler specialization of 'mkAlgTyCon' for classes+mkClassTyCon :: Name -> [TyConBinder]+             -> [Role] -> AlgTyConRhs -> Class+             -> Name -> TyCon+mkClassTyCon name binders roles rhs clas tc_rep_name+  = mkAlgTyCon name binders constraintKind roles Nothing [] rhs+               (ClassTyCon clas tc_rep_name)+               False++mkTupleTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Result kind of the 'TyCon'+             -> DataCon+             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed+             -> AlgTyConFlav+             -> TyCon+mkTupleTyCon name binders res_kind con sort parent+  = mkTyCon name binders res_kind (constRoles binders Representational) $+    AlgTyCon { tyConCType       = Nothing+             , algTcGadtSyntax  = False+             , algTcStupidTheta = []+             , algTcRhs         = TupleTyCon { data_con = con+                                             , tup_sort = sort }+             , algTcFields      = emptyDFsEnv+             , algTcFlavour     = parent }++constRoles :: [TyConBinder] -> Role -> [Role]+constRoles bndrs role = [role | _ <- bndrs]++mkSumTyCon :: Name+           -> [TyConBinder]+           -> Kind    -- ^ Kind of the resulting 'TyCon'+           -> [DataCon]+           -> AlgTyConFlav+           -> TyCon+mkSumTyCon name binders res_kind cons parent+  = mkTyCon name binders res_kind (constRoles binders Representational) $+    AlgTyCon { tyConCType       = Nothing+             , algTcGadtSyntax  = False+             , algTcStupidTheta = []+             , algTcRhs         = mkSumTyConRhs cons+             , algTcFields      = emptyDFsEnv+             , algTcFlavour     = parent }++-- | Makes a tycon suitable for use during type-checking. It stores+-- a variety of details about the definition of the TyCon, but no+-- right-hand side. It lives only during the type-checking of a+-- mutually-recursive group of tycons; it is then zonked to a proper+-- TyCon in zonkTcTyCon.+-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl"+mkTcTyCon :: Name+          -> [TyConBinder]+          -> Kind                -- ^ /result/ kind only+          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;+          -> Bool                -- ^ Is this TcTyCon generalised already?+          -> TyConFlavour TyCon  -- ^ What sort of 'TyCon' this represents+          -> TyCon+mkTcTyCon name binders res_kind scoped_tvs poly flav+  = mkTyCon name binders res_kind (constRoles binders Nominal) $+    TcTyCon { tctc_scoped_tvs = scoped_tvs+            , tctc_is_poly    = poly+            , tctc_flavour    = flav }++-- | No scoped type variables (to be used with mkTcTyCon).+noTcTyConScopedTyVars :: [(Name, TcTyVar)]+noTcTyConScopedTyVars = []++-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@+-- Primitive TyCons are marshalable iff not lifted.+-- If you'd like to change this, modify marshalablePrimTyCon.+mkPrimTyCon :: Name -> [TyConBinder]+            -> Kind    -- ^ /result/ kind+                       -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism).+                       -- (If you need a representation-polymorphic PrimTyCon,+                       -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.)+            -> [Role]+            -> TyCon+mkPrimTyCon name binders res_kind roles+  = mkTyCon name binders res_kind roles $+    PrimTyCon { primRepName  = mkPrelTyConRepName name }++-- | Create a type synonym 'TyCon'+mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind+               -> [Role] -> Type+               -> Bool -> Bool -> Bool -> Bool+               -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau+               is_fam_free is_forgetful is_concrete+  = mkTyCon name binders res_kind roles $+    SynonymTyCon { synTcRhs       = rhs+                 , synIsTau       = is_tau+                 , synIsFamFree   = is_fam_free+                 , synIsForgetful = is_forgetful+                 , synIsConcrete  = is_concrete }++-- | Create a type family 'TyCon'+mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind+              -> Maybe Name -> FamTyConFlav+              -> Maybe Class -> Injectivity -> TyCon+mkFamilyTyCon name binders res_kind resVar flav parent inj+  = mkTyCon name binders res_kind (constRoles binders Nominal) $+    FamilyTyCon { famTcResVar  = resVar+                , famTcFlav    = flav+                , famTcParent  = classTyCon <$> parent+                , famTcInj     = inj }++-- | Create a promoted data constructor 'TyCon'+-- Somewhat dodgily, we give it the same Name+-- as the data constructor itself; when we pretty-print+-- the TyCon we add a quote; see the Outputable TyCon instance+mkPromotedDataCon :: DataCon -> Name -> TyConRepName+                  -> [TyConBinder] -> Kind -> [Role]+                  -> PromDataConInfo -> TyCon+mkPromotedDataCon con name rep_name binders res_kind roles rep_info+  = mkTyCon name binders res_kind roles $+    PromotedDataCon { dataCon    = con+                    , tcRepName  = rep_name+                    , promDcInfo = rep_info }++-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)+isAbstractTyCon :: TyCon -> Bool+isAbstractTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True+  | otherwise           = False++-- | Does this 'TyCon' represent something that cannot be defined in Haskell?+isPrimTyCon :: TyCon -> Bool+isPrimTyCon (TyCon { tyConDetails = details })+  | PrimTyCon {} <- details = True+  | otherwise               = False++-- | Returns @True@ if the supplied 'TyCon' resulted from either a+-- @data@ or @newtype@ declaration+isAlgTyCon :: TyCon -> Bool+isAlgTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {} <- details = True+  | otherwise              = False++-- | Returns @True@ for vanilla AlgTyCons -- that is, those created+-- with a @data@ or @newtype@ declaration.+isVanillaAlgTyCon :: TyCon -> Bool+isVanillaAlgTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True+  | otherwise                                                = False++-- | Returns @True@ if a boxed type headed by the given @TyCon@+-- satisfies condition DTT2 of Note [DataToTag overview] in+-- GHC.Tc.Instance.Class+isValidDTT2TyCon :: TyCon -> Bool+isValidDTT2TyCon = isBoxedDataTyCon++isBoxedDataTyCon :: TyCon -> Bool+-- ^ Returns @True@ for data types that are /definitely/ represented by+-- heap-allocated constructors.  These are scrutinised by Core-level+-- @case@ expressions, and they get info tables allocated for them.+--+-- Generally, the function will be+-- true for all `data` types and+-- false for  newtype+--            unboxed tuples+--            unboxed sums+--            type family+--            type data+-- 'TyCon's. But it is not guaranteed to return `True` in all cases+-- that it could.+--+-- NB: for a data type family, only the /instance/ 'TyCon's+--     get an info table.  The family declaration 'TyCon' does not+isBoxedDataTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details+  = case rhs of+        TupleTyCon { tup_sort = sort }+                           -> isBoxed (tupleSortBoxity sort)+        SumTyCon {}        -> False+            -- Constructors from "type data" declarations exist only at+            -- the type level.+            -- See Note [Type data declarations] in GHC.Rename.Module.+        DataTyCon { is_type_data = type_data } -> not type_data+        NewTyCon {}        -> False+        UnaryClassTyCon {} -> False+        AbstractTyCon {}   -> False      -- We don't know, so return False+isBoxedDataTyCon _ = False++-- | Was this 'TyCon' declared as "type data"?+-- See Note [Type data declarations] in GHC.Rename.Module.+isTypeDataTyCon :: TyCon -> Bool+isTypeDataTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details+              = type_data+  | otherwise = False++-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds+-- (where r is the role passed in):+--   If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2)+-- (where r1, r2, and r3, are the roles given by tyConRolesX tc r)+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"+isInjectiveTyCon :: TyCon -> Role -> Bool+isInjectiveTyCon (TyCon { tyConDetails = details }) role+  = go details+  where+    go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!++    go (AlgTyCon {algTcRhs = rhs})+       | Nominal <- role                                = True+       | Representational <- role                       = go_alg_rep rhs++    go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })+       | Nominal <- role                                = True+    go (FamilyTyCon { famTcInj = Injective inj })+       | Nominal <- role                                = and inj+    go (FamilyTyCon {})                                 = False++    go (SynonymTyCon {})    = False+    go (PrimTyCon {})       = True+    go (PromotedDataCon {}) = True+    go (TcTyCon {})         = True+       -- Reply True for TcTyCon to minimise knock on type errors+       -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl++    -- go_alg_rep used only at Representational role+    go_alg_rep (TupleTyCon {})      = True+    go_alg_rep (SumTyCon {})        = True+    go_alg_rep (DataTyCon {})       = True+    go_alg_rep (UnaryClassTyCon {}) = True -- See (UCM9) in Note [Unary class magic]+    go_alg_rep (AbstractTyCon {})   = False+    go_alg_rep (NewTyCon {})        = False++-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds+-- (where r is the role passed in):+--   If (T tys ~r t), then (t's head ~r T).+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"+--+-- NB: at Nominal role, isGenerativeTyCon is simple:+--     isGenerativeTyCon tc Nominal+--       = not (isTypeFamilyTyCon tc || isSynonymTyCon tc)+isGenerativeTyCon :: TyCon -> Role -> Bool+isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role+   = go role details+   where+    go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True+    go _       (FamilyTyCon {})                                = False++    -- In all other cases, injectivity implies generativity+    go r _ = isInjectiveTyCon tc r++-- | Is this 'TyCon' that for a @newtype@+isNewTyCon :: TyCon -> Bool+isNewTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True+  | otherwise                                    = False++-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it+-- expands into, and (possibly) a coercion from the representation type to the+-- @newtype@.+-- Returns @Nothing@ if this is not possible.+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details+              = Just (tvs, rhs, co)+  | otherwise = Nothing++unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_co = co+                                    , nt_etad_rhs = (tvs,rhs) }} <- details+              = Just (tvs, rhs, co)+  | otherwise = Nothing++-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?+{-# INLINE isTypeSynonymTyCon #-}  -- See Note [Inlining coreView] in GHC.Core.Type+isTypeSynonymTyCon :: TyCon -> Bool+isTypeSynonymTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon {} <- details = True+  | otherwise                  = False++isTauTyCon :: TyCon -> Bool+isTauTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsTau = is_tau } <- details = is_tau+  | otherwise                                     = True++-- | Is this tycon neither a type family nor a synonym that expands+-- to a type family?+isFamFreeTyCon :: TyCon -> Bool+isFamFreeTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free+  | FamilyTyCon { famTcFlav = flav }         <- details = isDataFamFlav flav+  | otherwise                                           = True++-- | Is this a forgetful type synonym? If this is a type synonym whose+-- RHS does not mention one (or more) of its bound variables, returns+-- True. Thus, False means that all bound variables appear on the RHS;+-- True may not mean anything, as the test to set this flag is+-- conservative.+--+-- See Note [Forgetful type synonyms]+isForgetfulSynTyCon :: TyCon -> Bool+isForgetfulSynTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsForgetful = forget } <- details = forget+  | otherwise                                           = False++{- Note [Forgetful type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type synonyms is /forgetful/ if its RHS fails to mention one (or more) of its bound variables.++Forgetfulness is conservative:+  * A non-forgetful synonym /guarantees/ to mention all its bound variables in its RHS.+  * It is always safe to classify a synonym as forgetful.++Examples:+    type R = Int             -- Not forgetful+    type S a = Int           -- Forgetful+    type T1 a = Int -> S a   -- Forgetful+    type T2 a = a -> S a     -- Not forgetful+    type T3 a = Int -> F a   -- Not forgetful+      where type family F a++* R shows that nullary synonyms are not forgetful.++* T2 shows that forgetfulness needs to account for uses of forgetful+  synonyms. `a` appears on the RHS, but only under a forgetful S++* T3 shows that non-forgetfulness is not the same as injectivity. T3 mentions its+  bound variable on its RHS, but under a type family.  So it is entirely possible+  that    T3 Int ~ T3 Bool++* Since type synonyms are non-recursive, we don't need a fixpoint analysis to+  determine forgetfulness.  It's rather easy -- see `GHC.Core.Type.buildSynTyCon`,+  which is a bit over-conservative for over-saturated synonyms.+-}++-- As for newtypes, it is in some contexts important to distinguish between+-- closed synonyms and synonym families, as synonym families have no unique+-- right hand side to which a synonym family application can expand.+--++-- | True iff we can decompose (T a b c) into ((T a b) c)+--   I.e. is it injective and generative w.r.t nominal equality?+--   That is, if (T a b) ~N d e f, is it always the case that+--            (T ~N d), (a ~N e) and (b ~N f)?+-- Specifically NOT true of synonyms (open and otherwise)+--+-- It'd be unusual to call tyConMustBeSaturated on a regular H98+-- type synonym, because you should probably have expanded it first+-- But regardless, it's not decomposable+tyConMustBeSaturated :: TyCon -> Bool+tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour++-- | Is this an algebraic 'TyCon' declared with the GADT syntax?+isGadtSyntaxTyCon :: TyCon -> Bool+isGadtSyntaxTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcGadtSyntax = res } <- details = res+  | otherwise                                     = False++-- | Is this an algebraic 'TyCon' which is just an enumeration of values?+isEnumerationTyCon :: TyCon -> Bool+-- See Note [Enumeration types] in GHC.Core.TyCon+isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+       DataTyCon { is_enum = res }     -> res+       TupleTyCon { tup_sort = tsort }+         | arity == 0                  -> isBoxed (tupleSortBoxity tsort)+                                          -- () is an enumeration, but (##) is not+       _                               -> False+  | otherwise = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family?+isFamilyTyCon :: TyCon -> Bool+isFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {} <- details = True+  | otherwise                 = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family with+-- instances?+isOpenFamilyTyCon :: TyCon -> Bool+isOpenFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = flav } <- details+              = case flav of+                  OpenSynFamilyTyCon -> True+                  DataFamilyTyCon {} -> True+                  _                  -> False+  | otherwise = False++-- | Is this a type family 'TyCon' (whether open or closed)?+isTypeFamilyTyCon :: TyCon -> Bool+isTypeFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav)+  | otherwise                                   = False++-- | Is this a data family 'TyCon'?+isDataFamilyTyCon :: TyCon -> Bool+isDataFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav+  | otherwise                                    = False++-- | Is this an open type family TyCon?+isOpenTypeFamilyTyCon :: TyCon -> Bool+isOpenTypeFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True+  | otherwise                                                = False++-- | Is this a non-empty closed type family? Returns 'Nothing' for+-- abstract or empty closed families.+isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)+isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb+  | otherwise                                                    = Nothing++isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily+isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops} <- details = Just ops+  | otherwise                                                   = Nothing++-- | Extract type variable naming the result of injective type family+tyConFamilyResVar_maybe :: TyCon -> Maybe Name+tyConFamilyResVar_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcResVar = res} <- details = res+  | otherwise                                  = Nothing++-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an+-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is+-- injective), or 'NotInjective' otherwise.+tyConInjectivityInfo :: TyCon -> Injectivity+tyConInjectivityInfo tc@(TyCon { tyConDetails = details })+  | FamilyTyCon { famTcInj = inj } <- details+  = inj+  | isInjectiveTyCon tc Nominal+  = Injective (replicate (tyConArity tc) True)+  | otherwise+  = NotInjective++isDataFamFlav :: FamTyConFlav -> Bool+isDataFamFlav (DataFamilyTyCon {}) = True   -- Data family+isDataFamFlav _                    = False  -- Type synonym family++-- | Is this TyCon for an associated type?+isTyConAssoc :: TyCon -> Bool+isTyConAssoc = isJust . tyConAssoc_maybe++-- | Get the enclosing class TyCon (if there is one) for the given TyCon.+tyConAssoc_maybe :: TyCon -> Maybe TyCon+tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour++-- The unit tycon didn't used to be classed as a tuple tycon+-- but I thought that was silly so I've undone it+-- If it can't be for some reason, it should be a AlgTyCon+isTupleTyCon :: TyCon -> Bool+-- ^ Does this 'TyCon' represent a tuple?+--+-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to+-- 'isTupleTyCon', because they are built as 'AlgTyCons'.  However they+-- get spat into the interface file as tuple tycons, so I don't think+-- it matters.+isTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True+  | otherwise                                        = False++tyConTuple_maybe :: TyCon -> Maybe TupleSort+tyConTuple_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort} <- rhs = Just sort+  | otherwise                            = Nothing++-- | Is this the 'TyCon' for an unboxed tuple?+isUnboxedTupleTyCon :: TyCon -> Bool+isUnboxedTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort } <- rhs+              = not (isBoxed (tupleSortBoxity sort))+  | otherwise = False++-- | Is this the 'TyCon' for a boxed tuple?+isBoxedTupleTyCon :: TyCon -> Bool+isBoxedTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort } <- rhs+              = isBoxed (tupleSortBoxity sort)+  | otherwise = False++-- | Is this the 'TyCon' for an unboxed sum?+isUnboxedSumTyCon :: TyCon -> Bool+isUnboxedSumTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , SumTyCon {} <- rhs+              = True+  | otherwise = False++isLiftedAlgTyCon :: TyCon -> Bool+isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details })+  | AlgTyCon {} <- details = isLiftedTypeKind res_kind+  | otherwise              = False++-- | Retrieves the promoted DataCon if this is a PromotedDataCon;+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon+isPromotedDataCon_maybe (TyCon { tyConDetails = details })+  | PromotedDataCon { dataCon = dc } <- details = Just dc+  | otherwise                                   = Nothing++-- | Is this the 'TyCon' for a /promoted/ tuple?+isPromotedTupleTyCon :: TyCon -> Bool+isPromotedTupleTyCon tyCon+  | Just dataCon <- isPromotedDataCon_maybe tyCon+  , isTupleTyCon (dataConTyCon dataCon) = True+  | otherwise                           = False++-- | Is this a PromotedDataCon?+isPromotedDataCon :: TyCon -> Bool+isPromotedDataCon (TyCon { tyConDetails = details })+  | PromotedDataCon {} <- details = True+  | otherwise                     = False++-- | This function identifies PromotedDataCon's from data constructors in+-- `data T = K1 | K2`, promoted by -XDataKinds.  These type constructors+-- are printed with a tick mark 'K1 and 'K2, and similarly have a tick+-- mark added to their OccName's.+--+-- In contrast, constructors in `type data T = K1 | K2` are printed and+-- represented with their original undecorated names.+-- See Note [Type data declarations] in GHC.Rename.Module+isDataKindsPromotedDataCon :: TyCon -> Bool+isDataKindsPromotedDataCon (TyCon { tyConDetails = details })+  | PromotedDataCon { dataCon = dc } <- details+              = not (isTypeDataCon dc)+  | otherwise = False++-- | Is this 'TyCon' really meant for use at the kind level? That is,+-- should it be permitted without @DataKinds@?+isKindTyCon :: TyCon -> Bool+isKindTyCon = isKindUniquable++-- | This is 'Name' really meant for use at the kind level? That is,+-- should it be permitted wihout @DataKinds@?+isKindName :: Name -> Bool+isKindName = isKindUniquable++-- | The workhorse for 'isKindTyCon' and 'isKindName'.+isKindUniquable :: Uniquable a => a -> Bool+isKindUniquable thing = getUnique thing `memberUniqueSet` kindTyConKeys++-- | These TyCons should be allowed at the kind level, even without+-- -XDataKinds.+kindTyConKeys :: UniqueSet+kindTyConKeys = fromListUniqueSet $+  -- Make sure to keep this in sync with the following:+  --+  -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC+  --   User's Guide.+  --+  -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all+  --   of these can successfully be used without DataKinds.+  [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ]+  ++ concatMap tycon_with_datacons [ runtimeRepTyCon, levityTyCon+                                   , multiplicityTyCon+                                   , vecCountTyCon, vecElemTyCon ]+  where+    tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)++isLiftedTypeKindTyConName :: Name -> Bool+isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)++-- | Identifies implicit tycons that, in particular, do not go into interface+-- files (because they are implicitly reconstructed when the interface is+-- read).+--+-- Note that:+--+-- * Associated families are implicit, as they are re-constructed from+--   the class declaration in which they reside, and+--+-- * Family instances are /not/ implicit as they represent the instance body+--   (similar to a @dfun@ does that for a class instance).+--+-- * Tuples are implicit iff they have a wired-in name+--   (namely: boxed and unboxed tuples are wired-in and implicit,+--            but constraint tuples are not)+isImplicitTyCon :: TyCon -> Bool+isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details+  where+    go (PrimTyCon {})       = True+    go (PromotedDataCon {}) = True+    go (SynonymTyCon {})    = False+    go (TcTyCon {})         = False+    go (FamilyTyCon { famTcParent = parent }) = isJust parent+    go (AlgTyCon { algTcRhs = rhs })+       | TupleTyCon {} <- rhs = isWiredInName name+       | SumTyCon {} <- rhs   = True+       | otherwise            = False++tyConCType_maybe :: TyCon -> Maybe CType+tyConCType_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype+  | otherwise                                    = Nothing++-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?+--+-- False is safe. True means we're sure.+-- Does only a quick check, based on the TyCon's category.+--+-- See Note [Representation-polymorphic TyCons]+tcHasFixedRuntimeRep :: TyCon -> Bool+tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+       AbstractTyCon {} -> False+               -- An abstract TyCon might not have a fixed runtime representation.+               -- Note that this is an entirely different matter from the concreteness+               -- of the 'TyCon', in the sense of 'isConcreteTyCon'.++       DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev+               -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).+               -- NB: the current representation-polymorphism checks require that+               -- the representation be fully-known, including levity variables.+               -- This might be relaxed in the future (#15532).++       TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) ||+                                               -- (# #) also has fixed rep.+                                               tyConArity tc == 0++       SumTyCon {} -> False   -- only unboxed sums here++       UnaryClassTyCon {} -> True  -- Always boxed++       NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep+              -- A newtype might not have a fixed runtime representation+              -- with UnliftedNewtypes (#17360)++  | SynonymTyCon {}   <- details = False   -- conservative choice+  | FamilyTyCon{}     <- details = False+  | PrimTyCon{}       <- details = True+  | TcTyCon{}         <- details = False+  | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)++-- | Is this 'TyCon' concrete?+-- More specifically, if 'tys' are all concrete, is (T tys) concrete?+--      (for synonyms this requires us to look at the RHS)+-- Used for representation polymorphism checks.+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete+isConcreteTyCon :: TyCon -> Bool+isConcreteTyCon tc@(TyCon { tyConDetails = details })+  = case details of+      AlgTyCon {}        -> True   -- Includes AbstractTyCon+      PrimTyCon {}       -> True+      PromotedDataCon {} -> True+      FamilyTyCon {}     -> False++      SynonymTyCon { synIsConcrete = is_conc } -> is_conc++      TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc)+                    -- isConcreteTyCon is only used on "real" tycons++{-+-----------------------------------------------+--      TcTyCon+-----------------------------------------------+-}++-- | Is this a TcTyCon? (That is, one only used during type-checking?)+isTcTyCon :: TyCon -> Bool+isTcTyCon (TyCon { tyConDetails = details })+  | TcTyCon {} <- details = True+  | otherwise             = False++setTcTyConKind :: TyCon -> Kind -> TyCon+-- Update the Kind of a TcTyCon+-- The new kind is always a zonked version of its previous+-- kind, so we don't need to update any other fields.+-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType+setTcTyConKind tc kind+  = assert (isMonoTcTyCon tc) $+    let tc' = tc { tyConKind      = kind+                 , tyConNullaryTy = mkNakedTyConTy tc' }+                 -- See Note [Sharing nullary TyConApps]+    in tc'++isMonoTcTyCon :: TyCon -> Bool+isMonoTcTyCon (TyCon { tyConDetails = details })+  | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly+  | otherwise                                      = False++tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)]+tcTyConScopedTyVars tc@(TyCon { tyConDetails = details })+  | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs+  | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc)++{-+-----------------------------------------------+--      Expand type-constructor applications+-----------------------------------------------+-}++data ExpandSynResult tyco+  = NoExpansion+  | ExpandsSyn [(TyVar,tyco)] Type [tyco]++expandSynTyCon_maybe+        :: TyCon+        -> [tyco]                 -- ^ Arguments to 'TyCon'+        -> ExpandSynResult tyco       -- ^ Returns a 'TyVar' substitution, the body+                                  -- type of the synonym (not yet substituted)+                                  -- and any arguments remaining from the+                                  -- application+-- ^ Expand a type synonym application+-- Return Nothing if the TyCon is not a synonym,+-- or if not enough arguments are supplied+expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity+                            , tyConDetails = details }) tys+  | SynonymTyCon { synTcRhs = rhs } <- details+  = if arity == 0+    then ExpandsSyn [] rhs tys  -- Avoid a bit of work in the case of nullary synonyms+    else case tys `listLengthCmp` arity of+              GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys)+              EQ -> ExpandsSyn (tvs `zip` tys) rhs []+              LT -> NoExpansion+   | otherwise+   = NoExpansion++----------------++-- | Check if the tycon actually refers to a proper `data` or `newtype`+--  with user defined constructors rather than one from a class or other+--  construction.++-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an+-- exported tycon can have a pattern synonym bundled with it, e.g.,+-- module Foo (TyCon(.., PatSyn)) where+isTyConWithSrcDataCons :: TyCon -> Bool+isTyConWithSrcDataCons (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details+  , let isSrcParent = isNoParent parent+              = case rhs of+                   DataTyCon {}  -> isSrcParent+                   NewTyCon {}   -> isSrcParent+                   TupleTyCon {} -> isSrcParent+                   _             -> False+  | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details+              = True -- #14058+  | otherwise = False+++-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no+-- constructors could be found+tyConDataCons :: TyCon -> [DataCon]+-- It's convenient for tyConDataCons to return the+-- empty list for type synonyms etc+tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []++-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon'+-- is the sort that can have any constructors (note: this does not include+-- abstract algebraic types)+tyConDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConDataCons_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details+  = case rhs of+       DataTyCon { data_cons = cons }     -> Just cons+       NewTyCon { data_con = con }        -> Just [con]+       UnaryClassTyCon { data_con = con } -> Just [con]+       TupleTyCon { data_con = con }      -> Just [con]+       SumTyCon { data_cons = cons }      -> Just cons+       _                                  -> Nothing+tyConDataCons_maybe _ = Nothing++-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@+-- type with one alternative, a tuple type or a @newtype@ then that constructor+-- is returned. If the 'TyCon' has more than one constructor, or represents a+-- primitive or function type constructor then @Nothing@ is returned.+tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon+tyConSingleDataCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+      DataTyCon { data_cons = [c] }    -> Just c+      TupleTyCon { data_con = c }      -> Just c+      NewTyCon { data_con = c }        -> Just c+      UnaryClassTyCon { data_con = c } -> Just c+      _                                -> Nothing+  | otherwise = Nothing++-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'.+tyConSingleDataCon :: TyCon -> DataCon+tyConSingleDataCon tc+  = case tyConSingleDataCon_maybe tc of+      Just c  -> c+      Nothing -> pprPanic "tyConDataCon" (ppr tc)++-- | Determine the number of value constructors a 'TyCon' has. Panics if the+-- 'TyCon' is not algebraic or a tuple+tyConFamilySize  :: TyCon -> Int+tyConFamilySize tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+      DataTyCon { data_cons_size = size } -> size+      NewTyCon {}                    -> 1+      UnaryClassTyCon {}             -> 1+      TupleTyCon {}                  -> 1+      SumTyCon { data_cons_size = size }  -> size+      _                              -> pprPanic "tyConFamilySize 1" (ppr tc)+  | otherwise = pprPanic "tyConFamilySize 2" (ppr tc)++-- | Extract an 'AlgTyConRhs' with information about data constructors from an+-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'+algTyConRhs :: TyCon -> AlgTyConRhs+algTyConRhs tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details = rhs+  | otherwise                            = pprPanic "algTyConRhs" (ppr tc)++-- | Extract the bound type variables and type expansion of a type synonym+-- 'TyCon'. Panics if the 'TyCon' is not a synonym+newTyConRhs :: TyCon -> ([TyVar], Type)+newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details+  = (tvs, rhs)+  | otherwise+  = pprPanic "newTyConRhs" (ppr tc)++-- | The number of type parameters that need to be passed to a newtype to+-- resolve it. May be less than in the definition if it can be eta-contracted.+newTyConEtadArity :: TyCon -> Int+newTyConEtadArity tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details+  = length (fst tvs_rhs)+  | otherwise+  = pprPanic "newTyConEtadArity" (ppr tc)++-- | Extract the bound type variables and type expansion of an eta-contracted+-- type synonym 'TyCon'.  Panics if the 'TyCon' is not a synonym+newTyConEtadRhs :: TyCon -> ([TyVar], Type)+newTyConEtadRhs tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs+  | otherwise = pprPanic "newTyConEtadRhs" (ppr tc)++-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to+-- construct something with the @newtype@s type from its representation type+-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns+-- @Nothing@+newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+newTyConCo_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co+  | otherwise                                                = Nothing++newTyConCo :: TyCon -> CoAxiom Unbranched+newTyConCo tc = case newTyConCo_maybe tc of+                 Just co -> co+                 Nothing -> pprPanic "newTyConCo" (ppr tc)++newTyConDataCon_maybe :: TyCon -> Maybe DataCon+newTyConDataCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con+  | otherwise                                                    = Nothing++-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context+-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration+-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon".+tyConStupidTheta :: TyCon -> [PredType]+tyConStupidTheta tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid+  | PrimTyCon {} <- details                         = []+  | PromotedDataCon {} <- details                   = []+  | otherwise = pprPanic "tyConStupidTheta" (ppr tc)++-- | Extract the 'TyVar's bound by a vanilla type synonym+-- and the corresponding (unsubstituted) right hand side.+synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)+synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details })+  | SynonymTyCon {synTcRhs = ty} <- details+  = Just (tyvars, ty)+  | otherwise+  = Nothing++-- | Extract the information pertaining to the right hand side of a type synonym+-- (@type@) declaration.+synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe (TyCon { tyConDetails = details })+  | SynonymTyCon {synTcRhs = rhs} <- details  = Just rhs+  | otherwise                                 = Nothing++-- | Extract the flavour of a type family (with all the extra information that+-- it carries)+famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav+famTyConFlav_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = flav} <- details = Just flav+  | otherwise                                 = Nothing++isUnaryClassTyCon :: TyCon -> Bool+isUnaryClassTyCon tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClassTyCon {} } <- details+  = assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $+    True+  | otherwise+  = False++isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon)+isUnaryClassTyCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = ClassTyCon cls _+             , algTcRhs = UnaryClassTyCon { data_con = dc } } <- details+  = Just (cls, dc)+  | otherwise+  = Nothing++-- | Is this 'TyCon' that for a class instance?+isClassTyCon :: TyCon -> Bool+isClassTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True+  | otherwise                                          = False++-- | If this 'TyCon' is that for a class instance, return the class it is for.+-- Otherwise returns @Nothing@+tyConClass_maybe :: TyCon -> Maybe Class+tyConClass_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas+  | otherwise                                              = Nothing++-- | Return the associated types of the 'TyCon', if any+tyConATs :: TyCon -> [TyCon]+tyConATs (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas+  | otherwise                                              = []++----------------------------------------------------------------------------+-- | Is this 'TyCon' that for a data family instance?+isFamInstTyCon :: TyCon -> Bool+isFamInstTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True+  | otherwise                                                 = False++tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)+tyConFamInstSig_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax)+  | otherwise                                                      = Nothing++-- | If this 'TyCon' is that of a data family instance, return the family in question+-- and the instance types. Otherwise, return @Nothing@+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])+tyConFamInst_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts)+  | otherwise                                                     = Nothing++-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which+-- represents a coercion identifying the representation type with the type+-- instance family.  Otherwise, return @Nothing@+tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+tyConFamilyCoercion_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax+  | otherwise                                                     = Nothing++-- | Extract any 'RuntimeRepInfo' from this TyCon+tyConPromDataConInfo :: TyCon -> PromDataConInfo+tyConPromDataConInfo (TyCon { tyConDetails = details })+  | PromotedDataCon { promDcInfo = rri } <- details = rri+  | otherwise                                       = NoPromInfo+  -- could panic in that second case. But Douglas Adams told me not to.++{-+Note [Constructor tag allocation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking we need to allocate constructor tags to constructors.+They are allocated based on the position in the data_cons field of TyCon,+with the first constructor getting fIRST_TAG.++We used to pay linear cost per constructor, with each constructor looking up+its relative index in the constructor list. That was quadratic and prohibitive+for large data types with more than 10k constructors.++The current strategy is to build a NameEnv with a mapping from constructor's+Name to ConTag and pass it down to buildDataCon for efficient lookup.++Relevant ticket: #14657+-}++mkTyConTagMap :: TyCon -> NameEnv ConTag+mkTyConTagMap tycon =+  mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..]+  -- See Note [Constructor tag allocation]++{-+************************************************************************+*                                                                      *+\subsection[TyCon-instances]{Instance declarations for @TyCon@}+*                                                                      *+************************************************************************++@TyCon@s are compared by comparing their @Unique@s.+-}++instance Eq TyCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable TyCon where+    getUnique tc = tyConUnique tc++instance Outputable TyCon where+  -- At the moment a promoted TyCon has the same Name as its+  -- corresponding TyCon, so we add the quote to distinguish it here+  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc+    where+      pp_tc = getPprStyle $ \sty ->+              getPprDebug $ \debug ->+               if ((debug || dumpStyle sty) && isTcTyCon tc)+                  then text "[tc]"+                  else empty++tyConFlavour :: TyCon -> TyConFlavour TyCon+tyConFlavour (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details+  = case parent of+      ClassTyCon {} -> ClassFlavour+      _ -> case rhs of+                  TupleTyCon { tup_sort = sort }+                                     -> TupleFlavour (tupleSortBoxity sort)+                  SumTyCon {}        -> SumFlavour+                  DataTyCon {}       -> DataTypeFlavour+                  NewTyCon {}        -> NewtypeFlavour+                  UnaryClassTyCon {} -> ClassFlavour+                  AbstractTyCon {}   -> AbstractTypeFlavour++  | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details+  = case flav of+      DataFamilyTyCon{}            -> OpenFamilyFlavour (IAmData DataType) parent+      OpenSynFamilyTyCon           -> OpenFamilyFlavour IAmType parent+      ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour+      AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour+      BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour++  | SynonymTyCon {} <- details                  = TypeSynonymFlavour+  | PrimTyCon {} <- details                     = BuiltInTypeFlavour+  | PromotedDataCon {} <- details               = PromotedDataConFlavour+  | TcTyCon { tctc_flavour = flav } <-details   = flav++-- | Can this flavour of 'TyCon' appear unsaturated?+tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool+tcFlavourMustBeSaturated ClassFlavour            = False+tcFlavourMustBeSaturated DataTypeFlavour         = False+tcFlavourMustBeSaturated NewtypeFlavour          = False+tcFlavourMustBeSaturated TupleFlavour{}          = False+tcFlavourMustBeSaturated SumFlavour              = False+tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False+tcFlavourMustBeSaturated BuiltInTypeFlavour      = False+tcFlavourMustBeSaturated PromotedDataConFlavour  = False+tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True }+tcFlavourMustBeSaturated TypeSynonymFlavour      = True+tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True++-- | Is this flavour of 'TyCon' an open type family or a data family?+tcFlavourIsOpen :: TyConFlavour tc -> Bool+tcFlavourIsOpen OpenFamilyFlavour{}     = True+tcFlavourIsOpen ClosedTypeFamilyFlavour = False+tcFlavourIsOpen ClassFlavour            = False+tcFlavourIsOpen DataTypeFlavour         = False+tcFlavourIsOpen NewtypeFlavour          = False+tcFlavourIsOpen TupleFlavour{}          = False+tcFlavourIsOpen SumFlavour              = False+tcFlavourIsOpen AbstractTypeFlavour {}  = False+tcFlavourIsOpen BuiltInTypeFlavour      = False+tcFlavourIsOpen PromotedDataConFlavour  = False+tcFlavourIsOpen TypeSynonymFlavour      = False++pprPromotionQuote :: TyCon -> SDoc+-- Promoted data constructors already have a tick in their OccName+pprPromotionQuote tc =+  getPprStyle $ \sty ->+    let+      name   = getOccName tc+      ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name)+    in+      if ticked+      then char '\''+      else empty++instance NamedThing TyCon where+    getName = tyConName++instance Data.Data TyCon where+    -- don't traverse?+    toConstr _   = abstractConstr "TyCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "TyCon"++instance Binary Injectivity where+    put_ bh NotInjective   = putByte bh 0+    put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs++    get bh = do { h <- getByte bh+                ; case h of+                    0 -> return NotInjective+                    _ -> do { xs <- get bh+                            ; return (Injective xs) } }++instance NFData Injectivity where+  rnf NotInjective = ()+  rnf (Injective xs) = rnf xs++-- | Returns whether or not this 'TyCon' is definite, or a hole+-- that may be filled in at some later point.  See Note [Skolem abstract data]+tyConSkolem :: TyCon -> Bool+tyConSkolem = isHoleName . tyConName++-- Note [Skolem abstract data]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Skolem abstract data arises from data declarations in an hsig file.+--+-- The best analogy is to interpret the types declared in signature files as+-- elaborating to universally quantified type variables; e.g.,+--+--    unit p where+--        signature H where+--            data T+--            data S+--        module M where+--            import H+--            f :: (T ~ S) => a -> b+--            f x = x+--+-- elaborates as (with some fake structural types):+--+--    p :: forall t s. { f :: forall a b. t ~ s => a -> b }+--    p = { f = \x -> x } -- ill-typed+--+-- It is clear that inside p, t ~ s is not provable (and+-- if we tried to write a function to cast t to s, that+-- would not work), but if we call p @Int @Int, clearly Int ~ Int+-- is provable.  The skolem variables are all distinct from+-- one another, but we can't make assumptions like "f is+-- inaccessible", because the skolem variables will get+-- instantiated eventually!+--+-- Skolem abstractness can apply to "non-abstract" data as well):+--+--    unit p where+--        signature H1 where+--            data T = MkT+--        signature H2 where+--            data T = MkT+--        module M where+--            import qualified H1+--            import qualified H2+--            f :: (H1.T ~ H2.T) => a -> b+--            f x = x+--+-- This is why the test is on the original name of the TyCon,+-- not whether it is abstract or not.
+ GHC/Core/TyCon.hs-boot view
@@ -0,0 +1,21 @@+module GHC.Core.TyCon where++import GHC.Prelude+import GHC.Types.Unique ( Uniquable )+import {-# SOURCE #-} GHC.Types.Name+import GHC.Utils.Outputable++data TyCon++instance Uniquable TyCon+instance Outputable TyCon++type TyConRepName = Name++isNewTyCon          :: TyCon -> Bool+isTupleTyCon        :: TyCon -> Bool+isUnboxedTupleTyCon :: TyCon -> Bool++tyConRepName_maybe  :: TyCon -> Maybe TyConRepName+mkPrelTyConRepName  :: Name -> TyConRepName+tyConName :: TyCon -> Name
+ GHC/Core/TyCon/Env.hs view
@@ -0,0 +1,145 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TyConEnv]{@TyConEnv@: tyCon environments}+-}+++{-# LANGUAGE ScopedTypeVariables #-}+++module GHC.Core.TyCon.Env (+        -- * TyCon environment (map)+        TyConEnv,++        -- ** Manipulating these environments+        mkTyConEnv, mkTyConEnvWith,+        emptyTyConEnv, isEmptyTyConEnv,+        unitTyConEnv, nonDetTyConEnvElts,+        extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,+        extendTyConEnvList, extendTyConEnvList_C,+        filterTyConEnv, anyTyConEnv,+        plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv,+        lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv,+        elemTyConEnv, mapTyConEnv, disjointTyConEnv,++        DTyConEnv,++        emptyDTyConEnv, isEmptyDTyConEnv,+        lookupDTyConEnv,+        delFromDTyConEnv, filterDTyConEnv,+        mapDTyConEnv, mapMaybeDTyConEnv,+        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv+    ) where++import GHC.Prelude++import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Core.TyCon (TyCon)++import GHC.Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection{TyCon environment}+*                                                                      *+************************************************************************+-}++-- | TyCon Environment+type TyConEnv a = UniqFM TyCon a       -- Domain is TyCon++emptyTyConEnv       :: TyConEnv a+isEmptyTyConEnv     :: TyConEnv a -> Bool+mkTyConEnv          :: [(TyCon,a)] -> TyConEnv a+mkTyConEnvWith      :: (a -> TyCon) -> [a] -> TyConEnv a+nonDetTyConEnvElts  :: TyConEnv a -> [a]+alterTyConEnv       :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a+extendTyConEnv_C    :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a+extendTyConEnv_Acc  :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b+extendTyConEnv      :: TyConEnv a -> TyCon -> a -> TyConEnv a+plusTyConEnv        :: TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_C      :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_CD     :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a+plusTyConEnv_CD2    :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+extendTyConEnvList  :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a+extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a+delFromTyConEnv     :: TyConEnv a -> TyCon -> TyConEnv a+delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a+elemTyConEnv        :: TyCon -> TyConEnv a -> Bool+unitTyConEnv        :: TyCon -> a -> TyConEnv a+lookupTyConEnv      :: TyConEnv a -> TyCon -> Maybe a+lookupTyConEnv_NF   :: TyConEnv a -> TyCon -> a+filterTyConEnv      :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt+anyTyConEnv         :: (elt -> Bool) -> TyConEnv elt -> Bool+mapTyConEnv         :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2+disjointTyConEnv    :: TyConEnv a -> TyConEnv a -> Bool++nonDetTyConEnvElts x   = nonDetEltsUFM x+emptyTyConEnv          = emptyUFM+isEmptyTyConEnv        = isNullUFM+unitTyConEnv x y       = unitUFM x y+extendTyConEnv x y z   = addToUFM x y z+extendTyConEnvList x l = addListToUFM x l+lookupTyConEnv x y     = lookupUFM x y+alterTyConEnv          = alterUFM+mkTyConEnv     l       = listToUFM l+mkTyConEnvWith f       = mkTyConEnv . map (\a -> (f a, a))+elemTyConEnv x y          = elemUFM x y+plusTyConEnv x y          = plusUFM x y+plusTyConEnv_C f x y      = plusUFM_C f x y+plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b+plusTyConEnv_CD2 f x y    = plusUFM_CD2 f x y+extendTyConEnv_C f x y z  = addToUFM_C f x y z+mapTyConEnv f x           = mapUFM f x+extendTyConEnv_Acc x y z a b  = addToUFM_Acc x y z a b+extendTyConEnvList_C x y z = addListToUFM_C x y z+delFromTyConEnv x y      = delFromUFM x y+delListFromTyConEnv x y  = delListFromUFM x y+filterTyConEnv x y       = filterUFM x y+anyTyConEnv f x          = nonDetFoldUFM ((||) . f) False x+disjointTyConEnv x y     = disjointUFM x y++lookupTyConEnv_NF env n = expectJust (lookupTyConEnv env n)++-- | Deterministic TyCon Environment+--+-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why+-- we need DTyConEnv.+type DTyConEnv a = UniqDFM TyCon a++emptyDTyConEnv :: DTyConEnv a+emptyDTyConEnv = emptyUDFM++isEmptyDTyConEnv :: DTyConEnv a -> Bool+isEmptyDTyConEnv = isNullUDFM++lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a+lookupDTyConEnv = lookupUDFM++delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a+delFromDTyConEnv = delFromUDFM++filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a+filterDTyConEnv = filterUDFM++mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b+mapDTyConEnv = mapUDFM++mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b+mapMaybeDTyConEnv = mapMaybeUDFM++adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a+adjustDTyConEnv = adjustUDFM++alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a+alterDTyConEnv = alterUDFM++extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a+extendDTyConEnv = addToUDFM++foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a+foldDTyConEnv = foldUDFM
+ GHC/Core/TyCon/RecWalk.hs view
@@ -0,0 +1,101 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Check for recursive type constructors.++-}++++module GHC.Core.TyCon.RecWalk (++        -- * Recursion breaking+        RecTcChecker, initRecTc, defaultRecTcMaxBound,+        setRecTcMaxBound, checkRecTc++    ) where++import GHC.Prelude++import GHC.Core.TyCon+import GHC.Core.TyCon.Env+import GHC.Utils.Outputable++{-+************************************************************************+*                                                                      *+           Walking over recursive TyCons+*                                                                      *+************************************************************************++Note [Expanding newtypes and products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When expanding a type to expose a data-type constructor, we need to be+careful about newtypes, lest we fall into an infinite loop. Here are+the key examples:++  newtype Id  x = MkId x+  newtype Fix f = MkFix (f (Fix f))+  newtype T     = MkT (T -> T)++  Type           Expansion+ --------------------------+  T              T -> T+  Fix Maybe      Maybe (Fix Maybe)+  Id (Id Int)    Int+  Fix Id         NO NO NO++Notice that+ * We can expand T, even though it's recursive.+ * We can expand Id (Id Int), even though the Id shows up+   twice at the outer level, because Id is non-recursive++So, when expanding, we keep track of when we've seen a recursive+newtype at outermost level; and bail out if we see it again.++We sometimes want to do the same for product types, so that the+strictness analyser doesn't unbox infinitely deeply.++More precisely, we keep a *count* of how many times we've seen it.+This is to account for+   data instance T (a,b) = MkT (T a) (T b)+Then (#10482) if we have a type like+        T (Int,(Int,(Int,(Int,Int))))+we can still unbox deeply enough during strictness analysis.+We have to treat T as potentially recursive, but it's still+good to be able to unwrap multiple layers.++The function that manages all this is checkRecTc.+-}++data RecTcChecker = RC !Int (TyConEnv Int)+  -- The upper bound, and the number of times+  -- we have encountered each TyCon++instance Outputable RecTcChecker where+  ppr (RC n env) = text "RC:" <> int n <+> ppr env++-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.+initRecTc :: RecTcChecker+initRecTc = RC defaultRecTcMaxBound emptyTyConEnv++-- | The default upper bound (100) for the number of times a 'RecTcChecker' is+-- allowed to encounter each 'TyCon'.+defaultRecTcMaxBound :: Int+defaultRecTcMaxBound = 100+-- Should we have a flag for this?++-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed+-- to encounter each 'TyCon'.+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts++checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker+-- Nothing      => Recursion detected+-- Just rec_tcs => Keep going+checkRecTc (RC bound rec_nts) tc+  = case lookupTyConEnv rec_nts tc of+      Just n | n >= bound -> Nothing+             | otherwise  -> Just (RC bound (extendTyConEnv rec_nts tc (n+1)))+      Nothing             -> Just (RC bound (extendTyConEnv rec_nts tc 1))
+ GHC/Core/TyCon/Set.hs view
@@ -0,0 +1,71 @@+{-+(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
+ GHC/Core/Type.hs view
@@ -0,0 +1,3438 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1998+--+-- Type - public interface++{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Main functions for manipulating types and type-related things+module GHC.Core.Type (+        -- Note some of this is just re-exports from TyCon..++        -- * Main data types representing Types+        -- $type_classification++        -- $representation_types+        Type, ForAllTyFlag(..), FunTyFlag(..),+        Specificity(..),+        KindOrType, PredType, ThetaType, FRRType,+        Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder,+        Mult, Scaled,+        KnotTied, RuntimeRepType,++        -- ** Constructing and deconstructing types+        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,+        getCastedTyVar_maybe, tyVarKind, varType,++        mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView,+        splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe,++        mkFunTy, mkVisFunTy,+        mkVisFunTyMany, mkVisFunTysMany,+        mkScaledFunTys,+        mkInvisFunTy, mkInvisFunTys,+        tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy,+        splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe,+        splitFunTys, funResultTy, funArgTy,+        funTyConAppTy_maybe, funTyFlagTyCon,+        tyConAppFunTy_maybe, tyConAppFunCo_maybe,+        mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag,++        mkTyConApp, mkTyConTy,+        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,+        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,++        splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp,+        tcSplitTyConApp, tcSplitTyConApp_maybe,++        mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,+        mkSpecForAllTy, mkSpecForAllTys,+        mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy,+        mkInfForAllTy, mkInfForAllTys,+        splitForAllTyCoVars, splitForAllTyVars,+        splitForAllReqTyBinders, splitForAllInvisTyBinders,+        splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,+        splitForAllTyCoVar_maybe, splitForAllTyCoVar,+        splitForAllTyVar_maybe, splitForAllCoVar_maybe,+        splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,+        getRuntimeArgTys,+        mkTyConBindersPreferAnon,+        mkPiTy, mkPiTys,+        piResultTy, piResultTys,+        applyTysX, dropForAlls,+        mkFamilyTyConApp,+        buildSynTyCon,++        mkNumLitTy, isNumLitTy,+        mkStrLitTy, isStrLitTy,+        mkCharLitTy, isCharLitTy,+        isLitTy,++        getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,+        getLevity, levityType_maybe,++        mkCastTy, mkCoercionTy, splitCastTy_maybe,++        ErrorMsgType,+        userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy,++        coAxNthLHS,+        stripCoercionTy,++        splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,+        filterOutInvisibleTypes, filterOutInferredTypes,+        partitionInvisibleTypes, partitionInvisibles,+        tyConForAllTyFlags, appTyForAllTyFlags,++        -- ** Analyzing types+        TyCoMapper(..), mapTyCo, mapTyCoX,+        TyCoFolder(..), foldTyCo, noView,++        -- (Newtypes)+        newTyConInstRhs,++        -- ** Binders+        mkForAllTyBinder, mkForAllTyBinders,+        mkTyVarBinder, mkTyVarBinders,+        tyVarSpecToBinders,+        isAnonPiTyBinder,+        binderVar, binderVars, binderType, binderFlag, binderFlags,+        piTyBinderType, namedPiTyBinder_maybe,+        anonPiTyBinderType_maybe,+        isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder,+        isInvisiblePiTyBinder, isNamedPiTyBinder,+        tyConBindersPiTyBinders,++        -- ** Predicates on types+        isTyVarTy, isFunTy, isCoercionTy,+        isCoercionTy_maybe, isForAllTy,+        isForAllTy_ty, isForAllTy_co,+        isForAllTy_invis_ty,+        isPiTy, isTauTy, isFamFreeTy,+        isAtomicTy,++        isValidJoinPointType,+        tyConAppNeedsKindSig,++        -- * Space-saving construction+        mkTYPEapp, mkTYPEapp_maybe,+        mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,+        mkBoxedRepApp_maybe, mkTupleRepApp_maybe,+        typeOrConstraintKind, liftedTypeOrConstraintKind,++        -- *** Levity and boxity+        sORTKind_maybe, typeTypeOrConstraint,+        typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT,+        isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,+        isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,+        isBoxedRuntimeRep,+        isLiftedLevity, isUnliftedLevity,+        isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,+        kindBoxedRepLevity_maybe,+        mightBeLiftedType, mightBeUnliftedType,+        definitelyLiftedType, definitelyUnliftedType,+        isAlgType, isDataFamilyApp, isSatTyFamApp,+        isPrimitiveType, isStrictType, isTerminatingType,+        isLevityTy, isLevityVar,+        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,+        dropRuntimeRepArgs,++        -- * Multiplicity++        isMultiplicityTy, isMultiplicityVar,+        unrestricted, linear, tymult,+        mkScaled, irrelevantMult, scaledSet,+        pattern OneTy, pattern ManyTy,+        isOneTy, isManyTy,+        isLinearType,++        -- * Main data types representing Kinds+        Kind,++        -- ** Finding the kind of a type+        typeKind, typeHasFixedRuntimeRep,+        tcIsLiftedTypeKind,+        isConstraintKind, isConstraintLikeKind, returnsConstraintKind,+        tcIsBoxedTypeKind, isTypeLikeKind,++        -- ** Common Kind+        liftedTypeKind, unliftedTypeKind,++        -- * Type free variables+        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,+        tyCoVarsOfType, tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet,+        coVarsOfType,+        coVarsOfTypes,++        anyFreeVarsOfType, anyFreeVarsOfTypes,+        noFreeVarsOfType,+        expandTypeSynonyms, expandSynTyConApp_maybe,+        typeSize, occCheckExpand,++        -- ** Closing over kinds+        closeOverKindsDSet, closeOverKindsList,+        closeOverKinds,++        -- * Forcing evaluation of types+        seqType, seqTypes,++        -- * Other views onto Types+        coreView, coreFullView, rewriterView,++        tyConsOfType,++        -- * Main type substitution data types+        TvSubstEnv,     -- Representation widely visible+        IdSubstEnv,+        Subst(..),    -- Representation visible to a few friends++        -- ** Manipulating type substitutions+        emptyTvSubstEnv, emptySubst, mkEmptySubst,++        mkTCvSubst, zipTvSubst, mkTvSubstPrs,+        zipTCvSubst,+        notElemSubst,+        getTvSubstEnv,+        zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs,+        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,+        extendTCvSubst, extendCvSubst,+        extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,+        extendTCvSubstList,+        extendTvSubstWithClone,+        extendTCvSubstWithClone,+        isInScope, composeTCvSubst, zipTyEnv, zipCoEnv,+        isEmptySubst, unionSubst, isEmptyTCvSubst,++        -- ** Performing substitution on types and kinds+        substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta,+        substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,+        substThetaUnchecked, substTyWithUnchecked,+        substCo, substCoUnchecked, substCoWithUnchecked,+        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,+        substVarBndr, substVarBndrs,+        substTyCoBndr, substTyVarToTyVar,+        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,++        -- * Kinds+        isTYPEorCONSTRAINT,+        isConcreteType,+        isFixedRuntimeRepKind+    ) where++import GHC.Prelude++import GHC.Types.Basic++-- We import the representation and primitive functions from GHC.Core.TyCo.Rep.+-- Many things are reexported, but not the representation!++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs++-- friends:+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set++import GHC.Core.TyCon+import GHC.Builtin.Types.Prim++import {-# SOURCE #-} GHC.Builtin.Types+   ( charTy, naturalTy+   , typeSymbolKind, liftedTypeKind, unliftedTypeKind+   , constraintKind, zeroBitTypeKind+   , manyDataConTy, oneDataConTy+   , liftedRepTy, unliftedRepTy, zeroBitRepTy )++import GHC.Types.Name( Name )+import GHC.Builtin.Names+import GHC.Core.Coercion.Axiom++import {-# SOURCE #-} GHC.Core.Coercion+   ( mkNomReflCo, mkGReflCo, mkReflCo+   , mkTyConAppCo, mkAppCo+   , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo+   , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo+   , mkKindCo, mkSubCo, mkFunCo, funRole+   , decomposePiCos, coercionKind+   , coercionRKind, coercionType+   , isReflexiveCo, seqCo+   , topNormaliseNewType_maybe+   )+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar )++-- others+import GHC.Utils.Misc+import GHC.Utils.FV+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString++import GHC.Data.Maybe   ( orElse, isJust, firstJust )+import GHC.List (build)++-- $type_classification+-- #type_classification#+--+-- Types are any, but at least one, of:+--+-- [Boxed]              Iff its representation is a pointer to an object on the+--                      GC'd heap. Operationally, heap objects can be entered as+--                      a means of evaluation.+--+-- [Lifted]             Iff it has bottom as an element: An instance of a+--                      lifted type might diverge when evaluated.+--                      GHC Haskell's unboxed types are unlifted.+--                      An unboxed, but lifted type is not very useful.+--                      (Example: A byte-represented type, where evaluating 0xff+--                      computes the 12345678th collatz number modulo 0xff.)+--                      Only lifted types may be unified with a type variable.+--+-- [Algebraic]          Iff it is a type with one or more constructors, whether+--                      declared with @data@ or @newtype@.+--                      An algebraic type is one that can be deconstructed+--                      with a case expression. There are algebraic types that+--                      are not lifted types, like unlifted data types or+--                      unboxed tuples.+--+-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.+--                      There are also /unlifted/ data types.+--+-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.+--+-- [Unlifted]           Anything that isn't lifted is considered unlifted.+--+-- Currently, all primitive types are unlifted, but that's not necessarily+-- the case: for example, @Int@ could be primitive.+--+-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed+-- but unlifted (such as @ByteArray#@).  The only primitive types that we+-- classify as algebraic are the unboxed tuples.+--+-- Some examples of type classifications that may make this a bit clearer are:+--+-- @+-- Type          primitive       boxed           lifted          algebraic+-- -----------------------------------------------------------------------------+-- Int#          Yes             No              No              No+-- ByteArray#    Yes             Yes             No              No+-- (\# a, b \#)  Yes             No              No              Yes+-- (\# a | b \#) Yes             No              No              Yes+-- (  a, b  )    No              Yes             Yes             Yes+-- [a]           No              Yes             Yes             Yes+-- @++-- $representation_types+-- A /source type/ is a type that is a separate type as far as the type checker is+-- concerned, but which has a more low-level representation as far as Core-to-Core+-- passes and the rest of the back end is concerned.+--+-- You don't normally have to worry about this, as the utility functions in+-- this module will automatically convert a source into a representation type+-- if they are spotted, to the best of its abilities. If you don't want this+-- to happen, use the equivalent functions from the "TcType" module.++{-+************************************************************************+*                                                                      *+                Type representation+*                                                                      *+************************************************************************+-}++rewriterView :: Type -> Maybe Type+-- 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]+{-# INLINE rewriterView #-}+rewriterView (TyConApp tc tys)+  | isTypeSynonymTyCon tc+  , isForgetfulSynTyCon tc || not (isFamFreeTyCon tc)+  = expandSynTyConApp_maybe tc tys+rewriterView _other+  = Nothing++coreView :: Type -> Maybe Type+-- ^ This function strips off the /top layer only/ of a type synonym+-- application (if any) its underlying representation type.+-- Returns 'Nothing' if there is nothing to look through.+--+-- This function does not look through type family applications.+--+-- By being non-recursive and inlined, this case analysis gets efficiently+-- joined onto the case analysis that the caller is already doing+coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys+coreView _                 = Nothing+-- See Note [Inlining coreView].+{-# INLINE coreView #-}++coreFullView, core_full_view :: Type -> Type+-- ^ Iterates 'coreView' until there is no more to synonym to expand.+-- NB: coreFullView is non-recursive and can be inlined;+--     core_full_view is the recursive one+-- See Note [Inlining coreView].+coreFullView ty@(TyConApp tc _)+  | isTypeSynonymTyCon tc = core_full_view ty+coreFullView ty = ty+{-# INLINE coreFullView #-}++core_full_view ty+  | Just ty' <- coreView ty = core_full_view ty'+  | otherwise               = ty++-----------------------------------------------+-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a+-- synonym.+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type+{-# INLINE expandSynTyConApp_maybe #-}+-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView,+-- which will eliminate the allocation Just/Nothing in the result+-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the+-- Just/Nothing, else you'll increase allocation+expandSynTyConApp_maybe tc arg_tys+  | Just (tvs, rhs) <- synTyConDefn_maybe tc+  , arg_tys `saturates` tyConArity tc+  = Just $! (expand_syn tvs rhs arg_tys)+    -- Why strict application? Because every client of this function will evaluat+    -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk.+    -- Mind you, this function is always INLINEd, so the client context is probably+    -- enough to avoid thunk construction and so the $! is just belt-and-braces.+  | otherwise+  = Nothing++saturates :: [Type] -> Arity -> Bool+saturates _       0 = True+saturates []      _ = False+saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1)+                       -- Arities are always positive; the assertion just checks+                       -- that, to avoid an infinite loop in the bad case++-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path+-- into call-sites.+--+-- Precondition: the call is saturated or over-saturated;+--               i.e. length tvs <= length arg_tys+expand_syn :: [TyVar]  -- ^ the variables bound by the synonym+           -> Type     -- ^ the RHS of the synonym+           -> [Type]   -- ^ the type arguments the synonym is instantiated at.+           -> Type+{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path.++expand_syn tvs rhs arg_tys+  -- No substitution necessary if either tvs or tys is empty+  -- This is both more efficient, and steers clear of an infinite+  -- loop; see Note [Care using synonyms to compress types]+  | null arg_tys  = assert (null tvs) rhs+  | null tvs      = mkAppTys rhs arg_tys+  | otherwise     = go empty_subst tvs arg_tys+  where+    empty_subst = mkEmptySubst in_scope+    in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys+      -- The free vars of 'rhs' should all be bound by 'tenv',+      -- so we only need the free vars of tys+      -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.++    go subst [] tys+      | null tys  = rhs'  -- Exactly Saturated+      | otherwise = mkAppTys rhs' tys+          -- Its important to use mkAppTys, rather than (foldl AppTy),+          -- because the function part might well return a+          -- partially-applied type constructor; indeed, usually will!+      where+        rhs' = substTy subst rhs++    go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys++    go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys)+                   -- Under-saturated, precondition failed++{- Note [Inlining coreView]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very common to have a function++  f :: Type -> ...+  f ty | Just ty' <- coreView ty = f ty'+  f (TyVarTy ...) = ...+  f ...           = ...++If f is not otherwise recursive, the initial call to coreView+causes f to become recursive, which kills the possibility of+inlining. Instead, for non-recursive functions, we prefer to+use coreFullView, which guarantees to unwrap top-level type+synonyms. It can be inlined and is efficient and non-allocating+in its fast path. For this to really be fast, all calls made+on its fast path must also be inlined, linked back to this Note.+-}+++{- *********************************************************************+*                                                                      *+                expandTypeSynonyms+*                                                                      *+********************************************************************* -}++expandTypeSynonyms :: Type -> Type+-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out+-- just the ones that discard type variables (e.g.  type Funny a = Int)+-- But we don't know which those are currently, so we just expand all.+--+-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,+-- not in the kinds of any TyCon or TyVar mentioned in the type.+--+-- Keep this synchronized with 'synonymTyConsOfType'+expandTypeSynonyms ty+  = go (mkEmptySubst in_scope) ty+  where+    in_scope = mkInScopeSet (tyCoVarsOfType ty)++    go subst (TyConApp tc tys)+      | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys+      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)+            -- Make a fresh substitution; rhs has nothing to+            -- do with anything that has happened so far+            -- NB: if you make changes here, be sure to build an+            --     /idempotent/ substitution, even in the nested case+            --        type T a b = a -> b+            --        type S x y = T y x+            -- (#11665)+        in  mkAppTys (go subst' rhs) tys'+      | otherwise+      = TyConApp tc expanded_tys+      where+        expanded_tys = (map (go subst) tys)++    go _     (LitTy l)     = LitTy l+    go subst (TyVarTy tv)  = substTyVar subst tv+    go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)+    go subst ty@(FunTy _ mult arg res)+      = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res }+    go subst (ForAllTy (Bndr tv vis) t)+      = let (subst', tv') = substVarBndrUsing go subst tv in+        ForAllTy (Bndr tv' vis) (go subst' t)+    go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)+    go subst (CoercionTy co) = mkCoercionTy (go_co subst co)++    go_mco _     MRefl    = MRefl+    go_mco subst (MCo co) = MCo (go_co subst co)++    go_co subst (Refl ty)+      = mkNomReflCo (go subst ty)+    go_co subst (GRefl r ty mco)+      = mkGReflCo r (go subst ty) (go_mco subst mco)+       -- NB: coercions are always expanded upon creation+    go_co subst (TyConAppCo r tc args)+      = mkTyConAppCo r tc (map (go_co subst) args)+    go_co subst (AppCo co arg)+      = mkAppCo (go_co subst co) (go_co subst arg)+    go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                          , fco_kind = kind_co, fco_body = co })+      = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in+        mkForAllCo tv' visL visR kind_co' (go_co subst' co)+    go_co subst (FunCo r afl afr w co1 co2)+      = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)+    go_co subst (CoVarCo cv)+      = substCoVar subst cv+    go_co subst (AxiomCo ax cs)+      = mkAxiomCo ax (map (go_co subst) cs)+    go_co subst co@(UnivCo { uco_lty = lty, uco_rty = rty })+      = co { uco_lty = go subst lty, uco_rty = go subst rty }+    go_co subst (SymCo co)+      = mkSymCo (go_co subst co)+    go_co subst (TransCo co1 co2)+      = mkTransCo (go_co subst co1) (go_co subst co2)+    go_co subst (SelCo n co)+      = mkSelCo n (go_co subst co)+    go_co subst (LRCo lr co)+      = mkLRCo lr (go_co subst co)+    go_co subst (InstCo co arg)+      = mkInstCo (go_co subst co) (go_co subst arg)+    go_co subst (KindCo co)+      = mkKindCo (go_co subst co)+    go_co subst (SubCo co)+      = mkSubCo (go_co subst co)+    go_co _ (HoleCo h)+      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)++    go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst++{- Notes on type synonyms+~~~~~~~~~~~~~~~~~~~~~~~~~+The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try+to return type synonyms wherever possible. Thus++        type Foo a = a -> a++we want+        splitFunTys (a -> Foo a) = ([a], Foo a)+not                                ([a], a -> a)++The reason is that we then get better (shorter) type signatures in+interfaces.  Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind.+-}++{- *********************************************************************+*                                                                      *+                Random functions (todo: organise)+*                                                                      *+********************************************************************* -}++-- | An INLINE helper for function such as 'kindRep_maybe' below.+--+-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff+-- the type @ty = T tys@, where T's unique = key+-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`.+-- Thanks to this fact, we don't have to pattern match on `FunTy` here.+isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]+isTyConKeyApp_maybe key ty+  | TyConApp tc args <- coreFullView ty+  , tc `hasKey` key+  = Just args+  | otherwise+  = Nothing+{-# INLINE isTyConKeyApp_maybe #-}++-- | Extract the RuntimeRep classifier of a type from its kind. For example,+-- @kindRep * = LiftedRep@; Panics if this is not possible.+-- Treats * and Constraint as the same+kindRep :: HasDebugCallStack => Kind -> RuntimeRepType+kindRep k = case kindRep_maybe k of+              Just r  -> r+              Nothing -> pprPanic "kindRep" (ppr k)++-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr.+-- For example, @kindRep_maybe * = Just LiftedRep@+-- Returns 'Nothing' if the kind is not of form (TYPE rr)+kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType+kindRep_maybe kind+  | Just (_, rep) <- sORTKind_maybe kind = Just rep+  | otherwise                            = Nothing++-- | Returns True if the argument is (lifted) Type or Constraint+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim+isLiftedTypeKind :: Kind -> Bool+isLiftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isLiftedRuntimeRep rep+      Nothing  -> False++-- | Returns True if the kind classifies unlifted types (like 'Int#') and False+-- otherwise. Note that this returns False for representation-polymorphic+-- kinds, which may be specialized to a kind that classifies unlifted types.+isUnliftedTypeKind :: Kind -> Bool+isUnliftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isUnliftedRuntimeRep rep+      Nothing  -> False++pickyIsLiftedTypeKind :: Kind -> Bool+-- Checks whether the kind is literally+--      TYPE LiftedRep+-- or   TYPE ('BoxedRep 'Lifted)+-- or   Type+-- without expanding type synonyms or anything+-- Used only when deciding whether to suppress the ":: *" in+-- (a :: *) when printing kinded type variables+-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr+pickyIsLiftedTypeKind kind+  | TyConApp tc [arg] <- kind+  , tc `hasKey` tYPETyConKey+  , TyConApp rr_tc rr_args <- arg = case rr_args of+      [] -> rr_tc `hasKey` liftedRepTyConKey+      [rr_arg]+        | rr_tc `hasKey` boxedRepDataConKey+        , TyConApp lev [] <- rr_arg+        , lev `hasKey` liftedDataConKey -> True+      _ -> False+  | TyConApp tc [] <- kind+  , tc `hasKey` liftedTypeKindTyConKey = True+  | otherwise                          = False++-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)`+-- or `TYPE (BoxedRep Unlifted)`.+--+-- Returns:+--+--  - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`,+--  - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`,+--  - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc.+kindBoxedRepLevity_maybe :: Type -> Maybe Levity+kindBoxedRepLevity_maybe ty+  | Just rep <- kindRep_maybe ty+  , isBoxedRuntimeRep rep+  = runtimeRepLevity_maybe rep+  | otherwise+  = Nothing++-- | Check whether a type of kind 'RuntimeRep' is lifted.+--+-- 'isLiftedRuntimeRep' is:+--+--  * True of @LiftedRep :: RuntimeRep@+--  * False of type variables, type family applications,+--    and of other reps such as @IntRep :: RuntimeRep@.+isLiftedRuntimeRep :: RuntimeRepType -> Bool+isLiftedRuntimeRep rep+  = runtimeRepLevity_maybe rep == Just Lifted++-- | Check whether a type of kind 'RuntimeRep' is unlifted.+--+--  * True of definitely unlifted 'RuntimeRep's such as+--    'UnliftedRep', 'IntRep', 'FloatRep', ...+--  * False of 'LiftedRep',+--  * False for type variables and type family applications.+isUnliftedRuntimeRep :: RuntimeRepType -> Bool+isUnliftedRuntimeRep rep =+  runtimeRepLevity_maybe rep == Just Unlifted++-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'.+--+-- Checks whether the type is a nullary 'TyCon' application,+-- for a 'TyCon' with the given 'Unique'.+isNullaryTyConKeyApp :: Unique -> Type -> Bool+isNullaryTyConKeyApp key ty+  | Just args <- isTyConKeyApp_maybe key ty+  = assert (null args) True+  | otherwise+  = False+{-# INLINE isNullaryTyConKeyApp #-}++isLiftedLevity :: Type -> Bool+isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey++isUnliftedLevity :: Type -> Bool+isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey++-- | Is this the type 'Levity'?+isLevityTy :: Type -> Bool+isLevityTy = isNullaryTyConKeyApp levityTyConKey++-- | Is this the type 'RuntimeRep'?+isRuntimeRepTy :: Type -> Bool+isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey++-- | Is a tyvar of type 'RuntimeRep'?+isRuntimeRepVar :: TyVar -> Bool+isRuntimeRepVar = isRuntimeRepTy . tyVarKind++-- | Is a tyvar of type 'Levity'?+isLevityVar :: TyVar -> Bool+isLevityVar = isLevityTy . tyVarKind++-- | Is this the type 'Multiplicity'?+isMultiplicityTy :: Type -> Bool+isMultiplicityTy  = isNullaryTyConKeyApp multiplicityTyConKey++-- | Is a tyvar of type 'Multiplicity'?+isMultiplicityVar :: TyVar -> Bool+isMultiplicityVar = isMultiplicityTy . tyVarKind++--------------------------------------------+--  Splitting RuntimeRep+--------------------------------------------++-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and+--   returns the (TyCon,[Type]) for the RuntimeRep, if possible, where+--   the TyCon is one of the promoted DataCons of RuntimeRep.+-- Remember: the unique on TyCon that is a a promoted DataCon is the+--           same as the unique on the DataCon+--           See Note [Promoted data constructors] in GHC.Core.TyCon+-- May not be possible if `rr` is a type variable or type+--   family application+splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type])+splitRuntimeRep_maybe rep+  | TyConApp rr_tc args <- coreFullView rep+  , isPromotedDataCon rr_tc+    -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep,+  = Just (rr_tc, args)+  | otherwise+  = Nothing++-- | See 'isBoxedRuntimeRep_maybe'.+isBoxedRuntimeRep :: RuntimeRepType -> Bool+isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)++-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`+-- expands to `Boxed lev` and returns `Nothing` otherwise.+--+-- Types with this runtime rep are represented by pointers on the GC'd heap.+isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType+isBoxedRuntimeRep_maybe rep+  | Just (rr_tc, args) <- splitRuntimeRep_maybe rep+  , rr_tc `hasKey` boxedRepDataConKey+  , [lev] <- args+  = Just lev+  | otherwise+  = Nothing++-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted,+--   or unknown.  Returns Nothing if the type isn't of kind 'RuntimeRep'.+--+-- `runtimeRepLevity_maybe rr` returns:+--+--   * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep`+--   * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`+--   * `Nothing` if not known (e.g. it's a type variable or a type family application).+runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity+runtimeRepLevity_maybe rep+  | Just (rr_tc, args) <- splitRuntimeRep_maybe rep+  =       -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]+    if (rr_tc `hasKey` boxedRepDataConKey)+    then case args of+            [lev] -> levityType_maybe lev+            _     -> Nothing  -- Type isn't of kind RuntimeRep+                     -- The latter case happens via the call to isLiftedRuntimeRep+                     -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742)+    else Just Unlifted+        -- Avoid searching all the unlifted RuntimeRep type cons+        -- In the RuntimeRep data type, only LiftedRep is lifted+  | otherwise+  = Nothing++--------------------------------------------+--  Splitting Levity+--------------------------------------------++-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity+-- May not be possible for a type variable or type family application+levityType_maybe :: LevityType -> Maybe Levity+levityType_maybe lev+  | TyConApp lev_tc args <- coreFullView lev+  = if | lev_tc `hasKey` liftedDataConKey   -> assert( null args) $ Just Lifted+       | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted+       | otherwise                          -> Nothing+  | otherwise+  = Nothing+++{- *********************************************************************+*                                                                      *+               mapType+*                                                                      *+************************************************************************++These functions do a map-like operation over types, performing some operation+on all variables and binding sites. Primarily used for zonking.++Note [Efficiency for ForAllCo case of mapTyCoX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.+It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches+the left-hand kind of the coercion. This is convenient lots of the time, but+not when mapping a function over a coercion.++The problem is that tcm_tybinder will affect the TyCoVar's kind and+mapCoercion will affect the Coercion, and we hope that the results will be+the same. Even if they are the same (which should generally happen with+correct algorithms), then there is an efficiency issue. In particular,+this problem seems to make what should be a linear algorithm into a potentially+exponential one. But it's only going to be bad in the case where there's+lots of foralls in the kinds of other foralls. Like this:++  forall a : (forall b : (forall c : ...). ...). ...++This construction seems unlikely. So we'll do the inefficient, easy way+for now.++Note [Specialising mappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used+to implement zonking, and it's vital that they get specialised to the TcM+monad and the particular mapper in use.++Even specialising to the monad alone made a 20% allocation difference+in perf/compiler/T5030.++See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this+idiom.+-}++-- | This describes how a "map" operation over a type/coercion should behave+data TyCoMapper env m+  = TyCoMapper+      { tcm_tyvar :: env -> TyVar -> m Type+      , tcm_covar :: env -> CoVar -> m Coercion+      , tcm_hole  :: env -> CoercionHole -> m Coercion+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".++      , tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag+                       -> (env -> TyCoVar -> m r) -> m r+          -- ^ The returned env is used in the extended scope++      , tcm_tycon :: TyCon -> m TyCon+          -- ^ This is used only for TcTyCons+          -- a) To zonk TcTyCons+          -- b) To turn TcTyCons into TyCons.+          --    See Note [Type checking recursive type and class declarations]+          --    in "GHC.Tc.TyCl"+      }++{-# INLINE mapTyCo #-}  -- See Note [Specialising mappers]+mapTyCo :: Monad m => TyCoMapper () m+        -> ( Type       -> m  Type+           , [Type]     -> m  [Type]+           , Coercion   -> m  Coercion+           , [Coercion] -> m [Coercion] )+mapTyCo mapper+  = case mapTyCoX mapper of+     (go_ty, go_tys, go_co, go_cos)+        -> (go_ty (), go_tys (), go_co (), go_cos ())++{-# INLINE mapTyCoX #-}  -- See Note [Specialising mappers]+mapTyCoX :: forall m env. Monad m+         => TyCoMapper env m+         -> ( env -> Type       -> m Type+            , env -> [Type]     -> m [Type]+            , env -> Coercion   -> m Coercion+            , env -> [Coercion] -> m [Coercion] )+mapTyCoX (TyCoMapper { tcm_tyvar = tyvar+                     , tcm_tycobinder = tycobinder+                     , tcm_tycon = tycon+                     , tcm_covar = covar+                     , tcm_hole = cohole })+  = (go_ty, go_tys, go_co, go_cos)+  where+    -- See Note [Use explicit recursion in mapTyCo]+    go_tys !_   []       = return []+    go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys++    go_ty !env (TyVarTy tv)    = tyvar env tv+    go_ty !env (AppTy t1 t2)   = mkAppTy <$> go_ty env t1 <*> go_ty env t2+    go_ty !_   ty@(LitTy {})   = return ty+    go_ty !env (CastTy ty co)  = mkCastTy <$> go_ty env ty <*> go_co env co+    go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co++    go_ty !env ty@(FunTy _ w arg res)+      = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res+           ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) }++    go_ty !env ty@(TyConApp tc tys)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConApp tc' <$> go_tys env tys }++      -- Not a TcTyCon+      | null tys    -- Avoid allocation in this very+      = return ty   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConApp tc <$> go_tys env tys++    go_ty !env (ForAllTy (Bndr tv vis) inner)+      = do { tycobinder env tv vis $ \env' tv' -> do+           ; inner' <- go_ty env' inner+           ; return $ ForAllTy (Bndr tv' vis) inner' }++    -- See Note [Use explicit recursion in mapTyCo]+    go_cos !_   []       = return []+    go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos++    go_mco !_   MRefl    = return MRefl+    go_mco !env (MCo co) = MCo <$> (go_co env co)++    go_co :: env -> Coercion -> m Coercion+    go_co !env (Refl ty)                  = Refl <$> go_ty env ty+    go_co !env (GRefl r ty mco)           = mkGReflCo r <$> go_ty env ty <*> go_mco env mco+    go_co !env (AppCo c1 c2)              = mkAppCo <$> go_co env c1 <*> go_co env c2+    go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw+                                           <*> go_co env c1 <*> go_co env c2+    go_co !env (CoVarCo cv)               = covar env cv+    go_co !env (HoleCo hole)              = cohole env hole+    go_co !env (UnivCo { uco_prov = p, uco_role = r+                       , uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                          = mkUnivCo <$> pure p+                                                     <*> go_cos env deps+                                                     <*> pure r+                                                     <*> go_ty env t1 <*> go_ty env t2+    go_co !env (SymCo co)                 = mkSymCo <$> go_co env co+    go_co !env (TransCo c1 c2)            = mkTransCo <$> go_co env c1 <*> go_co env c2+    go_co !env (AxiomCo r cos)            = mkAxiomCo r <$> go_cos env cos+    go_co !env (SelCo i co)               = mkSelCo i <$> go_co env co+    go_co !env (LRCo lr co)               = mkLRCo lr <$> go_co env co+    go_co !env (InstCo co arg)            = mkInstCo <$> go_co env co <*> go_co env arg+    go_co !env (KindCo co)                = mkKindCo <$> go_co env co+    go_co !env (SubCo co)                 = mkSubCo <$> go_co env co+    go_co !env co@(TyConAppCo r tc cos)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConAppCo r tc' <$> go_cos env cos }++      -- Not a TcTyCon+      | null cos    -- Avoid allocation in this very+      = return co   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConAppCo r tc <$> go_cos env cos+    go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = co })+      = do { kind_co' <- go_co env kind_co+           ; tycobinder env tv visL $ \env' tv' ->  do+           ; co' <- go_co env' co+           ; return $ mkForAllCo tv' visL visR kind_co' co' }+        -- See Note [Efficiency for ForAllCo case of mapTyCoX]+++{- Note [Use explicit recursion in mapTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`,+for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in+GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order+functions makes the strictness analyser produce worse results.++We could probably use `foldr`, since it is inlined bodily, fairly early; but+I'm doing the simple thing and inlining it by hand.++See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is+definitely not inlined bodily).+-}++{- *********************************************************************+*                                                                      *+                      TyVarTy+*                                                                      *+********************************************************************* -}++-- | Attempts to obtain the type variable underlying a 'Type', and panics with the+-- given message if this is not a type variable type. See also 'getTyVar_maybe'+getTyVar :: HasDebugCallStack => Type -> TyVar+getTyVar ty = case getTyVar_maybe ty of+                    Just tv -> tv+                    Nothing -> pprPanic "getTyVar" (ppr ty)++-- | Attempts to obtain the type variable underlying a 'Type'+getTyVar_maybe :: Type -> Maybe TyVar+getTyVar_maybe = repGetTyVar_maybe . coreFullView++-- | Attempts to obtain the type variable underlying a 'Type', without+-- any expansion+repGetTyVar_maybe :: Type -> Maybe TyVar+repGetTyVar_maybe (TyVarTy tv) = Just tv+repGetTyVar_maybe _            = Nothing++isTyVarTy :: Type -> Bool+isTyVarTy ty = isJust (getTyVar_maybe ty)++-- | If the type is a tyvar, possibly under a cast, returns it, along+-- with the coercion. Thus, the co is :: kind tv ~N kind ty+getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)+getCastedTyVar_maybe ty = case coreFullView ty of+  CastTy (TyVarTy tv) co -> Just (tv, co)+  TyVarTy tv             -> Just (tv, mkReflCo Nominal (tyVarKind tv))+  _                      -> Nothing+++{- *********************************************************************+*                                                                      *+                      AppTy+*                                                                      *+********************************************************************* -}++{- We need to be pretty careful with AppTy to make sure we obey the+invariant that a TyConApp is always visibly so.  mkAppTy maintains the+invariant: use it.++Note [Decomposing fat arrow c=>t]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with+a partial application like ((=>) (Eq a)) which doesn't make sense in+source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).+Here's an example (#9858) of how you might do it:+   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep+   i p = typeRep p++   j = i (Proxy :: Proxy (Eq Int => Int))+The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,+but suppose we want that.  But then in the call to 'i', we end+up decomposing (Eq Int => Int), and we definitely don't want that.++We are willing to split (t1 -=> t2) because the argument is still of+kind Type, not Constraint.  So the criterion is isVisibleFunArg.++In Core there is no real reason to avoid such decomposition.  But for now I've+put the test in splitAppTyNoView_maybe, which applies throughout, because the+other calls to splitAppTy are in GHC.Core.Unify, which is also used by the+type checker (e.g. when matching type-function equations).+-}++-- | Applies a type to another, as in e.g. @k a@+mkAppTy :: Type -> Type -> Type+  -- See Note [Respecting definitional equality], invariant (EQ1).+mkAppTy (CastTy fun_ty co) arg_ty+  | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]+  = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co++mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])+mkAppTy ty1               ty2 = AppTy ty1 ty2+        -- Note that the TyConApp could be an+        -- under-saturated type synonym.  GHC allows that; e.g.+        --      type Foo k = k a -> k a+        --      type Id x = x+        --      foo :: Foo Id -> Foo Id+        --+        -- Here Id is partially applied in the type sig for Foo,+        -- but once the type synonyms are expanded all is well+        --+        -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type+        --   (T t1 t2 t3) one argument at a type, thus forming+        --   (T t1), (T t1 t2), etc++mkAppTys :: Type -> [Type] -> Type+mkAppTys ty1                []   = ty1+mkAppTys (CastTy fun_ty co) arg_tys  -- much more efficient then nested mkAppTy+                                     -- Why do this? See (EQ1) of+                                     -- Note [Respecting definitional equality]+                                     -- in GHC.Core.TyCo.Rep+  = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers+  where+    (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys+    (args_to_cast, leftovers) = splitAtList arg_cos arg_tys+    casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos+mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)+mkAppTys ty1                tys2 = foldl' AppTy ty1 tys2++-------------+splitAppTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempt to take a type application apart, whether it is a+-- function, type constructor, or plain type application. Note+-- that type family applications are NEVER unsaturated by this!+splitAppTy_maybe = splitAppTyNoView_maybe . coreFullView++splitAppTy :: Type -> (Type, Type)+-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',+-- and panics if this is not possible+splitAppTy ty = splitAppTy_maybe ty `orElse` pprPanic "splitAppTy" (ppr ty)++-------------+splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that+-- any coreView stuff is already done+splitAppTyNoView_maybe (AppTy ty1 ty2)+  = Just (ty1, ty2)++splitAppTyNoView_maybe (FunTy af w ty1 ty2)+  | Just (tc, tys)   <- funTyConAppTy_maybe af w ty1 ty2+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')++splitAppTyNoView_maybe (TyConApp tc tys)+  | not (tyConMustBeSaturated tc) || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!++splitAppTyNoView_maybe _other = Nothing++tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type)+-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t)+-- See Note [Decomposing fat arrow c=>t]+tcSplitAppTyNoView_maybe ty+  | FunTy { ft_af = af } <- ty+  , not (isVisibleFunArg af)  -- See Note [Decomposing fat arrow c=>t]+  = Nothing+  | otherwise+  = splitAppTyNoView_maybe ty++-------------+splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])+-- ^ Recursively splits a type as far as is possible, leaving a residual+-- type being applied to and the type arguments applied to it. Never fails,+-- even if that means returning an empty list of type applications.+splitAppTys ty = split ty ty []+  where+    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args+    split _       (AppTy ty arg)        args = split ty ty (arg:args)+    split _       (TyConApp tc tc_args) args+      = let -- keep type families saturated+            n | tyConMustBeSaturated tc = tyConArity tc+              | otherwise               = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split _   (FunTy af w ty1 ty2) args+      | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2+      = assert (null args )+        (TyConApp tc [], tys)++    split orig_ty _ args  = (orig_ty, args)++-- | Like 'splitAppTys', but doesn't look through type synonyms+splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type])+splitAppTysNoView ty = split ty []+  where+    split (AppTy ty arg) args = split ty (arg:args)+    split (TyConApp tc tc_args) args+      = let n | tyConMustBeSaturated tc = tyConArity tc+              | otherwise               = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split (FunTy af w ty1 ty2) args+      | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2+      = assert (null args )+        (TyConApp tc [], tys)++    split ty args = (ty, args)+++{- *********************************************************************+*                                                                      *+                      LitTy+*                                                                      *+********************************************************************* -}++mkNumLitTy :: Integer -> Type+mkNumLitTy n = LitTy (NumTyLit n)++-- | Is this a numeric literal. We also look through type synonyms.+isNumLitTy :: Type -> Maybe Integer+isNumLitTy ty+  | LitTy (NumTyLit n) <- coreFullView ty = Just n+  | otherwise                             = Nothing++mkStrLitTy :: FastString -> Type+mkStrLitTy s = LitTy (StrTyLit s)++-- | Is this a symbol literal. We also look through type synonyms.+isStrLitTy :: Type -> Maybe FastString+isStrLitTy ty+  | LitTy (StrTyLit s) <- coreFullView ty = Just s+  | otherwise                             = Nothing++mkCharLitTy :: Char -> Type+mkCharLitTy c = LitTy (CharTyLit c)++-- | Is this a char literal? We also look through type synonyms.+isCharLitTy :: Type -> Maybe Char+isCharLitTy ty+  | LitTy (CharTyLit s) <- coreFullView ty = Just s+  | otherwise                              = Nothing+++-- | Is this a type literal (symbol, numeric, or char)?+isLitTy :: Type -> Maybe TyLit+isLitTy ty+  | LitTy l <- coreFullView ty = Just l+  | otherwise                  = Nothing++-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module).+type ErrorMsgType = Type++-- | Is this type a custom user error?+-- If so, give us the error message.+userTypeError_maybe :: Type -> Maybe ErrorMsgType+userTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+userTypeError_maybe (TyConApp tc (_kind : msg : _))+  | tyConName tc == errorMessageTypeErrorFamName+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg+userTypeError_maybe _+  = Nothing++deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType+-- Look for custom user error, deeply inside the type+deepUserTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+deepUserTypeError_maybe (TyConApp tc tys)+  | tyConName tc == errorMessageTypeErrorFamName+  , _kind : msg : _ <- tys+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg++  | tyConMustBeSaturated tc  -- Don't go looking for user type errors+                             -- inside type family arguments (see #20241).+  = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys)+  | otherwise+  = foldr (firstJust . deepUserTypeError_maybe) Nothing tys+deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty+deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res })+  = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res+deepUserTypeError_maybe (AppTy t1 t2)+  = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2+deepUserTypeError_maybe (CastTy ty _)+  = deepUserTypeError_maybe ty+deepUserTypeError_maybe _   -- TyVarTy, CoercionTy, LitTy+  = Nothing++-- | Render a type corresponding to a user type error into a SDoc.+pprUserTypeErrorTy :: ErrorMsgType -> SDoc+pprUserTypeErrorTy ty =+  case splitTyConApp_maybe ty of++    -- Text "Something"+    Just (tc,[txt])+      | tyConName tc == typeErrorTextDataConName+      , Just str <- isStrLitTy txt -> ftext str++    -- ShowType t+    Just (tc,[_k,t])+      | tyConName tc == typeErrorShowTypeDataConName -> ppr t++    -- t1 :<>: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorAppendDataConName ->+        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2++    -- t1 :$$: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorVAppendDataConName ->+        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2++    -- An unevaluated type function+    _ -> ppr ty++{- *********************************************************************+*                                                                      *+                      FunTy+*                                                                      *+********************************************************************* -}++{- Note [Representation of function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functions (e.g. Int -> Char) can be thought of as being applications+of funTyCon (known in Haskell surface syntax as (->)), (note that+`RuntimeRep' quantifiers are left inferred)++    (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}+                   (a :: TYPE r1) (b :: TYPE r2).+            a -> b -> Type++However, for efficiency's sake we represent saturated applications of (->)+with FunTy. For instance, the type,++    (->) r1 r2 a b++is equivalent to,++    FunTy (Anon a) b++Note how the RuntimeReps are implied in the FunTy representation. For this+reason we must be careful when reconstructing the TyConApp representation (see,+for instance, splitTyConApp_maybe).++In the compiler we maintain the invariant that all saturated applications of+(->) are represented with FunTy.++See #11714.+-}++-----------------------------------------------+funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type+                    -> Maybe (TyCon, [Type])+-- ^ Given the components of a FunTy+-- figure out the corresponding TyConApp.+funTyConAppTy_maybe af mult arg res+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  -- If you're changing the lines below, you'll probably want to adapt the+  -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly.+  , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res]+             | otherwise   = [      arg_rep, res_rep, arg, res]+  = Just $ (funTyFlagTyCon af, args)+  | otherwise+  = Nothing++tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type+-- ^ Return Just if this TyConApp should be represented as a FunTy+tyConAppFunTy_maybe tc tys+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe manyDataConTy tc tys+            = Just (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })+  | otherwise = Nothing++tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]+                    -> Maybe Coercion+-- ^ Return Just if this TyConAppCo should be represented as a FunCo+tyConAppFunCo_maybe r tc cos+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos+  = Just (mkFunCo r af mult arg res)+  | otherwise+  = Nothing+  where+    mult_refl = mkReflCo (funRole r SelMult) manyDataConTy++ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]+                     -> Maybe (FunTyFlag, a, a, a)+{-# INLINE ty_con_app_fun_maybe #-}+-- Specialise this function for its two call sites+ty_con_app_fun_maybe many_ty_co tc args+  | tc_uniq == fUNTyConKey     = fUN_case+  | tc_uniq == tcArrowTyConKey = non_FUN_case FTF_T_C+  | tc_uniq == ctArrowTyConKey = non_FUN_case FTF_C_T+  | tc_uniq == ccArrowTyConKey = non_FUN_case FTF_C_C+  | otherwise                  = Nothing+  where+    tc_uniq = tyConUnique tc++    fUN_case+      | (w:_r1:_r2:a1:a2:rest) <- args+      = assertPpr (null rest) (ppr tc <+> ppr args) $+        Just (FTF_T_T, w, a1, a2)+      | otherwise = Nothing++    non_FUN_case ftf+      | (_r1:_r2:a1:a2:rest) <- args+      = assertPpr (null rest) (ppr tc <+> ppr args) $+        Just (ftf, many_ty_co, a1, a2)+      | otherwise+      = Nothing++mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type+-- ^ This one works out the FunTyFlag from the argument type+-- See GHC.Types.Var Note [FunTyFlag]+mkFunctionType mult arg_ty res_ty+ = FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty+         , ft_mult = assertPpr mult_ok (ppr [mult, arg_ty, res_ty]) $+                     mult }+  where+    af = chooseFunTyFlag arg_ty res_ty+    mult_ok = isVisibleFunArg af || isManyTy mult++mkScaledFunctionTys :: [Scaled Type] -> Type -> Type+-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments+mkScaledFunctionTys arg_tys res_ty+  = foldr mk res_ty arg_tys+  where+    mk (Scaled mult arg_ty) res_ty+      = mkFunTy (chooseFunTyFlag arg_ty res_ty)+                mult arg_ty res_ty++chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag+-- ^ See GHC.Types.Var Note [FunTyFlag]+chooseFunTyFlag arg_ty res_ty+  = mkFunTyFlag (typeTypeOrConstraint arg_ty) (typeTypeOrConstraint res_ty)++splitFunTy :: Type -> (Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type,+-- and panics if that is not possible. See also 'splitFunTy_maybe'+splitFunTy ty = case splitFunTy_maybe ty of+                   Just (_af, mult, arg, res) -> (mult,arg,res)+                   Nothing                    -> pprPanic "splitFunTy" (ppr ty)++{-# INLINE splitFunTy_maybe #-}+splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type+splitFunTy_maybe ty+  | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res)+  | otherwise                             = Nothing++{-# INLINE splitVisibleFunTy_maybe #-}+splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Works on visible function types only (t1 -> t2), and+--   returns t1 and t2, but not the multiplicity+splitVisibleFunTy_maybe ty+  | FunTy af _ arg res <- coreFullView ty+  , isVisibleFunArg af = Just (arg, res)+  | otherwise          = Nothing++splitFunTys :: Type -> ([Scaled Type], Type)+splitFunTys ty = split [] ty ty+  where+      -- common case first+    split args _       (FunTy _ w arg res) = split (Scaled w arg : args) res res+    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'+    split args orig_ty _                   = (reverse args, orig_ty)++funResultTy :: HasDebugCallStack => Type -> Type+-- ^ Extract the function result type and panic if that is not possible+funResultTy ty+  | FunTy { ft_res = res } <- coreFullView ty = res+  | otherwise                                 = pprPanic "funResultTy" (ppr ty)++funArgTy :: HasDebugCallStack => Type -> Type+-- ^ Extract the function argument type and panic if that is not possible+funArgTy ty+  | FunTy { ft_arg = arg } <- coreFullView ty = arg+  | otherwise                                 = pprPanic "funArgTy" (ppr ty)++-- ^ Just like 'piResultTys' but for a single argument+-- Try not to iterate 'piResultTy', because it's inefficient to substitute+-- one variable at a time; instead use 'piResultTys"+piResultTy :: HasDebugCallStack => Type -> Type ->  Type+piResultTy ty arg = case piResultTy_maybe ty arg of+                      Just res -> res+                      Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)++piResultTy_maybe :: Type -> Type -> Maybe Type+-- We don't need a 'tc' version, because+-- this function behaves the same for Type and Constraint+piResultTy_maybe ty arg = case coreFullView ty of+  FunTy { ft_res = res } -> Just res++  ForAllTy (Bndr tv _) res+    -> let empty_subst = mkEmptySubst $ mkInScopeSet $+                         tyCoVarsOfTypes [arg,res]+       in Just (substTy (extendTCvSubst empty_subst tv arg) res)++  _ -> Nothing++-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)+--   where f :: f_ty+-- 'piResultTys' is interesting because:+--      1. 'f_ty' may have more for-alls than there are args+--      2. Less obviously, it may have fewer for-alls+-- For case 2. think of:+--   piResultTys (forall a.a) [forall b.b, Int]+-- This really can happen, but only (I think) in situations involving+-- undefined.  For example:+--       undefined :: forall a. a+-- Term: undefined @(forall b. b->b) @Int+-- This term should have type (Int -> Int), but notice that+-- there are more type args than foralls in 'undefined's type.++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint++-- This is a heavily used function (e.g. from typeKind),+-- so we pay attention to efficiency, especially in the special case+-- where there are no for-alls so we are just dropping arrows from+-- a function type/kind.+piResultTys :: HasDebugCallStack => Type -> [Type] -> Type+piResultTys ty [] = ty+piResultTys ty orig_args@(arg:args)+  | FunTy { ft_res = res } <- ty+  = piResultTys res args++  | ForAllTy (Bndr tcv _) res <- ty+  = -- Both type and coercion variables+    go (extendTCvSubst init_subst tcv arg) res args++  | Just ty' <- coreView ty+  = piResultTys ty' orig_args++  | otherwise+  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)+  where+    init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))++    go :: Subst -> Type -> [Type] -> Type+    go subst ty [] = substTyUnchecked subst ty++    go subst ty all_args@(arg:args)+      | FunTy { ft_res = res } <- ty+      = go subst res args++      | ForAllTy (Bndr tv _) res <- ty+      = go (extendTCvSubst subst tv arg) res args++      | Just ty' <- coreView ty+      = go subst ty' all_args++      | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+      = go init_subst+          (substTy subst ty)+          all_args++      | otherwise+      = -- We have not run out of arguments, but the function doesn't+        -- have the right kind to apply to them; so panic.+        -- Without the explicit isEmptyVarEnv test, an ill-kinded type+        -- would give an infinite loop, which is very unhelpful+        -- c.f. #15473+        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)++applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type+-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys+-- Assumes that (/\tvs. body_ty) is closed+applyTysX tvs body_ty arg_tys+  = assertPpr (tvs `leLength` arg_tys) pp_stuff $+    assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $+    mkAppTys (substTyWith tvs arg_tys_prefix body_ty)+             arg_tys_rest+  where+    pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]+    (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys+++{- Note [Care with kind instantiation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  T :: forall k. k+and we are finding the kind of+  T (forall b. b -> b) * Int+Then+  T (forall b. b->b) :: k[ k :-> forall b. b->b]+                     :: forall b. b -> b+So+  T (forall b. b->b) * :: (b -> b)[ b :-> *]+                       :: * -> *++In other words we must instantiate the forall!++Similarly (#15428)+   S :: forall k f. k -> f k+and we are finding the kind of+   S * (* ->) Int Bool+We have+   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]+              :: * -> * -> *+So again we must instantiate.++The same thing happens in GHC.CoreToIface.toIfaceAppArgsX.+-}+++{- *********************************************************************+*                                                                      *+                      TyConApp+*                                                                      *+********************************************************************* -}++-- splitTyConApp "looks through" synonyms, because they don't+-- mean a distinct type, but all other type-constructor applications+-- including functions are returned as Just ..++-- | Retrieve the tycon heading this type, if there is one. Does /not/+-- look through synonyms.+tyConAppTyConPicky_maybe :: Type -> Maybe TyCon+tyConAppTyConPicky_maybe (TyConApp tc _)        = Just tc+tyConAppTyConPicky_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af)+tyConAppTyConPicky_maybe _                      = Nothing+++-- | The same as @fst . splitTyConApp@+-- We can short-cut the FunTy case+{-# INLINE tyConAppTyCon_maybe #-}+tyConAppTyCon_maybe :: Type -> Maybe TyCon+tyConAppTyCon_maybe ty = case coreFullView ty of+  TyConApp tc _        -> Just tc+  FunTy { ft_af = af } -> Just (funTyFlagTyCon af)+  _                    -> Nothing++tyConAppTyCon :: HasDebugCallStack => Type -> TyCon+tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)++-- | The same as @snd . splitTyConApp@+tyConAppArgs_maybe :: Type -> Maybe [Type]+tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of+                          Just (_, tys) -> Just tys+                          Nothing       -> Nothing++tyConAppArgs :: HasDebugCallStack => Type -> [Type]+tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor. Panics if that is not possible.+-- See also 'splitTyConApp_maybe'+splitTyConApp :: Type -> (TyCon, [Type])+splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor+splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty)++splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- Same as splitTyConApp_maybe but without looking through synonyms+splitTyConAppNoView_maybe ty+  = case ty of+      FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                      -> funTyConAppTy_maybe af w arg res+      TyConApp tc tys -> Just (tc, tys)+      _               -> Nothing++-- | tcSplitTyConApp_maybe splits a type constructor application into+-- its type constructor and applied types.+--+-- Differs from splitTyConApp_maybe in that it does *not* split types+-- headed with (=>), as that's not a TyCon in the type-checker.+--+-- Note that this may fail (in funTyConAppTy_maybe) in the case+-- of a 'FunTy' with an argument of unknown kind 'FunTy'+-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of+-- the form `TYPE rep`.  This isn't usually a problem but may+-- be temporarily the case during canonicalization:+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality+--     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+--         Wrinkle around FunTy+--+-- Consequently, you may need to zonk your type before+-- using this function.+tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- Defined here to avoid module loops between Unify and TcType.+tcSplitTyConApp_maybe ty+  = case coreFullView ty of+      FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                      | isVisibleFunArg af    -- Visible args only+                        -- See Note [Decomposing fat arrow c=>t]+                      -> funTyConAppTy_maybe af w arg res+      TyConApp tc tys -> Just (tc, tys)+      _               -> Nothing++tcSplitTyConApp :: Type -> (TyCon, [Type])+tcSplitTyConApp ty+  = tcSplitTyConApp_maybe ty `orElse` pprPanic "tcSplitTyConApp" (ppr ty)++---------------------------+newTyConInstRhs :: TyCon -> [Type] -> Type+-- ^ Unwrap one 'layer' of newtype on a type constructor and its+-- arguments, using an eta-reduced version of the @newtype@ if possible.+-- This requires tys to have at least @newTyConInstArity tycon@ elements.+newTyConInstRhs tycon tys+    = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $+      applyTysX tvs rhs tys+  where+    (tvs, rhs) = newTyConEtadRhs tycon+++{- *********************************************************************+*                                                                      *+                      CastTy+*                                                                      *+********************************************************************* -}++splitCastTy_maybe :: Type -> Maybe (Type, Coercion)+splitCastTy_maybe ty+  | CastTy ty' co <- coreFullView ty = Just (ty', co)+  | otherwise                        = Nothing++-- | Make a 'CastTy'. The Coercion must be nominal. Checks the+-- Coercion for reflexivity, dropping it if it's reflexive.+-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep"+mkCastTy :: Type -> Coercion -> Type+mkCastTy orig_ty co | isReflexiveCo co = orig_ty  -- (EQ2) from the Note+-- NB: Do the slow check here. This is important to keep the splitXXX+-- functions working properly. Otherwise, we may end up with something+-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)+-- fails under splitFunTy_maybe. This happened with the cheaper check+-- in test dependent/should_compile/dynamic-paper.+mkCastTy orig_ty co = mk_cast_ty orig_ty co++-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity,+-- as that can be expensive.+mk_cast_ty :: Type -> Coercion -> Type+mk_cast_ty orig_ty co = go orig_ty+  where+    go :: Type -> Type+    -- See Note [Using coreView in mk_cast_ty]+    go ty | Just ty' <- coreView ty = go ty'++    go (CastTy ty co1)+      -- (EQ3) from the Note+      = mkCastTy ty (co1 `mkTransCo` co)+          -- call mkCastTy again for the reflexivity check++    go (ForAllTy (Bndr tv vis) inner_ty)+      -- (EQ4) from the Note+      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep.+      | isTyVar tv+      , let fvs = tyCoVarsOfCo co+      = -- have to make sure that pushing the co in doesn't capture the bound var!+        if tv `elemVarSet` fvs+        then let empty_subst = mkEmptySubst (mkInScopeSet fvs)+                 (subst, tv') = substVarBndr empty_subst tv+             in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co)+        else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co)++    go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible++{-+Note [Using coreView in mk_cast_ty]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in+GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance,+consider this example (#19742):++   type EqSameNat = () |> co+   useNatEq :: EqSameNat |> sym co++(Those casts aren't visible in the user-source code, of course; see #19742 for+what the user might write.)++The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no+nested casts, but if we expand EqSameNat, we see that it doesn't.+And then Bad Things happen.++The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in+`mk_cast_ty`.+-}++{- *********************************************************************+*                                                                      *+                     CoercionTy+  CoercionTy allows us to inject coercions into types. A CoercionTy+  should appear only in the right-hand side of an application.+*                                                                      *+********************************************************************* -}++mkCoercionTy :: Coercion -> Type+mkCoercionTy = CoercionTy++isCoercionTy :: Type -> Bool+isCoercionTy (CoercionTy _) = True+isCoercionTy _              = False++isCoercionTy_maybe :: Type -> Maybe Coercion+isCoercionTy_maybe (CoercionTy co) = Just co+isCoercionTy_maybe _               = Nothing++stripCoercionTy :: Type -> Coercion+stripCoercionTy (CoercionTy co) = co+stripCoercionTy ty              = pprPanic "stripCoercionTy" (ppr ty)+++{- *********************************************************************+*                                                                      *+                      ForAllTy+*                                                                      *+********************************************************************* -}++tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder]+-- Return the tyConBinders in PiTyBinder form+tyConBindersPiTyBinders = map to_tyb+  where+    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)+    to_tyb (Bndr tv AnonTCB)        = Anon (tymult (varType tv)) FTF_T_T++-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type+mkTyCoForAllTy tv vis ty+  | isCoVar tv+  , not (tv `elemVarSet` tyCoVarsOfType ty)+   -- Maintain ForAllTy's invariants+    -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+  = mkVisFunTyMany (varType tv) ty+  | otherwise+  = ForAllTy (mkForAllTyBinder vis tv) ty++-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type+mkTyCoForAllTys bndrs ty+  = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs++-- | Make a dependent forall over an 'Inferred' variable+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type+mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty++-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar+mkInfForAllTy :: TyVar -> Type -> Type+mkInfForAllTy tv ty = assert (isTyVar tv )+                      ForAllTy (Bndr tv Inferred) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Inferred', a common case+mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type+mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs++-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar+mkInfForAllTys :: [TyVar] -> Type -> Type+mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs++-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',+-- a common case+mkSpecForAllTy :: TyVar -> Type -> Type+mkSpecForAllTy tv ty = assert (isTyVar tv )+                       -- covar is always Inferred, so input should be tyvar+                       ForAllTy (Bndr tv Specified) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Specified', a common case+mkSpecForAllTys :: [TyVar] -> Type -> Type+mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs++-- | Like mkForAllTys, but assumes all variables are dependent and visible+mkVisForAllTys :: [TyVar] -> Type -> Type+mkVisForAllTys tvs = assert (all isTyVar tvs )+                     -- covar is always Inferred, so all inputs should be tyvar+                     mkForAllTys [ Bndr tv Required | tv <- tvs ]++-- | Given a list of type-level vars and the free vars of a result kind,+-- makes PiTyBinders, preferring anonymous binders+-- if the variable is, in fact, not dependent.+-- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)+-- We want (k:*) Named, (b:k) Anon, (c:k) Anon+--+-- All non-coercion binders are /visible/.+mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders+                         -> TyCoVarSet   -- ^ free variables of result+                         -> [TyConBinder]+mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars)+                                           fst (go vars)+  where+    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars+    go [] = ([], inner_tkvs)+    go (v:vs) | v `elemVarSet` fvs+              = ( Bndr v (NamedTCB Required) : binders+                , fvs `delVarSet` v `unionVarSet` kind_vars )+              | otherwise+              = ( Bndr v AnonTCB : binders+                , fvs `unionVarSet` kind_vars )+      where+        (binders, fvs) = go vs+        kind_vars      = tyCoVarsOfType $ tyVarKind v++-- | Take a ForAllTy apart, returning the binders and result type+splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type)+splitForAllForAllTyBinders ty = split ty ty []+  where+    split _ (ForAllTy b res) bs                   = split res res (b:bs)+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split orig_ty _                bs             = (reverse bs, orig_ty)+{-# INLINE splitForAllForAllTyBinders #-}++-- | Take a ForAllTy apart, returning the list of tycovars and the result type.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTyCoVars :: Type -> ([TyCoVar], Type)+splitForAllTyCoVars ty = split ty ty []+  where+    split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but split only for tyvars.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTyVars :: Type -> ([TyVar], Type)+splitForAllTyVars ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs+    split orig_ty _                   tvs              = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type+-- variable binders. Furthermore, each returned tyvar is annotated with '()'.+splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type)+splitForAllReqTyBinders ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv Required) ty) tvs   = split ty ty (Bndr tv ():tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split orig_ty _                   tvs          = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type+-- variable binders. Furthermore, each returned tyvar is annotated with its+-- 'Specificity'.+splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type)+splitForAllInvisTyBinders ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty       = split orig_ty ty' tvs+    split orig_ty _                   tvs                = (reverse tvs, orig_ty)++-- | Checks whether this is a proper forall (with a named binder)+isForAllTy :: Type -> Bool+isForAllTy ty+  | ForAllTy {} <- coreFullView ty = True+  | otherwise                      = False++-- | Like `isForAllTy`, but returns True only if it is a tyvar binder+isForAllTy_ty :: Type -> Bool+isForAllTy_ty ty+  | ForAllTy (Bndr tv _) _ <- coreFullView ty+  , isTyVar tv+  = True++  | otherwise = False++-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder+isForAllTy_invis_ty :: Type -> Bool+isForAllTy_invis_ty  ty+  | ForAllTy (Bndr tv (Invisible InferredSpec)) _ <- coreFullView ty+  , isTyVar tv+  = True++  | otherwise = False++-- | Like `isForAllTy`, but returns True only if it is a covar binder+isForAllTy_co :: Type -> Bool+isForAllTy_co ty+  | ForAllTy (Bndr tv _) _ <- coreFullView ty+  , isCoVar tv+  = True++  | otherwise = False++-- | Is this a function or forall?+isPiTy :: Type -> Bool+isPiTy ty = case coreFullView ty of+  ForAllTy {} -> True+  FunTy {}    -> True+  _           -> False++-- | Is this a function?+-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function.+--       It would merely be a forall wrapping a function type.+isFunTy :: Type -> Bool+isFunTy ty+  | FunTy {} <- coreFullView ty = True+  | otherwise                   = False++-- | Take a forall type apart, or panics if that is not possible.+splitForAllTyCoVar :: Type -> (TyCoVar, Type)+splitForAllTyCoVar ty+  | Just answer <- splitForAllTyCoVar_maybe ty = answer+  | otherwise                                  = pprPanic "splitForAllTyCoVar" (ppr ty)++-- | Drops all ForAllTys+dropForAlls :: Type -> Type+dropForAlls ty = go ty+  where+    go (ForAllTy _ res)            = go res+    go ty | Just ty' <- coreView ty = go ty'+    go res                         = res++-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder+splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)+splitForAllForAllTyBinder_maybe ty+  | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty)+  | otherwise                                 = Nothing+++-- | Attempts to take a ForAllTy apart, returning the Var+splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTyCoVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)+  | otherwise                                        = Nothing++-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar+splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type)+splitForAllTyVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty+  , isTyVar tv+  = Just (tv, inner_ty)++  | otherwise = Nothing++-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder.+splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type)+splitForAllCoVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty+  , isCoVar tv+  = Just (tv, inner_ty)++  | otherwise = Nothing++-- | Attempts to take a forall type apart; works with proper foralls and+-- functions+{-# INLINE splitPiTy_maybe #-}  -- callers will immediately deconstruct+splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type)+splitPiTy_maybe ty = case coreFullView ty of+  ForAllTy bndr ty -> Just (Named bndr, ty)+  FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                   -> Just (Anon (mkScaled w arg) af, res)+  _                -> Nothing++-- | Takes a forall type apart, or panics+splitPiTy :: Type -> (PiTyBinder, Type)+splitPiTy ty+  | Just answer <- splitPiTy_maybe ty = answer+  | otherwise                         = pprPanic "splitPiTy" (ppr ty)++-- | Split off all PiTyBinders to a type, splitting both proper foralls+-- and functions+splitPiTys :: Type -> ([PiTyBinder], Type)+splitPiTys ty = split ty ty []+  where+    split _       (ForAllTy b res) bs = split res res (Named b  : bs)+    split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs+                                      = split res res (Anon (Scaled w arg) af : bs)+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split orig_ty _                bs = (reverse bs, orig_ty)++collectPiTyBinders :: Type -> [PiTyBinder]+collectPiTyBinders ty = build $ \c n ->+  let+    split (ForAllTy b res) = Named b `c` split res+    split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })+                           = Anon (Scaled w arg) af `c` split res+    split ty | Just ty' <- coreView ty = split ty'+    split _                = n+  in+    split ty+{-# INLINE collectPiTyBinders #-}++-- | Extracts a list of run-time arguments from a function type,+-- looking through newtypes to the right of arrows.+--+-- Examples:+--+-- @+--    newtype Identity a = I a+--+--    getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool)+--             == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)]+-- @+--+-- Note that, in the last case, the returned types might mention an out-of-scope+-- type variable. This function is used only when we really care about the /kinds/+-- of the returned types, so this is OK.+--+-- **Warning**: this function can return an infinite list. For example:+--+-- @+--   newtype N a = MkN (a -> N a)+--   getRuntimeArgTys (N a) == repeat (a, FTF_T_T)+-- @+getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)]+getRuntimeArgTys = go+  where+    go :: Type -> [(Scaled Type, FunTyFlag)]+    go (ForAllTy _ res)+      = go res+    go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af })+      = (Scaled w arg, af) : go res+    go ty+      | Just ty' <- coreView ty+      = go ty'+      | Just (_,ty') <- topNormaliseNewType_maybe ty+      = go ty'+      | otherwise+      = []++invisibleBndrCount :: Type -> Int+-- Returns the number of leading invisible forall'd binders in the type+-- Includes invisible predicate arguments; e.g. for+--    e.g.  forall {k}. (k ~ *) => k -> k+-- returns 2 not 1+invisibleBndrCount ty = length (fst (splitInvisPiTys ty))++-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.+-- Stops at the first visible binder.+splitInvisPiTys :: Type -> ([PiTyBinder], Type)+splitInvisPiTys ty = split ty ty []+   where+    split _ (ForAllTy b res) bs+      | Bndr _ vis <- b+      , isInvisibleForAllTyFlag vis   = split res res (Named b  : bs)+    split _ (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })  bs+      | isInvisibleFunArg af     = split res res (Anon (mkScaled mult arg) af : bs)+    split orig_ty ty bs+      | Just ty' <- coreView ty  = split orig_ty ty' bs+    split orig_ty _          bs  = (reverse bs, orig_ty)++splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type)+-- ^ Same as 'splitInvisPiTys', but stop when+--   - you have found @n@ 'PiTyBinder's,+--   - or you run out of invisible binders+splitInvisPiTysN n ty = split n ty ty []+   where+    split n orig_ty ty bs+      | n == 0                  = (reverse bs, orig_ty)+      | Just ty' <- coreView ty = split n orig_ty ty' bs+      | ForAllTy b res <- ty+      , Bndr _ vis <- b+      , isInvisibleForAllTyFlag vis  = split (n-1) res res (Named b  : bs)+      | FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty+      , isInvisibleFunArg af   = split (n-1) res res (Anon (Scaled mult arg) af : bs)+      | otherwise              = (reverse bs, orig_ty)++-- | Given a 'TyCon' and a list of argument types, filter out any invisible+-- (i.e., 'Inferred' or 'Specified') arguments.+filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]+filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys++-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred'+-- arguments.+filterOutInferredTypes :: TyCon -> [Type] -> [Type]+filterOutInferredTypes tc tys =+  filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys++-- | Given a 'TyCon' and a list of argument types, partition the arguments+-- into:+--+-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and+--+-- 2. 'Required' (i.e., visible) arguments+partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])+partitionInvisibleTypes tc tys =+  partitionByList (map isInvisibleForAllTyFlag $ tyConForAllTyFlags tc tys) tys++-- | Given a list of things paired with their visibilities, partition the+-- things into (invisible things, visible things).+partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a])+partitionInvisibles = partitionWith pick_invis+  where+    pick_invis :: (a, ForAllTyFlag) -> Either a a+    pick_invis (thing, vis) | isInvisibleForAllTyFlag vis = Left thing+                            | otherwise              = Right thing++-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Wrinkle: consider the following scenario:+--+-- > T :: forall k. k -> k+-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q]+--+-- After substituting, we get+--+-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n+--+-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,+-- and @Q@ is visible.+tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag]+tyConForAllTyFlags tc = fun_kind_arg_flags (tyConKind tc)++-- | Given a 'Type' and a list of argument types to which the 'Type' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Most of the time, the arguments will be 'Required', but not always. Consider+-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is+-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely+-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy,+-- since @f Type Bool@ would be represented in Core using 'AppTy's.+-- (See also #15792).+appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag]+appTyForAllTyFlags ty = fun_kind_arg_flags (typeKind ty)++-- | Given a function kind and a list of argument types (where each argument's+-- kind aligns with the corresponding position in the argument kind), determine+-- each argument's visibility ('Inferred', 'Specified', or 'Required').+fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag]+fun_kind_arg_flags = go emptySubst+  where+    go subst ki arg_tys+      | Just ki' <- coreView ki = go subst ki' arg_tys+    go _ _ [] = []+    go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)+      = argf : go subst' res_ki arg_tys+      where+        subst' = extendTvSubst subst tv arg_ty+    go subst (TyVarTy tv) arg_tys+      | Just ki <- lookupTyVar subst tv = go subst ki arg_tys+    -- This FunTy case is important to handle kinds with nested foralls, such+    -- as this kind (inspired by #16518):+    --+    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type+    --+    -- Here, we want to get the following ForAllTyFlags:+    --+    -- [Inferred,   Specified, Required, Required, Specified, Required]+    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type+    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)+      = argf : go subst res_ki arg_tys+      where+        argf | isVisibleFunArg af = Required+             | otherwise          = Inferred+    go _ _ arg_tys = map (const Required) arg_tys+                        -- something is ill-kinded. But this can happen+                        -- when printing errors. Assume everything is Required.++-- @isTauTy@ tests if a type has no foralls or (=>)+isTauTy :: Type -> Bool+isTauTy ty | Just ty' <- coreView ty = isTauTy ty'+isTauTy (TyVarTy _)       = True+isTauTy (LitTy {})        = True+isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc+isTauTy (AppTy a b)       = isTauTy a && isTauTy b+isTauTy (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b })+ | isInvisibleFunArg af   = False                               -- e.g., Eq a => b+ | otherwise              = isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b+isTauTy (ForAllTy {})     = False+isTauTy (CastTy ty _)     = isTauTy ty+isTauTy (CoercionTy _)    = False  -- Not sure about this++isAtomicTy :: Type -> Bool+-- True if the type is just a single token, and can be printed compactly+-- Used when deciding how to lay out type error messages; see the+-- call in GHC.Tc.Errors+isAtomicTy (TyVarTy {})    = True+isAtomicTy (LitTy {})      = True+isAtomicTy (TyConApp _ []) = True++isAtomicTy ty | isLiftedTypeKind ty = True+   -- 'Type' prints compactly as *+   -- See GHC.Iface.Type.ppr_kind_type++isAtomicTy _ = False++{-+************************************************************************+*                                                                      *+\subsection{Type families}+*                                                                      *+************************************************************************+-}++mkFamilyTyConApp :: TyCon -> [Type] -> Type+-- ^ Given a family instance TyCon and its arg types, return the+-- corresponding family type.  E.g:+--+-- > data family T a+-- > data instance T (Maybe b) = MkT b+--+-- Where the instance tycon is :RTL, so:+--+-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)+mkFamilyTyConApp tc tys+  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc+  , let tvs = tyConTyVars tc+        fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $+                    zipTvSubst tvs tys+  = mkTyConApp fam_tc (substTys fam_subst fam_tys)+  | otherwise+  = mkTyConApp tc tys++-- | Get the type on the LHS of a coercion induced by a type/data+-- family instance.+coAxNthLHS :: CoAxiom br -> Int -> Type+coAxNthLHS ax ind =+  mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))++isFamFreeTy :: Type -> Bool+isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'+isFamFreeTy (TyVarTy _)       = True+isFamFreeTy (LitTy {})        = True+isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc+isFamFreeTy (AppTy a b)       = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (FunTy _ w a b)   = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b+isFamFreeTy (ForAllTy _ ty)   = isFamFreeTy ty+isFamFreeTy (CastTy ty _)     = isFamFreeTy ty+isFamFreeTy (CoercionTy _)    = False  -- Not sure about this++-- | Check whether a type is a data family type+isDataFamilyApp :: Type -> Bool+isDataFamilyApp ty = case tyConAppTyCon_maybe ty of+                           Just tc -> isDataFamilyTyCon tc+                           _       -> False++isSatTyFamApp :: Type -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+isSatTyFamApp (TyConApp tc tys)+  |  isTypeFamilyTyCon tc+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated+  = Just (tc, tys)+isSatTyFamApp _ = Nothing++buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind+              -> [Role] -> KnotTied Type -> TyCon+-- This function is here because here is where we have+--   isFamFree and isTauTy+buildSynTyCon name binders res_kind roles rhs+  = mkSynonymTyCon name binders res_kind roles rhs+                   is_tau is_fam_free is_forgetful is_concrete+  where+    qtvs         = mkVarSet (map binderVar binders)+    is_tau       = isTauTy rhs+    is_fam_free  = isFamFreeTy rhs+    is_concrete  = isConcreteTypeWith qtvs rhs+    is_forgetful = not (qtvs `subVarSet` expanded_rhs_tyvars)++    expanded_rhs_tyvars = tyCoVarsOfType (expandTypeSynonyms rhs)+       -- See Note [Forgetful type synonyms] in GHC.Core.TyCon+       -- To find out if this TyCon is forgetful, expand the synonyms in its RHS+       -- and check that all of the binders are free in the expanded type.+       -- We really only need to expand the /forgetful/ synonyms on the RHS,+       -- but we don't currently have a function to do that.+       -- Failing to expand the RHS led to #25094, e.g.+       --    type Bucket a b c = Key (a,b,c)+       --    type Key x = Any+       -- Here Bucket is definitely forgetful!++{-+************************************************************************+*                                                                      *+\subsection{Liftedness}+*                                                                      *+************************************************************************+-}++-- | Tries to compute the 'Levity' of the given type. Returns either+-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the+-- type is representation-polymorphic).+--+-- Panics if the kind does not have the shape @TYPE r@.+typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity+typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty)++typeLevity :: HasDebugCallStack => Type -> Levity+typeLevity ty = case typeLevity_maybe ty of+                   Just lev -> lev+                   Nothing  -> pprPanic "typeLevity" (ppr ty)++-- | Is the given type definitely unlifted?+-- See "Type#type_classification" for what an unlifted type is.+--+-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- representation polymorphism.+isUnliftedType :: HasDebugCallStack => Type -> Bool+        -- isUnliftedType returns True for forall'd unlifted types:+        --      x :: forall a. Int#+        -- I found bindings like these were getting floated to the top level.+isUnliftedType ty =+  case typeLevity_maybe ty of+    Just Lifted   -> False+    Just Unlifted -> True+    Nothing       -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Returns:+--+-- * 'False' if the type is /guaranteed/ unlifted or+-- * 'True' if it lifted, OR we aren't sure+--    (e.g. in a representation-polymorphic case)+mightBeLiftedType :: Type -> Bool+mightBeLiftedType = mightBeLifted . typeLevity_maybe++definitelyLiftedType :: Type -> Bool+definitelyLiftedType = not . mightBeUnliftedType++-- | Returns:+--+-- * 'False' if the type is /guaranteed/ lifted or+-- * 'True' if it is unlifted, OR we aren't sure+--    (e.g. in a representation-polymorphic case)+mightBeUnliftedType :: Type -> Bool+mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe++definitelyUnliftedType :: Type -> Bool+definitelyUnliftedType = not . mightBeLiftedType++-- | See "Type#type_classification" for what a boxed type is.+-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- representation polymorphism.+isBoxedType :: Type -> Bool+isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty)++-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)+isRuntimeRepKindedTy :: Type -> Bool+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind++-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.+-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:+--+--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep+--                      , String, Int# ] == [String, Int#]+--+dropRuntimeRepArgs :: [Type] -> [Type]+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not+-- possible.+getRuntimeRep_maybe :: HasDebugCallStack+                    => Type -> Maybe RuntimeRepType+getRuntimeRep_maybe = kindRep_maybe . typeKind++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.+getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType+getRuntimeRep ty+  = case getRuntimeRep_maybe ty of+      Just r  -> r+      Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@,+-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@.+--+-- Returns 'Nothing' if this is not possible. Does not look through type family applications.+getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type+getLevity_maybe ty+  | Just rep <- getRuntimeRep_maybe ty+  -- Directly matching on TyConApp after expanding type synonyms+  -- saves allocations compared to `splitTyConApp_maybe`. See #22254.+  -- Given that this is a pretty hot function we make use of the fact+  -- and use isTyConKeyApp_maybe instead.+  , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep+  = Just lev+  | otherwise+  = Nothing++-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@,+-- or @getLevity (Array# Int) = Unlifted@.+--+-- Panics if this is not possible. Does not look through type family applications.+getLevity :: HasDebugCallStack => Type -> Type+getLevity ty+  | Just lev <- getLevity_maybe ty+  = lev+  | otherwise+  = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty))++isUnboxedTupleType :: Type -> Bool+isUnboxedTupleType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey+  -- NB: Do not use typePrimRep, as that can't tell the difference between+  -- unboxed tuples and unboxed sums+++isUnboxedSumType :: Type -> Bool+isUnboxedSumType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey++-- | See "Type#type_classification" for what an algebraic type is.+-- Should only be applied to /types/, as opposed to e.g. partially+-- saturated type constructors+isAlgType :: Type -> Bool+isAlgType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )+                            isAlgTyCon tc+      _other             -> False++-- | Computes whether an argument (or let right hand side) should+-- be computed strictly or lazily, based only on its type.+-- Currently, it's just 'isUnliftedType'.+-- Panics on representation-polymorphic types.+isStrictType :: HasDebugCallStack => Type -> Bool+isStrictType = isUnliftedType++isTerminatingType :: HasDebugCallStack => Type -> Bool+-- ^ True <=> a term of this type cannot be bottom+-- This identifies the types described by+--    Note [NON-BOTTOM-DICTS invariant] in GHC.Core+-- NB: unlifted types are not terminating types!+--     e.g. you can write a term (loop 1)::Int# that diverges.+isTerminatingType ty = case tyConAppTyCon_maybe ty of+    Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc)+               -- A non-unary class TyCon is terminating+               -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon+    _       -> False++isPrimitiveType :: Type -> Bool+-- ^ Returns true of types that are opaque to Haskell.+isPrimitiveType ty = case splitTyConApp_maybe ty of+                        Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )+                                              isPrimTyCon tc+                        _                  -> False++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Determine whether a type could be the type of a join point of given total+-- arity, according to the polymorphism rule. A join point cannot be polymorphic+-- in its return type, since given+--   join j @a @b x y z = e1 in e2,+-- the types of e1 and e2 must be the same, and a and b are not in scope for e2.+-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False+-- also if the type simply doesn't have enough arguments.+--+-- Note that we need to know how many arguments (type *and* value) the putative+-- join point takes; for instance, if+--   j :: forall a. a -> Int+-- then j could be a binary join point returning an Int, but it could *not* be a+-- unary join point returning a -> Int.+--+-- TODO: See Note [Excess polymorphism and join points]+isValidJoinPointType :: JoinArity -> Type -> Bool+isValidJoinPointType arity ty+  = valid_under emptyVarSet arity ty+  where+    valid_under tvs arity ty+      | arity == 0+      = tvs `disjointVarSet` tyCoVarsOfType ty+      | Just (t, ty') <- splitForAllTyCoVar_maybe ty+      = valid_under (tvs `extendVarSet` t) (arity-1) ty'+      | Just (_, _, _, res_ty) <- splitFunTy_maybe ty+      = valid_under tvs (arity-1) res_ty+      | otherwise+      = False++{- Note [Excess polymorphism and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In principle, if a function would be a join point except that it fails+the polymorphism rule (see Note [The polymorphism rule of join points] in+GHC.Core), it can still be made a join point with some effort. This is because+all tail calls must return the same type (they return to the same context!), and+thus if the return type depends on an argument, that argument must always be the+same.++For instance, consider:++  let f :: forall a. a -> Char -> [a]+      f @a x c = ... f @a y 'a' ...+  in ... f @Int 1 'b' ... f @Int 2 'c' ...++(where the calls are tail calls). `f` fails the polymorphism rule because its+return type is [a], where [a] is bound. But since the type argument is always+'Int', we can rewrite it as:++  let f' :: Int -> Char -> [Int]+      f' x c = ... f' y 'a' ...+  in ... f' 1 'b' ... f 2 'c' ...++and now we can make f' a join point:++  join f' :: Int -> Char -> [Int]+       f' x c = ... jump f' y 'a' ...+  in ... jump f' 1 'b' ... jump f' 2 'c' ...++It's not clear that this comes up often, however. TODO: Measure how often and+add this analysis if necessary.  See #14620.+++************************************************************************+*                                                                      *+\subsection{Sequencing on types}+*                                                                      *+************************************************************************+-}++seqType :: Type -> ()+seqType (LitTy n)                   = n `seq` ()+seqType (TyVarTy tv)                = tv `seq` ()+seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2+seqType (FunTy _ w t1 t2)           = seqType w `seq` seqType t1 `seq` seqType t2+seqType (TyConApp tc tys)           = tc `seq` seqTypes tys+seqType (ForAllTy (Bndr tv _) ty)   = seqType (varType tv) `seq` seqType ty+seqType (CastTy ty co)              = seqType ty `seq` seqCo co+seqType (CoercionTy co)             = seqCo co++seqTypes :: [Type] -> ()+seqTypes []       = ()+seqTypes (ty:tys) = seqType ty `seq` seqTypes tys++{-+************************************************************************+*                                                                      *+        The kind of a type+*                                                                      *+************************************************************************++Note [Kinding rules for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the key kinding rules for types++          torc1 is TYPE or CONSTRAINT+          torc2 is TYPE or CONSTRAINT+          t1 : torc1 rep1+          t2 : torc2 rep2+   (FUN)  ----------------+          t1 -> t2 : torc2 LiftedRep+          -- In fact the arrow varies with torc1/torc2+          -- See Note [Function type constructors and FunTy]+          -- in GHC.Builtin.Types.Prim++          torc is TYPE or CONSTRAINT+          ty : body_torc rep+          ki : Type+          `a` is a type variable+          `a` is not free in rep+(FORALL1) -----------------------+          forall (a::ki). ty : body_torc rep++          torc is TYPE or CONSTRAINT+          ty : body_torc rep+          `c` is a coercion variable+          `c` is not free in rep+          `c` is free in ty       -- Surprise 1!+(FORALL2) -------------------------+          forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep+                                           -- Surprise 2!++Note that:+* (FORALL1) rejects (forall (a::Maybe). blah)++* (FORALL2) Surprise 1:+  See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]++* (FORALL2) Surprise 2: coercion abstractions are not erased, so+  this must be LiftedRep, just like (FUN).  (FORALL2) is just a+  dependent form of (FUN).+++Note [Phantom type variables in kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  type K (r :: RuntimeRep) = Type   -- Note 'r' is unused+  data T r :: K r                   -- T :: forall r -> K r+  foo :: forall r. T r++The body of the forall in foo's type has kind (K r), and+normally it would make no sense to have+   forall r. (ty :: K r)+because the kind of the forall would escape the binding+of 'r'.  But in this case it's fine because (K r) expands+to Type, so we explicitly /permit/ the type+   forall r. T r++To accommodate such a type, in typeKind (forall a.ty) we use+occCheckExpand to expand any type synonyms in the kind of 'ty'+to eliminate 'a'.  See kinding rule (FORALL) in+Note [Kinding rules for types]+++See also+ * GHC.Core.Type.occCheckExpand+ * GHC.Core.Utils.coreAltsType+ * GHC.Tc.Validity.checkEscapingKind+all of which grapple with the same problem.++See #14939.+-}++-----------------------------+typeKind :: HasDebugCallStack => Type -> Kind+-- No need to expand synonyms+typeKind (TyConApp tc tys)      = piResultTys (tyConKind tc) tys+typeKind (LitTy l)              = typeLiteralKind l+typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af)+typeKind (TyVarTy tyvar)        = tyVarKind tyvar+typeKind (CastTy _ty co)        = coercionRKind co+typeKind (CoercionTy co)        = coercionType co++typeKind (AppTy fun arg)+  = go fun [arg]+  where+    -- Accumulate the type arguments, so we can call piResultTys,+    -- rather than a succession of calls to piResultTy (which is+    -- asymptotically costly as the number of arguments increases)+    go (AppTy fun arg) args = go fun (arg:args)+    go fun             args = piResultTys (typeKind fun) args++typeKind ty@(ForAllTy {})+  = assertPpr (not (null tcvs)) (ppr ty) $+       -- If tcvs is empty somehow we'll get an infinite loop!+    case occCheckExpand tcvs body_kind of+      -- We must make sure tvs do not occur in kind,+      -- as they would be out of scope!+      -- See Note [Phantom type variables in kinds]+      Nothing -> pprPanic "typeKind"+                  (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind)++      Just k' | all isTyVar tcvs -> k'                     -- Rule (FORALL1)+              | otherwise        -> lifted_kind_from_body  -- Rule (FORALL2)+  where+    (tcvs, body) = splitForAllTyCoVars ty  -- Important: splits both TyVar and CoVar binders+    body_kind    = typeKind body++    lifted_kind_from_body  -- Implements (FORALL2)+      = case sORTKind_maybe body_kind of+          Just (torc, _) -> liftedTypeOrConstraintKind torc+          Nothing        -> pprPanic "typeKind" (ppr body_kind)+++---------------------------------------------++sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type)+-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep)+-- and if so returns which, and the runtime rep+--+-- This is a "hot" function.  Do not call splitTyConApp_maybe here,+-- to avoid the faff with FunTy+sORTKind_maybe (TyConApp tc tys)+  -- First, short-cuts for Type and Constraint that do no allocation+  | tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike,       liftedRepTy)+  | tc_uniq == constraintKindTyConKey = assert( null tys ) $ Just (ConstraintLike, liftedRepTy)+  | tc_uniq == tYPETyConKey           = get_rep TypeLike+  | tc_uniq == cONSTRAINTTyConKey     = get_rep ConstraintLike+  | Just ty' <- expandSynTyConApp_maybe tc tys = sORTKind_maybe ty'+  where+    !tc_uniq = tyConUnique tc+     -- This bang on tc_uniq is important.  It means that sORTKind_maybe starts+     -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch++    get_rep torc = case tys of+                     (rep:_reps) -> assert (null _reps) $ Just (torc, rep)+                     []          -> Nothing++sORTKind_maybe _ = Nothing++typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint+-- Precondition: expects a type that classifies values.+-- Returns whether it is TypeLike or ConstraintLike.+-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case+typeTypeOrConstraint ty+   = case coreFullView ty of+       FunTy { ft_af = af } -> funTyFlagResultTypeOrConstraint af+       ty' | Just (torc, _) <- sORTKind_maybe (typeKind ty')+          -> torc+          | otherwise+          -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Does this classify a type allowed to have values? Responds True to things+-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.+isTYPEorCONSTRAINT :: Kind -> Bool+-- ^ True of a kind `TYPE _` or `CONSTRAINT _`+isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k)++tyConIsTYPEorCONSTRAINT :: TyCon -> Bool+tyConIsTYPEorCONSTRAINT tc+  = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey+  where+    !tc_uniq = tyConUnique tc++isConstraintLikeKind :: Kind -> Bool+-- True of (CONSTRAINT _)+isConstraintLikeKind kind+  = case sORTKind_maybe kind of+      Just (ConstraintLike, _) -> True+      _                        -> False++isConstraintKind :: Kind -> Bool+-- True of (CONSTRAINT LiftedRep)+isConstraintKind kind+  = case sORTKind_maybe kind of+      Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep+      _                          -> False++tcIsLiftedTypeKind :: Kind -> Bool+-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep?+tcIsLiftedTypeKind kind+  | Just (TypeLike, rep) <- sORTKind_maybe kind+  = isLiftedRuntimeRep rep+  | otherwise+  = False++tcIsBoxedTypeKind :: Kind -> Bool+-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@?+tcIsBoxedTypeKind kind+  | Just (TypeLike, rep) <- sORTKind_maybe kind+  = isBoxedRuntimeRep rep+  | otherwise+  = False++-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?+--+-- This considers 'Constraint' to be distinct from @*@.+isTypeLikeKind :: Kind -> Bool+isTypeLikeKind kind+  = case sORTKind_maybe kind of+      Just (TypeLike, _) -> True+      _                  -> False++returnsConstraintKind :: Kind -> Bool+-- True <=> the Kind ultimately returns a Constraint+--   E.g.  * -> Constraint+--         forall k. k -> Constraint+returnsConstraintKind kind+  | Just kind' <- coreView kind = returnsConstraintKind kind'+returnsConstraintKind (ForAllTy _ ty)         = returnsConstraintKind ty+returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty+returnsConstraintKind kind                    = isConstraintLikeKind kind++--------------------------+typeLiteralKind :: TyLit -> Kind+typeLiteralKind (NumTyLit {}) = naturalTy+typeLiteralKind (StrTyLit {}) = typeSymbolKind+typeLiteralKind (CharTyLit {}) = charTy++-- | Returns True if a type has a syntactically fixed runtime rep,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+--+-- This function is equivalent to `isFixedRuntimeRepKind . typeKind`+-- but much faster.+--+-- __Precondition:__ The type has kind @('TYPE' blah)@+typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool+typeHasFixedRuntimeRep = go+  where+    go (TyConApp tc _)+      | tcHasFixedRuntimeRep tc = True+    go (FunTy {})               = True+    go (LitTy {})               = True+    go (ForAllTy _ ty)          = go ty+    go ty                       = isFixedRuntimeRepKind (typeKind ty)++-- | Checks that a kind of the form 'Type', 'Constraint'+-- or @'TYPE r@ is concrete. See 'isConcreteType'.+--+-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah`+isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool+isFixedRuntimeRepKind k+  = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $+    -- the isLiftedTypeKind check is necessary b/c of Constraint+    isConcreteType k++-- | Tests whether the given type is concrete, i.e. it+-- whether it consists only of concrete type constructors,+-- concrete type variables, and applications.+--+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+isConcreteType :: Type -> Bool+isConcreteType = isConcreteTypeWith emptyVarSet++-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that+-- should be considered concrete.+--+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+isConcreteTypeWith :: TyVarSet -> Type -> Bool+-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon',+-- which needs to test the RHS for concreteness, under the assumption that+-- the binders are instantiated to concrete types+isConcreteTypeWith conc_tvs = go+  where+    go (TyVarTy tv)        = isConcreteTyVar tv || tv `elemVarSet` conc_tvs+    go (AppTy ty1 ty2)     = go ty1 && go ty2+    go (TyConApp tc tys)   = go_tc tc tys+    go ForAllTy{}          = False+    go (FunTy _ w t1 t2)   =  go w+                           && go (typeKind t1) && go t1+                           && go (typeKind t2) && go t2+    go LitTy{}             = True+    go CastTy{}            = False+    go CoercionTy{}        = False++    go_tc :: TyCon -> [Type] -> Bool+    go_tc tc tys+      | isForgetfulSynTyCon tc  -- E.g. type S a = Int+                                -- Then (S x) is concrete even if x isn't+      , Just ty' <- expandSynTyConApp_maybe tc tys+      = go ty'++      -- Apart from forgetful synonyms, isConcreteTyCon+      -- is enough; no need to expand.  This is good for e.g+      --      type LiftedRep = BoxedRep Lifted+      | isConcreteTyCon tc+      = all go tys++      | otherwise  -- E.g. type families+      = False++{-+%************************************************************************+%*                                                                      *+         Pretty-printing+%*                                                                      *+%************************************************************************++Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type.++-}++-- | Does a 'TyCon' (that is applied to some number of arguments) need to be+-- ascribed with an explicit kind signature to resolve ambiguity if rendered as+-- a source-syntax type?+-- (See @Note [When does a tycon application need an explicit kind signature?]@+-- for a full explanation of what this function checks for.)+tyConAppNeedsKindSig+  :: Bool  -- ^ Should specified binders count towards injective positions in+           --   the kind of the TyCon? (If you're using visible kind+           --   applications, then you want True here.+  -> TyCon+  -> Int   -- ^ The number of args the 'TyCon' is applied to.+  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the+           --   number of arguments)+tyConAppNeedsKindSig spec_inj_pos tc n_args+  | LT <- listLengthCmp tc_binders n_args+  = False+  | otherwise+  = let (dropped_binders, remaining_binders)+          = splitAt n_args tc_binders+        result_kind  = mkTyConKind remaining_binders tc_res_kind+        result_vars  = tyCoVarsOfType result_kind+        dropped_vars = fvVarSet $+                       mapUnionFV injective_vars_of_binder dropped_binders++    in not (subVarSet result_vars dropped_vars)+  where+    tc_binders  = tyConBinders tc+    tc_res_kind = tyConResKind tc++    -- Returns the variables that would be fixed by knowing a TyConBinder. See+    -- Note [When does a tycon application need an explicit kind signature?]+    -- for a more detailed explanation of what this function does.+    injective_vars_of_binder :: TyConBinder -> FV+    injective_vars_of_binder (Bndr tv vis) =+      case vis of+        AnonTCB        -> injectiveVarsOfType False -- conservative choice+                                              (varType tv)+        NamedTCB argf  | source_of_injectivity argf+                       -> unitFV tv `unionFV`+                          injectiveVarsOfType False (varType tv)+        _              -> emptyFV++    source_of_injectivity Required  = True+    source_of_injectivity Specified = spec_inj_pos+    source_of_injectivity Inferred  = False++{-+Note [When does a tycon application need an explicit kind signature?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a couple of places in GHC where we convert Core Types into forms that+more closely resemble user-written syntax. These include:++1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app)+2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock)++This conversion presents a challenge: how do we ensure that the resulting type+has enough kind information so as not to be ambiguous? To better motivate this+question, consider the following Core type:++  -- Foo :: Type -> Type+  type Foo = Proxy Type++There is nothing ambiguous about the RHS of Foo in Core. But if we were to,+say, reify it into a TH Type, then it's tempting to just drop the invisible+Type argument and simply return `Proxy`. But now we've lost crucial kind+information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`+or `Proxy Int` or something else! We've inadvertently introduced ambiguity.++Unlike in other situations in GHC, we can't just turn on+-fprint-explicit-kinds, as we need to produce something which has the same+structure as a source-syntax type. Moreover, we can't rely on visible kind+application, since the first kind argument to Proxy is inferred, not specified.+Our solution is to annotate certain tycons with their kinds whenever they+appear in applied form in order to resolve the ambiguity. For instance, we+would reify the RHS of Foo like so:++  type Foo = (Proxy :: Type -> Type)++We need to devise an algorithm that determines precisely which tycons need+these explicit kind signatures. We certainly don't want to annotate _every_+tycon with a kind signature, or else we might end up with horribly bloated+types like the following:++  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)++We only want to annotate tycons that absolutely require kind signatures in+order to resolve some sort of ambiguity, and nothing more.++Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type+require a kind signature? It might require it when we need to fill in any of+T's omitted arguments. By "omitted argument", we mean one that is dropped when+reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and+specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the+omitted arguments are only the inferred ones (e.g., in situations where+specified arguments are reified through visible kind application).+Regardless, the key idea is that _some_ arguments are going to be omitted after+reification, and the only mechanism we have at our disposal for filling them in+is through explicit kind signatures.++What do we mean by "fill in"? Let's consider this small example:++  T :: forall {k}. Type -> (k -> Type) -> k++Moreover, we have this application of T:++  T @{j} Int aty++When we reify this type, we omit the inferred argument @{j}. Is it fixed by the+other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then+we'll generate an equality constraint (kappa -> Type) and, assuming we can+solve it, that will fix `kappa`. (Here, `kappa` is the unification variable+that we instantiate `k` with.)++Therefore, for any application of a tycon T to some arguments, the Question We+Must Answer is:++* Given the first n arguments of T, do the kinds of the non-omitted arguments+  fill in the omitted arguments?++(This is still a bit hand-wavy, but we'll refine this question incrementally+as we explain more of the machinery underlying this process.)++Answering this question is precisely the role that the `injectiveVarsOfType`+and `injective_vars_of_binder` functions exist to serve. If an omitted argument+`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing+`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a+bit.)++More formally, if+`a` is in `injectiveVarsOfType ty`+and  S1(ty) ~ S2(ty),+then S1(a)  ~ S2(a),+where S1 and S2 are arbitrary substitutions.++For example, is `F` is a non-injective type family, then++  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}++Now that we know what this function does, here is a second attempt at the+Question We Must Answer:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. Do the injective+  variables of these binders fill in the remainder of T's kind?++Alright, we're getting closer. Next, we need to clarify what the injective+variables of a tycon binder are. This the role that the+`injective_vars_of_binder` function serves. Here is what this function does for+each form of tycon binder:++* Anonymous binders are injective positions. 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 kinds of 'True and+  '[] would contribute to the kind of '(:) 'True '[]. Therefore,+  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.+  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)+* Named binders:+  - Inferred binders are never injective positions. For example, in this data+    type:++      data Proxy a+      Proxy :: forall {k}. k -> Type++    If we had Proxy 'True, then the kind of 'True would not contribute to the+    kind of Proxy 'True. Therefore,+    injective_vars_of_binder(forall {k}. ...) = {}.+  - Required binders are injective positions. For example, in this data type:++      data 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 kind of Maybe a would+  contribute to the kind of Wurble (Maybe a) Nothing. Hence,+  injective_vars_of_binder(forall a -> ...) = {a}.+  - Specified binders /might/ be injective positions, depending on how you+    approach things. Continuing the '(:) example:++      '(:) :: forall a. a -> [a] -> [a]++    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind+    of '(:) 'True '[], since it's not explicitly instantiated by the user. But+    if visible kind application is enabled, then this is possible, since the+    user can write '(:) @Bool 'True '[]. (In that case,+    injective_vars_of_binder(forall a. ...) = {a}.)++    There are some situations where using visible kind application is appropriate+    and others where it is not (e.g., TH+    reification), so the `injective_vars_of_binder` function is parameterized by+    a Bool which decides if specified binders should be counted towards+    injective positions or not.++Now that we've defined injective_vars_of_binder, we can refine the Question We+Must Answer once more:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the remainder of T's kind?++If the answer to this question is "no", then (T ty_1 ... ty_n) needs an+explicit kind signature, since T's kind has kind variables leftover that+aren't fixed by the non-omitted arguments.++One last sticking point: what does "the remainder of T's kind" mean? You might+be tempted to think that it corresponds to all of the arguments in the kind of+T that would normally be instantiated by omitted arguments. But this isn't+quite right, strictly speaking. Consider the following (silly) example:++  S :: forall {k}. Type -> Type++And suppose we have this application of S:++  S Int Bool++The Int argument would be omitted, and+injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which+might suggest that (S Bool) needs an explicit kind signature. But+(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature+only affects the /result/ of the application, not all of the individual+arguments. So adding a kind signature here won't make a difference. Therefore,+the fourth (and final) iteration of the Question We Must Answer is:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the kind of (T ty_1 ... ty_n)?++Phew, that was a lot of work!++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.++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.+-}++{-+************************************************************************+*                                                                      *+        Multiplicities+*                                                                      *+************************************************************************++These functions would prefer to be in GHC.Core.Multiplicity, but+they some are used elsewhere in this module, and wanted to bring+their friends here with them.+-}++unrestricted, linear, tymult :: a -> Scaled a++-- | Scale a payload by Many+unrestricted = Scaled ManyTy++-- | Scale a payload by One+linear = Scaled OneTy++-- | Scale a payload by Many; used for type arguments in core+tymult = Scaled ManyTy++irrelevantMult :: Scaled a -> a+irrelevantMult = scaledThing++mkScaled :: Mult -> a -> Scaled a+mkScaled = Scaled++scaledSet :: Scaled a -> b -> Scaled b+scaledSet (Scaled m _) b = Scaled m b++pattern OneTy :: Mult+pattern OneTy <- (isOneTy -> True)+  where OneTy = oneDataConTy++pattern ManyTy :: Mult+pattern ManyTy <- (isManyTy -> True)+  where ManyTy = manyDataConTy++isManyTy :: Mult -> Bool+isManyTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` manyDataConKey+isManyTy _ = False++isOneTy :: Mult -> Bool+isOneTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` oneDataConKey+isOneTy _ = False++isLinearType :: Type -> Bool+-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function+-- where at least one argument is linear (or otherwise non-unrestricted). We use+-- this function to check whether it is safe to eta reduce an Id in CorePrep. It+-- is always safe to return 'True', because 'True' deactivates the optimisation.+isLinearType ty = case ty of+                      FunTy _ ManyTy _ res -> isLinearType res+                      FunTy _ _ _ _        -> True+                      ForAllTy _ res       -> isLinearType res+                      _ -> False++{- *********************************************************************+*                                                                      *+                    Space-saving construction+*                                                                      *+********************************************************************* -}++{- Note [Using synonyms to compress types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Was: [Prefer Type over TYPE (BoxedRep Lifted)]++The Core of nearly any program will have numerous occurrences of the Types++   TyConApp BoxedRep [TyConApp Lifted []]    -- Synonym LiftedRep+   TyConApp BoxedRep [TyConApp Unlifted []]  -- Synonym UnliftedREp+   TyConApp TYPE [TyConApp LiftedRep []]     -- Synonym Type+   TyConApp TYPE [TyConApp UnliftedRep []]   -- Synonym UnliftedType++While investigating #17292 we found that these constituted a majority+of all TyConApp constructors on the heap:++    (From a sample of 100000 TyConApp closures)+    0x45f3523    - 28732 - `Type`+    0x420b840702 - 9629  - generic type constructors+    0x42055b7e46 - 9596+    0x420559b582 - 9511+    0x420bb15a1e - 9509+    0x420b86c6ba - 9501+    0x42055bac1e - 9496+    0x45e68fd    - 538   - `TYPE ...`++Consequently, we try hard to ensure that operations on such types are+efficient. Specifically, we strive to++ a. Avoid heap allocation of such types; use a single static TyConApp+ b. Use a small (shallow in the tree-depth sense) representation+    for such types++Goal (b) is particularly useful as it makes traversals (e.g. free variable+traversal, substitution, and comparison) more efficient.+Comparison in particular takes special advantage of nullary type synonym+applications (e.g. things like @TyConApp typeTyCon []@). See+* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare"+* Note [Unifying type synonyms] in "GHC.Core.Unify"++To accomplish these we use a number of tricks, implemented by mkTyConApp.++ 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]),+    we prefer a statically-allocated (TyConApp LiftedRep [])+    where `LiftedRep` is a type synonym:+       type LiftedRep = BoxedRep Lifted+    Similarly for UnliftedRep++ 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []])+    we prefer the statically-allocated (TyConApp Type [])+    where `Type` is a type synonym+       type Type = TYPE LiftedRep+    Similarly for UnliftedType++These serve goal (b) since there are no applied type arguments to traverse,+e.g., during comparison.++ 3. We have a single, statically allocated top-level binding to+    represent `TyConApp GHC.Types.Type []` (namely+    'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't+    need to allocate such types (goal (a)).  See functions+    mkTYPEapp and mkBoxedRepApp++ 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps]+    in GHC.Core.TyCon to ensure that we never need to allocate such+    nullary applications (goal (a)).++See #17958, #20541+-}++-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to+-- its arguments.  Applies its arguments to the constructor from left to right.+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tycon []+  = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon+    mkTyConTy tycon++mkTyConApp tycon tys@(ty1:rest)+  | Just fun_ty <- tyConAppFunTy_maybe tycon tys+  = fun_ty++  -- See Note [Using synonyms to compress types]+  | key == tYPETyConKey+  , Just ty <- mkTYPEapp_maybe ty1+  = assert (null rest) ty++  | key == cONSTRAINTTyConKey+  , Just ty <- mkCONSTRAINTapp_maybe ty1+  = assert (null rest) ty++  -- See Note [Using synonyms to compress types]+  | key == boxedRepDataConTyConKey+  , Just ty <- mkBoxedRepApp_maybe ty1+  = assert (null rest) ty++  | key == tupleRepDataConTyConKey+  , Just ty <- mkTupleRepApp_maybe ty1+  = assert (null rest) ty++  -- The catch-all case+  | otherwise+  = TyConApp tycon tys+  where+    key = tyConUnique tycon+++{- Note [Care using synonyms to compress types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Using a synonym to compress a types has a tricky wrinkle. Consider+coreView applied to (TyConApp LiftedRep [])++* coreView expands the LiftedRep synonym:+     type LiftedRep = BoxedRep Lifted++* Danger: we might apply the empty substitution to the RHS of the+  synonym.  And substTy calls mkTyConApp BoxedRep [Lifted]. And+  mkTyConApp compresses that back to LiftedRep.  Loop!++* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary+  type synonyms.  That's more efficient anyway.+-}+++mkTYPEapp :: RuntimeRepType -> Type+mkTYPEapp rr+  = case mkTYPEapp_maybe rr of+       Just ty -> ty+       Nothing -> TyConApp tYPETyCon [rr]++mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type+-- ^ Given a @RuntimeRep@, applies @TYPE@ to it.+-- On the fly it rewrites+--      TYPE LiftedRep      -->   liftedTypeKind    (a synonym)+--      TYPE UnliftedRep    -->   unliftedTypeKind  (ditto)+--      TYPE ZeroBitRep     -->   zeroBitTypeKind   (ditto)+-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted)+--     because those inner types should already have been rewritten+--     to LiftedRep and UnliftedRep respectively, by mkTyConApp+--+-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkTYPEapp_maybe #-}+mkTYPEapp_maybe (TyConApp tc args)+  | key == liftedRepTyConKey    = assert (null args) $ Just liftedTypeKind   -- TYPE LiftedRep+  | key == unliftedRepTyConKey  = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep+  | key == zeroBitRepTyConKey   = assert (null args) $ Just zeroBitTypeKind  -- TYPE ZeroBitRep+  where+    key = tyConUnique tc+mkTYPEapp_maybe _ = Nothing++------------------+mkCONSTRAINTapp :: RuntimeRepType -> Type+-- ^ Just like mkTYPEapp+mkCONSTRAINTapp rr+  = case mkCONSTRAINTapp_maybe rr of+       Just ty -> ty+       Nothing -> TyConApp cONSTRAINTTyCon [rr]++mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type+-- ^ Just like mkTYPEapp_maybe+{-# NOINLINE mkCONSTRAINTapp_maybe #-}+mkCONSTRAINTapp_maybe (TyConApp tc args)+  | tc `hasKey` liftedRepTyConKey = assert (null args) $+                                    Just constraintKind   -- CONSTRAINT LiftedRep+mkCONSTRAINTapp_maybe _ = Nothing++------------------+mkBoxedRepApp_maybe :: LevityType -> Maybe Type+-- ^ Given a `Levity`, apply `BoxedRep` to it+-- On the fly, rewrite+--      BoxedRep Lifted     -->   liftedRepTy    (a synonym)+--      BoxedRep Unlifted   -->   unliftedRepTy  (ditto)+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkBoxedRepApp_maybe #-}+mkBoxedRepApp_maybe (TyConApp tc args)+  | key == liftedDataConKey   = assert (null args) $ Just liftedRepTy    -- BoxedRep Lifted+  | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy  -- BoxedRep Unlifted+  where+    key = tyConUnique tc+mkBoxedRepApp_maybe _ = Nothing++mkTupleRepApp_maybe :: Type -> Maybe Type+-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it+-- On the fly, rewrite+--      TupleRep [] -> zeroBitRepTy   (a synonym)+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkTupleRepApp_maybe #-}+mkTupleRepApp_maybe (TyConApp tc args)+  | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy  -- ZeroBitRep+  where+    key = tyConUnique tc+mkTupleRepApp_maybe _ = Nothing++typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind+typeOrConstraintKind TypeLike       rep = mkTYPEapp       rep+typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep++liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind+liftedTypeOrConstraintKind TypeLike       = liftedTypeKind+liftedTypeOrConstraintKind ConstraintLike = constraintKind
+ GHC/Core/Type.hs-boot view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}++module GHC.Core.Type where++import GHC.Prelude+import {-# SOURCE #-} GHC.Core.TyCon+import {-# SOURCE #-} GHC.Core.TyCo.Rep( Type, Coercion )+import GHC.Utils.Misc+import GHC.Types.Var( FunTyFlag, TyVar )+import GHC.Types.Basic( TypeOrConstraint )+++coreView         :: Type -> Maybe Type+rewriterView     :: Type -> Maybe Type+chooseFunTyFlag  :: HasDebugCallStack => Type -> Type -> FunTyFlag+typeKind         :: HasDebugCallStack => Type -> Type+isCoercionTy     :: Type -> Bool+mkAppTy          :: Type -> Type -> Type+mkCastTy         :: Type -> Coercion -> Type+mkTyConApp       :: TyCon -> [Type] -> Type+getLevity        :: HasDebugCallStack => Type -> Type+getTyVar_maybe   :: Type -> Maybe TyVar+isLiftedTypeKind :: Type -> Bool++partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])+typeTypeOrConstraint    :: HasDebugCallStack => Type -> TypeOrConstraint
+ GHC/Core/Unfold.hs view
@@ -0,0 +1,1081 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++Core-syntax unfoldings++Unfoldings (which can travel across module boundaries) are in Core+syntax (namely @CoreExpr@s).++The type @Unfolding@ sits ``above'' simply-Core-expressions+unfoldings, capturing ``higher-level'' things we know about a binding,+usually things that the simplifier found out (e.g., ``it's a+literal'').  In the corner of a @CoreUnfolding@ unfolding, you will+find, unsurprisingly, a Core expression.+-}++++module GHC.Core.Unfold (+        Unfolding, UnfoldingGuidance,   -- Abstract types++        ExprSize(..), sizeExpr,++        ArgSummary(..), nonTriv,+        CallCtxt(..),++        UnfoldingOpts (..), defaultUnfoldingOpts,+        updateCreationThreshold, updateUseThreshold,+        updateFunAppDiscount, updateDictDiscount,+        updateVeryAggressive, updateCaseScaling,+        updateCaseThreshold, updateReportPrefix,++        inlineBoringOk, calcUnfoldingGuidance,+        uncondInlineJoin+    ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.Utils+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Class( Class )+import GHC.Core.Predicate( isUnaryClass )++import GHC.Types.Id+import GHC.Types.Literal+import GHC.Types.Id.Info+import GHC.Types.RepType ( isZeroBitTy )+import GHC.Types.Basic  ( Arity, RecFlag )+import GHC.Types.ForeignCall+import GHC.Types.Tickish++import GHC.Builtin.PrimOps+import GHC.Builtin.Names++import GHC.Data.Bag++import GHC.Utils.Misc+import GHC.Utils.Outputable++import qualified Data.ByteString as BS+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE++-- | Unfolding options+data UnfoldingOpts = UnfoldingOpts+   { unfoldingCreationThreshold :: !Int+      -- ^ Threshold above which unfoldings are not *created*++   , unfoldingUseThreshold :: !Int+      -- ^ Threshold above which unfoldings are not *inlined*++   , unfoldingFunAppDiscount :: !Int+      -- ^ Discount for lambdas that are used (applied)++   , unfoldingDictDiscount :: !Int+      -- ^ Discount for dictionaries++   , unfoldingVeryAggressive :: !Bool+      -- ^ Force inlining in many more cases++   , unfoldingCaseThreshold :: !Int+      -- ^ Don't consider depth up to x++   , unfoldingCaseScaling :: !Int+      -- ^ Penalize depth with 1/x++   , unfoldingReportPrefix :: !(Maybe String)+      -- ^ Only report inlining decisions for names with this prefix+   }++defaultUnfoldingOpts :: UnfoldingOpts+defaultUnfoldingOpts = UnfoldingOpts+   { unfoldingCreationThreshold = 750+      -- The unfoldingCreationThreshold threshold must be reasonably high+      -- to take account of possible discounts.+      -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to+      -- inline into Csg.calc (The unfolding for sqr never makes it+      -- into the interface file.)++   , unfoldingUseThreshold   = 90+      -- Last adjusted upwards in #18282, when I reduced+      -- the result discount for constructors.++   , unfoldingFunAppDiscount = 60+      -- Be fairly keen to inline a function if that means+      -- we'll be able to pick the right method from a dictionary++   , unfoldingDictDiscount   = 30+      -- Be fairly keen to inline a function if that means+      -- we'll be able to pick the right method from a dictionary++   , unfoldingVeryAggressive = False++      -- Only apply scaling once we are deeper than threshold cases+      -- in an RHS.+   , unfoldingCaseThreshold = 2++      -- Penalize depth with (size*depth)/scaling+   , unfoldingCaseScaling = 30++      -- Don't filter inlining decision reports+   , unfoldingReportPrefix = Nothing+   }++-- Helpers for "GHC.Driver.Session"++updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCreationThreshold n opts = opts { unfoldingCreationThreshold = n }++updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateUseThreshold n opts = opts { unfoldingUseThreshold = n }++updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts+updateFunAppDiscount n opts = opts { unfoldingFunAppDiscount = n }++updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts+updateDictDiscount n opts = opts { unfoldingDictDiscount = n }++updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts+updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n }+++updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n }++updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling n opts = opts { unfoldingCaseScaling = n }++updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts+updateReportPrefix n opts = opts { unfoldingReportPrefix = n }++data ArgSummary = TrivArg       -- Nothing interesting+                | NonTrivArg    -- Arg has structure+                | ValueArg      -- Arg is a con-app or PAP+                                -- ..or con-like. Note [Conlike is interesting]++instance Outputable ArgSummary where+  ppr TrivArg    = text "TrivArg"+  ppr NonTrivArg = text "NonTrivArg"+  ppr ValueArg   = text "ValueArg"++nonTriv ::  ArgSummary -> Bool+nonTriv TrivArg = False+nonTriv _       = True++data CallCtxt+  = BoringCtxt+  | RhsCtxt RecFlag     -- Rhs of a let-binding; see Note [RHS of lets]+  | DiscArgCtxt         -- Argument of a function with non-zero arg discount+  | RuleArgCtxt         -- We are somewhere in the argument of a function with rules++  | ValAppCtxt          -- We're applied to at least one value arg+                        -- This arises when we have ((f x |> co) y)+                        -- Then the (f x) has argument 'x' but in a ValAppCtxt++  | CaseCtxt            -- We're the scrutinee of a case+                        -- that decomposes its scrutinee++instance Outputable CallCtxt where+  ppr CaseCtxt    = text "CaseCtxt"+  ppr ValAppCtxt  = text "ValAppCtxt"+  ppr BoringCtxt  = text "BoringCtxt"+  ppr (RhsCtxt ir)= text "RhsCtxt" <> parens (ppr ir)+  ppr DiscArgCtxt = text "DiscArgCtxt"+  ppr RuleArgCtxt = text "RuleArgCtxt"++{-+Note [Calculate unfolding guidance on the non-occ-anal'd expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that we give the non-occur-analysed expression to+calcUnfoldingGuidance.  In some ways it'd be better to occur-analyse+first; for example, sometimes during simplification, there's a large+let-bound thing which has been substituted, and so is now dead; so+'expr' contains two copies of the thing while the occurrence-analysed+expression doesn't.++Nevertheless, we *don't* and *must not* occ-analyse before computing+the size because++a) The size computation bales out after a while, whereas occurrence+   analysis does not.++b) Residency increases sharply if you occ-anal first.  I'm not+   100% sure why, but it's a large effect.  Compiling Cabal went+   from residency of 534M to over 800M with this one change.++This can occasionally mean that the guidance is very pessimistic;+it gets fixed up next round.  And it should be rare, because large+let-bound things that are dead are usually caught by preInlineUnconditionally+++************************************************************************+*                                                                      *+\subsection{The UnfoldingGuidance type}+*                                                                      *+************************************************************************+-}++{- Note [inlineBoringOk]+~~~~~~~~~~~~~~~~~~~~~~~~+See Note [INLINE for small functions]++The function `inlineBoringOk` returns True (boringCxtOk) if the supplied+unfolding, which looks like (\x y z. body), is such that the result of+inlining a saturated call is no bigger than `body`.  Some wrinkles:++(IB1) An important case is+    - \x. (x `cast` co)++(IB2) If `body` looks like a data constructor worker, we become keener+  to inline, by ignoring the number of arguments; we just insist they+  are all trivial.  Reason: in a call like `f (g x y)`, if `g` unfolds+  to a data construtor, we can allocate a data constructor instead of+  a thunk (g x y).++  A case in point where a GADT data constructor failed to inline (#25713)+      $WK = /\a \x. K @a <co> x+  We really want to inline a boring call to $WK so that we allocate+  a data constructor not a thunk ($WK @ty x).++  But not for nullary constructors!  We don't want to turn+     f ($WRefl @ty)+  into+     f (Refl @ty <co>)+   because the latter might allocate, whereas the former shares.+   (You might wonder if (Refl @ty <co>) should allocate, but I think+   that currently it does.)  So for nullary constructors, `inlineBoringOk`+   returns False.++(IB3) Types and coercions do not count towards the expression size.+      They are ultimately erased.++(IB4) If there are no value arguments, `inlineBoringOk` we have to be+  careful (#17182).  If we have+      let y = x @Int in f y y+  there’s no reason not to inline y at both use sites — no work is+  actually duplicated.++  But not so for coercion arguments! Unlike type arguments, which have+  no runtime representation, coercion arguments *do* have a runtime+  representation (albeit the zero-width VoidRep, see Note [Coercion+  tokens] in "GHC.CoreToStg").  For example:+       let y = g @Int <co> in g y y+  Here `co` is a value argument, and calling it twice might duplicate+  work.++  Even if `g` is a data constructor, so no work is duplicated,+  inlining `y` might duplicate allocation of a data constructor object+  (#17787). See also (IB2).++  TL;DR: if `is_fun` is False, so we have no value arguments, we /do/+  count coercion arguments, despite (IB3).++(IB5) You might wonder about an unfolding like  (\x y z -> x (y z)),+  whose body is, in some sense, just as small as (g x y z).+  But `inlineBoringOk` doesn't attempt anything fancy; it just looks+  for a function call with trivial arguments, Keep it simple.++(IB6) If we have an unfolding (K op) where K is a unary-class data constructor,+  we want to inline it!  So that we get calls (f op), which in turn can see (in+  STG land) that `op` is already evaluated and properly tagged. (If `op` isn't+  trivial we will have baled out before we get to the Var case.)  This made+  a big difference in benchmarks for the `effectful` library; details in !10479.++  See Note [Unary class magic] in GHC/Core/TyCon.+-}++inlineBoringOk :: CoreExpr -> Bool+-- True => the result of inlining the expression is+--         no bigger than the expression itself+--     eg      (\x y -> f y x)+-- See Note [inlineBoringOk]+inlineBoringOk e+  = go 0 e+  where+    is_fun = isValFun e++    go :: Int -> CoreExpr -> Bool+    -- credit = #(value lambdas) = #(value args)+    go credit (Lam x e) | isRuntimeVar x  = go (credit+1) e+                        | otherwise       = go credit e      -- See (IB3)++    go credit (App f (Type {}))           = go credit f      -- See (IB3)+    go credit (App f (Coercion {}))+      | is_fun                            = go credit f      -- See (IB3)+      | otherwise                         = go (credit-1) f  -- See (IB4)+    go credit (App f a) | exprIsTrivial a = go (credit-1) f++    go credit (Case e b _ alts)+      | null alts+      = go credit e   -- EmptyCase is like e+      | Just rhs <- isUnsafeEqualityCase e b alts+      = go credit rhs -- See Note [Inline unsafeCoerce]++    go credit (Tick _ e) = go credit e      -- dubious+    go credit (Cast e _) = go credit e      -- See (IB3)++    -- Lit: we assume credit >= 0; literals aren't functions+    go _      (Lit l)    = litIsTrivial l && boringCxtOk++    go credit (Var v) | isDataConWorkId v, is_fun = boringCxtOk  -- See (IB2)+                      | isUnaryClassId v          = boringCxtOk  -- See (IB6)+                      | credit >= 0               = boringCxtOk+                      | otherwise                 = boringCxtNotOk++    go _ _ = boringCxtNotOk++isValFun :: CoreExpr -> Bool+-- True of functions with at least+-- one top-level value lambda+isValFun (Lam b e) | isRuntimeVar b = True+                   | otherwise      = isValFun e+isValFun _                          = False++calcUnfoldingGuidance+        :: UnfoldingOpts+        -> Bool          -- Definitely a top-level, bottoming binding+        -> Bool          -- True <=> join point+        -> CoreExpr      -- Expression to look at+        -> UnfoldingGuidance+calcUnfoldingGuidance opts is_top_bottoming is_join (Tick t expr)+  | not (tickishIsCode t)  -- non-code ticks don't matter for unfolding+  = calcUnfoldingGuidance opts is_top_bottoming is_join expr+calcUnfoldingGuidance opts is_top_bottoming is_join expr+  = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of+      TooBig -> UnfNever+      SizeIs size cased_bndrs scrut_discount+        | uncondInline is_join expr bndrs n_val_bndrs body size+        -> UnfWhen { ug_unsat_ok = unSaturatedOk+                   , ug_boring_ok =  boringCxtOk+                   , ug_arity = n_val_bndrs }   -- Note [INLINE for small functions]++        | is_top_bottoming+        -> UnfNever   -- See Note [Do not inline top-level bottoming functions]++        | otherwise+        -> UnfIfGoodArgs { ug_args  = map (mk_discount cased_bndrs) val_bndrs+                         , ug_size  = size+                         , ug_res   = scrut_discount }++  where+    (bndrs, body) = collectBinders expr+    bOMB_OUT_SIZE = unfoldingCreationThreshold opts+           -- Bomb out if size gets bigger than this+    val_bndrs   = filter isId bndrs+    n_val_bndrs = length val_bndrs++    mk_discount :: Bag (Id,Int) -> Id -> Int+    mk_discount cbs bndr = foldl' combine 0 cbs+           where+             combine acc (bndr', disc)+               | bndr == bndr' = acc `plus_disc` disc+               | otherwise     = acc++             plus_disc :: Int -> Int -> Int+             plus_disc | isFunTy (idType bndr) = max+                       | otherwise             = (+)+             -- See Note [Function and non-function discounts]++{- Note [Inline unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We really want to inline unsafeCoerce, even when applied to boring+arguments.  It doesn't look as if its RHS is smaller than the call+   unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x+but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce]+in base:Unsafe.Coerce.++Moreover, if we /don't/ inline it, we may be left with+          f (unsafeCoerce x)+which will build a thunk -- bad, bad, bad.++Conclusion: we really want inlineBoringOk to be True of the RHS of+unsafeCoerce. And it really is, because we regard+  case unsafeEqualityProof @a @b of UnsafeRefl -> rhs+as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce].++Note [Computing the size of an expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of sizeExpr is obvious enough: count nodes.  But getting the+heuristics right has taken a long time.  Here's the basic strategy:++    * Variables, literals: 0+      (Exception for string literals, see litSize.)++    * Function applications (f e1 .. en): 1 + #value args++    * Constructor applications: 1, regardless of #args++    * Let(rec): 1 + size of components++    * Note, cast: 0++Examples++  Size  Term+  --------------+    0     42#+    0     x+    0     True+    2     f x+    1     Just x+    4     f (g x)++Notice that 'x' counts 0, while (f x) counts 2.  That's deliberate: there's+a function call to account for.  Notice also that constructor applications+are very cheap, because exposing them to a caller is so valuable.++[25/5/11] All sizes are now multiplied by 10, except for primops+(which have sizes like 1 or 4.  This makes primops look fantastically+cheap, and seems to be almost universally beneficial.  Done partly as a+result of #4978.++Note [Do not inline top-level bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The FloatOut pass has gone to some trouble to float out calls to 'error'+and similar friends.  See Note [Bottoming floats] in GHC.Core.Opt.SetLevels.+Do not re-inline them!  But we *do* still inline if they are very small+(the uncondInline stuff).++Note [INLINE for small functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        {-# INLINE f #-}+                f x = Just x+                g y = f y+Then f's RHS is no larger than its LHS, so we should inline it into+even the most boring context.  In general, f the function is+sufficiently small that its body is as small as the call itself, the+inline unconditionally, regardless of how boring the context is.++Things to note:++(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr)+    than the thing it's replacing.  Notice that+      (f x) --> (g 3)             -- YES, unconditionally+      (f x) --> x : []            -- YES, *even though* there are two+                                  --      arguments to the cons+      x     --> g 3               -- NO+      x     --> Just v            -- NO++    It's very important not to unconditionally replace a variable by+    a non-atomic term.++(2) We do this even if the thing isn't saturated, else we end up with the+    silly situation that+       f x y = x+       ...map (f 3)...+    doesn't inline.  Even in a boring context, inlining without being+    saturated will give a lambda instead of a PAP, and will be more+    efficient at runtime.++(3) However, when the function's arity > 0, we do insist that it+    has at least one value argument at the call site.  (This check is+    made in the UnfWhen case of callSiteInline.) Otherwise we find this:+         f = /\a \x:a. x+         d = /\b. MkD (f b)+    If we inline f here we get+         d = /\b. MkD (\x:b. x)+    and then prepareRhs floats out the argument, abstracting the type+    variables, so we end up with the original again!++(4) We must be much more cautious about arity-zero things. Consider+       let x = y +# z in ...+    In *size* terms primops look very small, because the generate a+    single instruction, but we do not want to unconditionally replace+    every occurrence of x with (y +# z).  So we only do the+    unconditional-inline thing for *trivial* expressions.++    NB: you might think that PostInlineUnconditionally would do this+    but it doesn't fire for top-level things; see GHC.Core.Opt.Simplify.Utils+    Note [Top level and postInlineUnconditionally]+-}++uncondInline :: Bool -> CoreExpr -> [Var] -> Arity -> CoreExpr -> Int -> Bool+-- Inline unconditionally if there no size increase+-- Size of call is arity (+1 for the function)+-- See Note [INLINE for small functions]+uncondInline is_join rhs bndrs arity body size+  | is_join   = uncondInlineJoin bndrs body+  | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)+  | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4)++uncondInlineJoin :: [Var] -> CoreExpr -> Bool+-- See Note [Duplicating join points] point (DJ3) in GHC.Core.Opt.Simplify.Iteration+uncondInlineJoin bndrs body++  -- (DJ3)(a)+  | exprIsTrivial body+  = True   -- Nullary constructors, literals++  -- (DJ3)(b) and (DJ3)(c) combined+  | indirectionOrAppWithoutFVs+  = True++  | otherwise+  = False++  where+    -- (DJ3)(b):+    -- - $j1 x = $j2 y x |> co  -- YES, inline indirection regardless of free vars+    -- (DJ3)(c):+    -- - $j1 x y = K y x |> co  -- YES, inline!+    -- - $j2 x = K f x          -- No, don't! (because f is free)+    indirectionOrAppWithoutFVs = go False body++    go !seen_fv (App f a)+      | Just has_fv <- go_arg a+                          = go (seen_fv || has_fv) f+      | otherwise         = False       -- Not trivial+    go seen_fv (Var v)+      | isJoinId v        = True        -- Indirection to another join point; always inline+      | isDataConId v     = not seen_fv -- e.g. $j a b = K a b+      | v `elem` bndrs    = not seen_fv -- e.g. $j a b = b a+    go seen_fv (Cast e _) = go seen_fv e+    go seen_fv (Tick _ e) = go seen_fv e+    go _ _                = False++    -- go_arg returns:+    --  - `Nothing` if arg is not trivial+    --  - `Just True` if arg is trivial but contains free var, literal, or constructor+    --  - `Just False` if arg is trivial without free vars+    go_arg (Type {})     = Just False+    go_arg (Coercion {}) = Just False+    go_arg (Lit l)+      | litIsTrivial l   = Just True    -- e.g. $j x = $j2 x 7 YES, but $j x = K x 7 NO+      | otherwise        = Nothing+    go_arg (App f a)+      | isTyCoArg a      = go_arg f     -- e.g. $j f = K (f @a)+      | otherwise        = Nothing+    go_arg (Cast e _)    = go_arg e+    go_arg (Tick _ e)    = go_arg e+    go_arg (Var f)       = Just $! f `notElem` bndrs+    go_arg _             = Nothing+++sizeExpr :: UnfoldingOpts+         -> Int             -- Bomb out if it gets bigger than this+         -> [Id]            -- Arguments; we're interested in which of these+                            -- get case'd+         -> CoreExpr+         -> ExprSize++-- Note [Computing the size of an expression]++-- Forcing bOMB_OUT_SIZE early prevents repeated+-- unboxing of the Int argument.+sizeExpr opts !bOMB_OUT_SIZE top_args expr+  = size_up expr+  where+    size_up (Cast e _) = size_up e+    size_up (Tick _ e) = size_up e+    size_up (Type _)   = sizeZero           -- Types cost nothing+    size_up (Coercion _) = sizeZero+    size_up (Lit lit)  = sizeN (litSize lit)+    size_up (Var f) | isZeroBitId f = sizeZero+                      -- Make sure we get constructor discounts even+                      -- on nullary constructors+                    | otherwise       = size_up_call f [] 0++    size_up (App fun arg)+      | isTyCoArg arg = size_up fun+      | otherwise     = size_up arg  `addSizeNSD`+                        size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0)++    size_up (Lam b e)+      | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)+      | otherwise = size_up e++    size_up (Let (NonRec binder rhs) body)+      = size_up_rhs (binder, rhs) `addSizeNSD`+        size_up body              `addSizeN`+        size_up_alloc binder++    size_up (Let (Rec pairs) body)+      = foldr (addSizeNSD . size_up_rhs)+              (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs))+              pairs++    size_up (Case e _ _ alts) = case nonEmpty alts of+      Nothing -> size_up e    -- case e of {} never returns, so take size of scrutinee+      Just alts+        | Just v <- is_top_arg e -> -- We are scrutinising an argument variable+          let+            alt_sizes = NE.map size_up_alt alts++                  -- alts_size tries to compute a good discount for+                  -- the case when we are scrutinising an argument variable+            alts_size (SizeIs tot tot_disc tot_scrut)+                          -- Size of all alternatives+                      (SizeIs max _        _)+                          -- Size of biggest alternative+                  = SizeIs tot (unitBag (v, 20 + tot - max)+                      `unionBags` tot_disc) tot_scrut+                          -- If the variable is known, we produce a+                          -- discount that will take us back to 'max',+                          -- the size of the largest alternative The+                          -- 1+ is a little discount for reduced+                          -- allocation in the caller+                          --+                          -- Notice though, that we return tot_disc,+                          -- the total discount from all branches.  I+                          -- think that's right.++            alts_size tot_size _ = tot_size+          in+          alts_size (foldr1 addAltSize alt_sizes)  -- alts is non-empty+                    (foldr1 maxSize    alt_sizes)+                -- Good to inline if an arg is scrutinised, because+                -- that may eliminate allocation in the caller+                -- And it eliminates the case itself++        | otherwise -> size_up e  `addSizeNSD`+                                foldr (addAltSize . size_up_alt) case_size alts++        where+          is_top_arg (Var v) | v `elem` top_args = Just v+          is_top_arg (Cast e _) = is_top_arg e+          is_top_arg _ = Nothing++      where+          case_size+           | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)+           | otherwise = sizeZero+                -- Normally we don't charge for the case itself, but+                -- we charge one per alternative (see size_up_alt,+                -- below) to account for the cost of the info table+                -- and comparisons.+                --+                -- However, in certain cases (see is_inline_scrut+                -- below), no code is generated for the case unless+                -- there are multiple alts.  In these cases we+                -- subtract one, making the first alt free.+                -- e.g. case x# +# y# of _ -> ...   should cost 1+                --      case touch# x# of _ -> ...  should cost 0+                -- (see #4978)+                --+                -- I would like to not have the "lengthAtMost alts 1"+                -- condition above, but without that some programs got worse+                -- (spectral/hartel/event and spectral/para).  I don't fully+                -- understand why. (SDM 24/5/11)++                -- unboxed variables, inline primops and unsafe foreign calls+                -- are all "inline" things:+          is_inline_scrut (Var v) =+            isUnliftedType (idType v)+              -- isUnliftedType is OK here: scrutinees have a fixed RuntimeRep (search for FRRCase)+          is_inline_scrut scrut+              | (Var f, _) <- collectArgs scrut+                = case idDetails f of+                    FCallId fc    -> not (isSafeForeignCall fc)+                    PrimOpId op _ -> not (primOpOutOfLine op)+                    _other        -> False+              | otherwise+                = False++    size_up_rhs (bndr, rhs)+      | JoinPoint join_arity <- idJoinPointHood bndr+        -- Skip arguments to join point+      , (_bndrs, body) <- collectNBinders join_arity rhs+      = size_up body+      | otherwise+      = size_up rhs++    ------------+    -- size_up_app is used when there's ONE OR MORE value args+    size_up_app (App fun arg) args voids+        | isTyCoArg arg                  = size_up_app fun args voids+        | isZeroBitExpr arg              = size_up_app fun (arg:args) (voids + 1)+        | otherwise                      = size_up arg  `addSizeNSD`+                                           size_up_app fun (arg:args) voids+    size_up_app (Var fun)     args voids = size_up_call fun args voids+    size_up_app (Tick _ expr) args voids = size_up_app expr args voids+    size_up_app (Cast expr _) args voids = size_up_app expr args voids+    size_up_app other         args voids = size_up other `addSizeN`+                                           callSize (length args) voids+       -- if the lhs is not an App or a Var, or an invisible thing like a+       -- Tick or Cast, then we should charge for a complete call plus the+       -- size of the lhs itself.++    ------------+    size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize+    size_up_call fun val_args voids+       = case idDetails fun of+           FCallId _                     -> sizeN (callSize (length val_args) voids)+           DataConWorkId dc              -> conSize    dc (length val_args)+           PrimOpId op _                 -> primOpSize op (length val_args)+           ClassOpId cls _               -> classOpSize opts cls top_args val_args+           _ | fun `hasKey` buildIdKey   -> buildSize+             | fun `hasKey` augmentIdKey -> augmentSize+             | otherwise                 -> funSize opts top_args fun (length val_args) voids++    ------------+    size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10+        -- Don't charge for args, so that wrappers look cheap+        -- (See comments about wrappers with Case)+        --+        -- IMPORTANT: *do* charge 1 for the alternative, else we+        -- find that giant case nests are treated as practically free+        -- A good example is Foreign.C.Error.errnoToIOError++    ------------+    -- Cost to allocate binding with given binder+    size_up_alloc bndr+      |  isTyVar bndr                    -- Doesn't exist at runtime+      || isJoinId bndr                   -- Not allocated at all+      || not (isBoxedType (idType bndr)) -- Doesn't live in heap+      = 0+      | otherwise+      = 10++    ------------+        -- These addSize things have to be here because+        -- I don't want to give them bOMB_OUT_SIZE as an argument+    addSizeN TooBig          _  = TooBig+    addSizeN (SizeIs n xs d) m  = mkSizeIs bOMB_OUT_SIZE (n + m) xs d++        -- addAltSize is used to add the sizes of case alternatives+    addAltSize TooBig            _      = TooBig+    addAltSize _                 TooBig = TooBig+    addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2)+        = mkSizeIs bOMB_OUT_SIZE (n1 + n2)+                                 (xs `unionBags` ys)+                                 (d1 + d2) -- Note [addAltSize result discounts]++        -- This variant ignores the result discount from its LEFT argument+        -- It's used when the second argument isn't part of the result+    addSizeNSD TooBig            _      = TooBig+    addSizeNSD _                 TooBig = TooBig+    addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2)+        = mkSizeIs bOMB_OUT_SIZE (n1 + n2)+                                 (xs `unionBags` ys)+                                 d2  -- Ignore d1++    -- don't count expressions such as State# RealWorld+    -- exclude join points, because they can be rep-polymorphic+    -- and typePrimRep will crash+    isZeroBitId id = not (isJoinId id) && isZeroBitTy (idType id)++    isZeroBitExpr (Var id)   = isZeroBitId id+    isZeroBitExpr (Tick _ e) = isZeroBitExpr e+    isZeroBitExpr _          = False++-- | Finds a nominal size of a string literal.+litSize :: Literal -> Int+-- Used by GHC.Core.Unfold.sizeExpr+litSize (LitNumber LitNumBigNat _)  = 100+litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4)+        -- If size could be 0 then @f "x"@ might be too small+        -- [Sept03: make literal strings a bit bigger to avoid fruitless+        --  duplication of little strings]+litSize _other = 0    -- Must match size of nullary constructors+                      -- Key point: if  x |-> 4, then x must inline unconditionally+                      --            (eg via case binding)++classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize+-- See Note [Conlike is interesting]+classOpSize opts cls top_args args+  | isUnaryClass cls+  = sizeZero   -- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon+  | otherwise+  = case args of+       []                -> sizeZero+       (arg1:other_args) -> SizeIs (size other_args) (arg_discount arg1) 0+  where+    size other_args = 20 + (10 * length other_args)++    -- If the class op is scrutinising a lambda bound dictionary then+    -- give it a discount, to encourage the inlining of this function+    -- The actual discount is rather arbitrarily chosen+    arg_discount (Var dict) | dict `elem` top_args+                   = unitBag (dict, unfoldingDictDiscount opts)+    arg_discount _ = emptyBag++-- | The size of a function call+callSize+ :: Int  -- ^ number of value args+ -> Int  -- ^ number of value args that are void+ -> Int+callSize n_val_args voids = 10 * (1 + n_val_args - voids)+        -- The 1+ is for the function itself+        -- Add 1 for each non-trivial arg;+        -- the allocation cost, as in let(rec)++-- | The size of a jump to a join point+jumpSize+ :: Int  -- ^ number of value args+ -> Int  -- ^ number of value args that are void+ -> Int+jumpSize _n_val_args _voids = 0   -- Jumps are small, and we don't want penalise them++  -- Old version:+  -- 2 * (1 + n_val_args - voids)+  -- A jump is 20% the size of a function call. Making jumps free reopens+  -- bug #6048, but making them any more expensive loses a 21% improvement in+  -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a+  -- better solution?++funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize+-- Size for function calls where the function is not a constructor or primops+-- Note [Function applications]+funSize opts top_args fun n_val_args voids+  | otherwise = SizeIs size arg_discount res_discount+  where+    some_val_args = n_val_args > 0+    is_join = isJoinId fun++    size | is_join              = jumpSize n_val_args voids+         | not some_val_args    = 0+         | otherwise            = callSize n_val_args voids++        --                  DISCOUNTS+        --  See Note [Function and non-function discounts]+    arg_discount | some_val_args && fun `elem` top_args+                 = unitBag (fun, unfoldingFunAppDiscount opts)+                 | otherwise = emptyBag+        -- If the function is an argument and is applied+        -- to some values, give it an arg-discount++    res_discount | idArity fun > n_val_args = unfoldingFunAppDiscount opts+                 | otherwise                = 0+        -- If the function is partially applied, show a result discount+-- XXX maybe behave like ConSize for eval'd variable++conSize :: DataCon -> Int -> ExprSize+conSize dc n_val_args+  | n_val_args == 0 = SizeIs 0 emptyBag 10    -- Like variables++-- See Note [Unboxed tuple size and result discount]+  | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10++  | isUnaryClassDataCon dc = sizeZero++-- See Note [Constructor size and result discount]+  | otherwise = SizeIs 10 emptyBag 10++{- Note [Constructor size and result discount]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Treat a constructors application as size 10, regardless of how many+arguments it has; we are keen to expose them (and we charge separately+for their args).  We can't treat them as size zero, else we find that+(Just x) has size 0, which is the same as a lone variable; and hence+'v' will always be replaced by (Just x), where v is bound to Just x.++The "result discount" is applied if the result of the call is+scrutinised (say by a case).  For a constructor application that will+mean the constructor application will disappear, so we don't need to+charge it to the function.  So the discount should at least match the+cost of the constructor application, namely 10.++Historical note 1: Until Jun 2020 we gave it a "bit of extra+incentive" via a discount of 10*(1 + n_val_args), but that was FAR too+much (#18282).  In particular, consider a huge case tree like++   let r = case y1 of+          Nothing -> B1 a b c+          Just v1 -> case y2 of+                      Nothing -> B1 c b a+                      Just v2 -> ...++If conSize gives a cost of 10 (regardless of n_val_args) and a+discount of 10, that'll make each alternative RHS cost zero.  We+charge 10 for each case alternative (see size_up_alt).  If we give a+bigger discount (say 20) in conSize, we'll make the case expression+cost *nothing*, and that can make a huge case tree cost nothing. This+leads to massive, sometimes exponential inlinings (#18282).  In short,+don't give a discount that give a negative size to a sub-expression!++Historical note 2: Much longer ago, Simon M tried a MUCH bigger+discount: (10 * (10 + n_val_args)), and said it was an "unambiguous+win", but its terribly dangerous because a function with many many+case branches, each finishing with a constructor, can have an+arbitrarily large discount.  This led to terrible code bloat: see #6099.++Note [Unboxed tuple size and result discount]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+However, unboxed tuples count as size zero. I found occasions where we had+        f x y z = case op# x y z of { s -> (# s, () #) }+and f wasn't getting inlined.++I tried giving unboxed tuples a *result discount* of zero (see the+commented-out line).  Why?  When returned as a result they do not+allocate, so maybe we don't want to charge so much for them. If you+have a non-zero discount here, we find that workers often get inlined+back into wrappers, because it look like+    f x = case $wf x of (# a,b #) -> (a,b)+and we are keener because of the case.  However while this change+shrank binary sizes by 0.5% it also made spectral/boyer allocate 5%+more. All other changes were very small. So it's not a big deal but I+didn't adopt the idea.++When fixing #18282 (see Note [Constructor size and result discount])+I changed the result discount to be just 10, not 10*(1+n_val_args).++Note [Function and non-function discounts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want a discount if the function is applied. A good example is+monadic combinators with continuation arguments, where inlining is+quite important.++But we don't want a big discount when a function is called many times+(see the detailed comments with #6048) because if the function is+big it won't be inlined at its many call sites and no benefit results.+Indeed, we can get exponentially big inlinings this way; that is what+#6048 is about.++On the other hand, for data-valued arguments, if there are lots of+case expressions in the body, each one will get smaller if we apply+the function to a constructor application, so we *want* a big discount+if the argument is scrutinised by many case expressions.++Conclusion:+  - For functions, take the max of the discounts+  - For data values, take the sum of the discounts+++Note [Literal integer size]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Literal integers *can* be big (mkInteger [...coefficients...]), but+need not be (IS n).  We just use an arbitrary big-ish constant here+so that, in particular, we don't inline top-level defns like+   n = IS 5+There's no point in doing so -- any optimisations will see the IS+through n's unfolding.  Nor will a big size inhibit unfoldings functions+that mention a literal Integer, because the float-out pass will float+all those constants to top level.+-}++primOpSize :: PrimOp -> Int -> ExprSize+primOpSize op n_val_args+ = if primOpOutOfLine op+      then sizeN (op_size + n_val_args)+      else sizeN op_size+ where+   op_size = primOpCodeSize op+++buildSize :: ExprSize+buildSize = SizeIs 0 emptyBag 40+        -- We really want to inline applications of build+        -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later)+        -- Indeed, we should add a result_discount because build is+        -- very like a constructor.  We don't bother to check that the+        -- build is saturated (it usually is).  The "-2" discounts for the \c n,+        -- The "4" is rather arbitrary.++augmentSize :: ExprSize+augmentSize = SizeIs 0 emptyBag 40+        -- Ditto (augment t (\cn -> e) ys) should cost only the cost of+        -- e plus ys. The -2 accounts for the \cn++-- When we return a lambda, give a discount if it's used (applied)+lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize+lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts)+lamScrutDiscount _      TooBig          = TooBig++{-+Note [addAltSize result discounts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding the size of alternatives, we *add* the result discounts+too, rather than take the *maximum*.  For a multi-branch case, this+gives a discount for each branch that returns a constructor, making us+keener to inline.  I did try using 'max' instead, but it makes nofib+'rewrite' and 'puzzle' allocate significantly more, and didn't make+binary sizes shrink significantly either.++Note [Discounts and thresholds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Constants for discounts and thresholds are defined in 'UnfoldingOpts'. They are:++unfoldingCreationThreshold+     At a definition site, if the unfolding is bigger than this, we+     may discard it altogether++unfoldingUseThreshold+     At a call site, if the unfolding, less discounts, is smaller than+     this, then it's small enough inline++unfoldingDictDiscount+     The discount for each occurrence of a dictionary argument+     as an argument of a class method.  Should be pretty small+     else big functions may get inlined++unfoldingFunAppDiscount+     Discount for a function argument that is applied.  Quite+     large, because if we inline we avoid the higher-order call.++unfoldingVeryAggressive+     If True, the compiler ignores all the thresholds and inlines very+     aggressively. It still adheres to arity, simplifier phase control and+     loop breakers.+++Historical Note: Before April 2020 we had another factor,+ufKeenessFactor, which would scale the discounts before they were subtracted+from the size. This was justified with the following comment:++  -- We multiply the raw discounts (args_discount and result_discount)+  -- ty opt_UnfoldingKeenessFactor because the former have to do with+  --  *size* whereas the discounts imply that there's some extra+  --  *efficiency* to be gained (e.g. beta reductions, case reductions)+  -- by inlining.++However, this is highly suspect since it means that we subtract a *scaled* size+from an absolute size, resulting in crazy (e.g. negative) scores in some cases+(#15304). We consequently killed off ufKeenessFactor and bumped up the+ufUseThreshold to compensate.+++Note [Function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a function application (f a b)++  - If 'f' is an argument to the function being analysed,+    and there's at least one value arg, record a FunAppDiscount for f++  - If the application if a PAP (arity > 2 in this example)+    record a *result* discount (because inlining+    with "extra" args in the call may mean that we now+    get a saturated application)++Code for manipulating sizes+-}++-- | The size of a candidate expression for unfolding+data ExprSize+    = TooBig+    | SizeIs { _es_size_is  :: {-# UNPACK #-} !Int -- ^ Size found+             , _es_args     :: !(Bag (Id,Int))+               -- ^ Arguments cased herein, and discount for each such+             , _es_discount :: {-# UNPACK #-} !Int+               -- ^ Size to subtract if result is scrutinised by a case+               -- expression+             }++instance Outputable ExprSize where+  ppr TooBig         = text "TooBig"+  ppr (SizeIs a _ c) = brackets (int a <+> int c)++-- subtract the discount before deciding whether to bale out. eg. we+-- want to inline a large constructor application into a selector:+--      tup = (a_1, ..., a_99)+--      x = case tup of ...+--+mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize+mkSizeIs max n xs d | (n - d) > max = TooBig+                    | otherwise     = SizeIs n xs d++maxSize :: ExprSize -> ExprSize -> ExprSize+maxSize TooBig         _                                  = TooBig+maxSize _              TooBig                             = TooBig+maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2   = s1+                                              | otherwise = s2++sizeZero :: ExprSize+sizeN :: Int -> ExprSize++sizeZero = SizeIs 0 emptyBag 0+sizeN n  = SizeIs n emptyBag 0
+ GHC/Core/Unfold.hs-boot view
@@ -0,0 +1,15 @@+module GHC.Core.Unfold where++import GHC.Prelude++data UnfoldingOpts++defaultUnfoldingOpts :: UnfoldingOpts++updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateUseThreshold      :: Int -> UnfoldingOpts -> UnfoldingOpts+updateFunAppDiscount    :: Int -> UnfoldingOpts -> UnfoldingOpts+updateDictDiscount      :: Int -> UnfoldingOpts -> UnfoldingOpts+updateVeryAggressive    :: Bool -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold     :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling       :: Int -> UnfoldingOpts -> UnfoldingOpts
+ GHC/Core/Unfold/Make.hs view
@@ -0,0 +1,508 @@+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Unfolding creation+module GHC.Core.Unfold.Make+   ( noUnfolding+   , mkUnfolding+   , mkCoreUnfolding+   , mkFinalUnfolding+   , mkFinalUnfolding'+   , mkSimpleUnfolding+   , mkWorkerUnfolding+   , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity+   , mkInlinableUnfolding+   , mkWrapperUnfolding+   , mkCompulsoryUnfolding, mkCompulsoryUnfolding'+   , mkDFunUnfolding+   , mkDataConUnfolding+   , specUnfolding+   , certainlyWillInline+   )+where++import GHC.Prelude+import GHC.Core+import GHC.Core.Unfold+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.Opt.Arity   ( manifestArity )+import GHC.Core.DataCon+import GHC.Core.Utils+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Demand ( DmdSig, isDeadEndSig )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import Data.Maybe ( fromMaybe )++-- the very simple optimiser is used to optimise unfoldings+import {-# SOURCE #-} GHC.Core.SimpleOpt++++mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Unfolding+-- "Final" in the sense that this is a GlobalId that will not be further+-- simplified; so the unfolding should be occurrence-analysed+mkFinalUnfolding opts src strict_sig expr = mkFinalUnfolding' opts src strict_sig expr Nothing++-- See Note [Tying the 'CoreUnfolding' knot] for why interfaces need+-- to pass a precomputed 'UnfoldingCache'+mkFinalUnfolding' :: UnfoldingOpts -> UnfoldingSource -> DmdSig -> CoreExpr -> Maybe UnfoldingCache -> Unfolding+-- "Final" in the sense that this is a GlobalId that will not be further+-- simplified; so the unfolding should be occurrence-analysed+mkFinalUnfolding' opts src strict_sig expr+  = mkUnfolding opts src+                True {- Top level -}+                (isDeadEndSig strict_sig)+                False {- Not a join point -}+                expr++-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first+mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding+mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr)++-- | Used for things that absolutely must be unfolded+mkCompulsoryUnfolding :: CoreExpr -> Unfolding+mkCompulsoryUnfolding expr+  = mkCoreUnfolding CompulsorySrc True+                    expr Nothing+                    (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter+                             , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })++-- Note [Top-level flag on inline rules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Slight hack: note that mk_inline_rules conservatively sets the+-- top-level flag to True.  It gets set more accurately by the simplifier+-- Simplify.simplUnfolding.++mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding+mkSimpleUnfolding !opts rhs+  = mkUnfolding opts VanillaSrc False False False rhs Nothing++mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding+mkDFunUnfolding bndrs con ops+  | isUnaryClassDataCon con+  = -- See (UCM5) in Note [Unary class magic] in GHC.Core.TyCon+    mkDataConUnfolding $+    mkLams bndrs  $+    mkApps (Var (dataConWrapId con)) ops+                -- This application will satisfy the Core invariants+                -- from Note [Representation polymorphism invariants] in GHC.Core,+                -- because typeclass method types are never unlifted.++  | otherwise+  = DFunUnfolding { df_bndrs = bndrs+                  , df_con = con+                  , df_args = map occurAnalyseExpr ops }+                  -- See Note [OccInfo in unfoldings and rules] in GHC.Core++mkDataConUnfolding :: CoreExpr -> Unfolding+-- Used for non-newtype data constructors with non-trivial wrappers+mkDataConUnfolding expr+  = mkCoreUnfolding StableSystemSrc True expr Nothing guide+    -- No need to simplify the expression+  where+    guide = UnfWhen { ug_arity     = manifestArity expr+                    , ug_unsat_ok  = unSaturatedOk+                    , ug_boring_ok = inlineBoringOk expr }+            -- inineBoringOk; sometimes wrappers are very simple, like+            --    \@a p q. K @a <coercion> p q+            -- and then we definitely want to inline it #25713++mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding+-- Make the unfolding for the wrapper in a worker/wrapper split+-- after demand/CPR analysis+mkWrapperUnfolding opts expr arity+  = mkCoreUnfolding StableSystemSrc True+                    (simpleOptExpr opts expr) Nothing+                    (UnfWhen { ug_arity     = arity+                             , ug_unsat_ok  = unSaturatedOk+                             , ug_boring_ok = boringCxtNotOk })++mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding+-- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap+mkWorkerUnfolding opts work_fn+                  (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                                 , uf_is_top = top_lvl })+  | isStableSource src+  = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance+  where+    new_tmpl = simpleOptExpr opts (work_fn tmpl)+    guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl++mkWorkerUnfolding _ _ _ = noUnfolding++-- | Make an INLINE unfolding that may be used unsaturated+-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its+-- manifest arity (the number of outer lambdas applications will+-- resolve before doing any work).+mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding+mkInlineUnfoldingNoArity opts src expr+  = mkCoreUnfolding src+                    True         -- Note [Top-level flag on inline rules]+                    expr' Nothing guide+  where+    expr' = simpleOptExpr opts expr+    guide = UnfWhen { ug_arity = manifestArity expr'+                    , ug_unsat_ok = unSaturatedOk+                    , ug_boring_ok = boring_ok }+    boring_ok = inlineBoringOk expr'++-- | Make an INLINE unfolding that will be used once the RHS has been saturated+-- to the given arity.+mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding+mkInlineUnfoldingWithArity opts src arity expr+  = mkCoreUnfolding src+                    True         -- Note [Top-level flag on inline rules]+                    expr' Nothing guide+  where+    expr' = simpleOptExpr opts expr+    guide = UnfWhen { ug_arity = arity+                    , ug_unsat_ok = needSaturated+                    , ug_boring_ok = boring_ok }+    -- See Note [INLINE pragmas and boring contexts] as to why we need to look+    -- at the arity here.+    boring_ok | arity == 0 = True+              | otherwise  = inlineBoringOk expr'++mkInlinableUnfolding :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding+mkInlinableUnfolding opts src expr+  = mkUnfolding (so_uf_opts opts) src False False False expr' Nothing+  where+    expr' = simpleOptExpr opts expr++specUnfolding :: SimpleOpts+              -> [Var] -> (CoreExpr -> CoreExpr)+              -> [CoreArg]   -- LHS arguments in the RULE+              -> Unfolding -> Unfolding+-- See Note [Specialising unfoldings]+-- specUnfolding spec_bndrs spec_args unf+--   = \spec_bndrs. unf spec_args+--+specUnfolding opts spec_bndrs spec_app rule_lhs_args+              df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })+  = assertPpr (rule_lhs_args `equalLength` old_bndrs)+              (ppr df $$ ppr rule_lhs_args) $+           -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise+    mkDFunUnfolding spec_bndrs con (map spec_arg args)+      -- For DFunUnfoldings we transform+      --       \obs. MkD <op1> ... <opn>+      -- to+      --       \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>+  where+    spec_arg arg = simpleOptExpr opts $+                   spec_app (mkLams old_bndrs arg)+                   -- The beta-redexes created by spec_app will be+                   -- simplified away by simplOptExpr+                   -- ToDo: this is VERY DELICATE for type args.  We make+                   --        (\@a @b x y. TYPE ty) ty1 ty2 d1 d2+                   -- and rely on it simplifying to ty[ty1/a, ty2/b]++specUnfolding opts spec_bndrs spec_app rule_lhs_args+              (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                             , uf_is_top = top_lvl+                             , uf_guidance = old_guidance })+ | isStableSource src  -- See Note [Specialising unfoldings]+ , UnfWhen { ug_arity = old_arity } <- old_guidance+ = mkCoreUnfolding src top_lvl new_tmpl Nothing+                   (old_guidance { ug_arity = old_arity - arity_decrease })+ where+   new_tmpl = simpleOptExpr opts $+              mkLams spec_bndrs  $+              spec_app tmpl  -- The beta-redexes created by spec_app+                             -- will be simplified away by simplOptExpr+   arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs+++specUnfolding _ _ _ _ _ = noUnfolding++{- Note [Specialising unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise a function for some given type-class arguments, we use+specUnfolding to specialise its unfolding.  Some important points:++* If the original function has a DFunUnfolding, the specialised one+  must do so too!  Otherwise we lose the magic rules that make it+  interact with ClassOps++* For a /stable/ CoreUnfolding, we specialise the unfolding, no matter+  how big, iff it has UnfWhen guidance.  This happens for INLINE+  functions, and for wrappers.  For these, it would 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.++* However, for a stable CoreUnfolding with guidance UnfoldIfGoodArgs,+  which arises from INLINABLE functions, we drop the unfolding.+  See #4874 for persuasive examples.  Suppose we have+    {-# INLINABLE f #-}+    f :: Ord a => [a] -> Int f xs = letrec f' = ...f'... in f'++  Then, when f is specialised and optimised we might get+    wgo :: [Int] -> Int#+    wgo = ...wgo...+    f_spec :: [Int] -> Int+    f_spec xs = case wgo xs of { r -> I# r }++  and we clearly want to inline f_spec at call sites.  But if we still+  have the big, un-optimised of f (albeit specialised) captured in the+  stable unfolding for f_spec, we won't get that optimisation.++  This happens with Control.Monad.liftM3, and can cause a lot more+  allocation as a result (nofib n-body shows this).++  Moreover, keeping the stable unfolding isn't much help, because+  the specialised function (probably) isn't overloaded any more.++  TL;DR: we simply drop the stable unfolding when specialising. It's not+  really a complete solution; ignoring specialisation for now, INLINABLE+  functions don't get properly strictness analysed, for example.+  Moreover, it means that the specialised function has an INLINEABLE+  pragma, but no stable unfolding. But it works well for examples+  involving specialisation, which is the dominant use of INLINABLE.++Note [Honour INLINE on 0-ary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   x = <expensive>+   {-# INLINE x #-}++   f y = ...x...++The semantics of an INLINE pragma is++  inline x at every call site, provided it is saturated;+  that is, applied to at least as many arguments as appear+  on the LHS of the Haskell source definition.++(This source-code-derived arity is stored in the `ug_arity` field of+the `UnfoldingGuidance`.)++In the example, x's ug_arity is 0, so we should inline it at every use+site.  It's rare to have such an INLINE pragma (usually INLINE is on+functions), but it's occasionally very important (#15578, #15519).+In #15519 we had something like+   x = case (g a b) of I# r -> T r+   {-# INLINE x #-}+   f y = ...(h x)....++where h is strict.  So we got+   f y = ...(case g a b of I# r -> h (T r))...++and that in turn allowed SpecConstr to ramp up performance.++How do we deliver on this?  By adjusting the ug_boring_ok+flag in mkInlineUnfoldingWithArity; see+Note [INLINE pragmas and boring contexts]++NB: there is a real risk that full laziness will float it right back+out again. Consider again+  x = factorial 200+  {-# INLINE x #-}+  f y = ...x...++After inlining we get+  f y = ...(factorial 200)...++but it's entirely possible that full laziness will do+  lvl23 = factorial 200+  f y = ...lvl23...++That's a problem for another day.++Note [INLINE pragmas and boring contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An INLINE pragma uses mkInlineUnfoldingWithArity to build the+unfolding.  That sets the ug_boring_ok flag to False if the function+is not tiny (inlineBoringOK), so that even INLINE functions are not+inlined in an utterly boring context.  E.g.+     \x y. Just (f y x)+Nothing is gained by inlining f here, even if it has an INLINE+pragma.++But for 0-ary bindings, we want to inline regardless; see+Note [Honour INLINE on 0-ary bindings].++I'm a bit worried that it's possible for the same kind of problem+to arise for non-0-ary functions too, but let's wait and see.+-}++mkUnfolding :: UnfoldingOpts+            -> UnfoldingSource+            -> Bool       -- Is top-level+            -> Bool       -- Definitely a bottoming binding+                          -- (only relevant for top-level bindings)+            -> Bool       -- True <=> join point+            -> CoreExpr+            -> Maybe UnfoldingCache+            -> Unfolding+-- Calculates unfolding guidance+-- Occurrence-analyses the expression before capturing it+mkUnfolding opts src top_lvl is_bottoming is_join expr cache+  = mkCoreUnfolding src top_lvl expr cache guidance+  where+    is_top_bottoming = top_lvl && is_bottoming+    guidance         = calcUnfoldingGuidance opts is_top_bottoming is_join expr+        -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!+        -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]++mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr+                -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding+-- Occurrence-analyses the expression before capturing it+mkCoreUnfolding src top_lvl expr precomputed_cache guidance+  = CoreUnfolding { uf_tmpl = cache `seq`+                              occurAnalyseExpr expr+      -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core+      -- See #20905 for what a discussion of this 'seq'.+      -- We are careful to make sure we only+      -- have one copy of an unfolding around at once.+      -- Note [Thoughtful forcing in mkCoreUnfolding]++                  , uf_src          = src+                  , uf_is_top       = top_lvl+                  , uf_cache        = cache+                  , uf_guidance     = guidance }+  where+    is_value      = exprIsHNF expr+    is_conlike    = exprIsConLike expr+    is_work_free  = exprIsWorkFree expr+    is_expandable = exprIsExpandable expr++    recomputed_cache = UnfoldingCache { uf_is_value = is_value+                                      , uf_is_conlike = is_conlike+                                      , uf_is_work_free = is_work_free+                                      , uf_expandable = is_expandable }++    cache = fromMaybe recomputed_cache precomputed_cache++----------------+certainlyWillInline :: UnfoldingOpts -> IdInfo -> CoreExpr -> Maybe Unfolding+-- ^ Sees if the unfolding is pretty certain to inline.+-- If so, return a *stable* unfolding for it, that will always inline.+-- The CoreExpr is the WW'd and simplified RHS. In contrast, the unfolding+-- template might not have been WW'd yet.+certainlyWillInline opts fn_info rhs'+  = case fn_unf of+      CoreUnfolding { uf_guidance = guidance, uf_src = src }+        | noinline -> Nothing       -- See Note [Worker/wrapper for NOINLINE functions]+        | otherwise+        -> case guidance of+             UnfNever   -> Nothing+             UnfWhen {} -> Just (fn_unf { uf_src = src', uf_tmpl = tmpl' })+                             -- INLINE functions have UnfWhen+             UnfIfGoodArgs { ug_size = size, ug_args = args }+                        -> do_cunf size args src' tmpl'+        where+          src' | isCompulsorySource src = src  -- Do not change InlineCompulsory!+               | otherwise              = StableSystemSrc++          tmpl' | isStableSource src = uf_tmpl fn_unf+                | otherwise          = occurAnalyseExpr rhs'+                -- Do not overwrite stable unfoldings!++      DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense+                                       -- to do so, and even if it is currently a+                                       -- loop breaker, it may not be later++      _other_unf       -> Nothing++  where+    noinline = isNoInlinePragma (inlinePragInfo fn_info)+    fn_unf   = unfoldingInfo fn_info -- NB: loop-breakers never inline++        -- The UnfIfGoodArgs case seems important.  If we w/w small functions+        -- binary sizes go up by 10%!  (This is with SplitObjs.)+        -- I'm not totally sure why.+        -- INLINABLE functions come via this path+        --    See Note [certainlyWillInline: INLINABLE]+    do_cunf size args src' tmpl'+      | arityInfo fn_info > 0  -- See Note [certainlyWillInline: be careful of thunks]+      , not (isDeadEndSig (dmdSigInfo fn_info))+              -- Do not unconditionally inline a bottoming functions even if+              -- it seems smallish. We've carefully lifted it out to top level,+              -- so we don't want to re-inline it.+      , let unf_arity = length args+      , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts+      = Just (fn_unf { uf_src      = src'+                     , uf_tmpl     = tmpl'+                     , uf_guidance = UnfWhen { ug_arity     = unf_arity+                                             , ug_unsat_ok  = unSaturatedOk+                                             , ug_boring_ok = inlineBoringOk tmpl' } })+             -- Note the "unsaturatedOk". A function like  f = \ab. a+             -- will certainly inline, even if partially applied (f e), so we'd+             -- better make sure that the transformed inlining has the same property+      | otherwise+      = Nothing++{- Note [certainlyWillInline: be careful of thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't claim that thunks will certainly inline, because that risks work+duplication.  Even if the work duplication is not great (eg is_cheap+holds), it can make a big difference in an inner loop In #5623 we+found that the WorkWrap phase thought that+       y = case x of F# v -> F# (v +# v)+was certainlyWillInline, so the addition got duplicated.++Note that we check arityInfo instead of the arity of the unfolding to detect+this case. This is so that we don't accidentally fail to inline small partial+applications, like `f = g 42` (where `g` recurses into `f`) where g has arity 2+(say). Here there is no risk of work duplication, and the RHS is tiny, so+certainlyWillInline should return True. But `unf_arity` is zero! However f's+arity, gotten from `arityInfo fn_info`, is 1.++Failing to say that `f` will inline forces W/W to generate a potentially huge+worker for f that will immediately cancel with `g`'s wrapper anyway, causing+unnecessary churn in the Simplifier while arriving at the same result.++Note [certainlyWillInline: INLINABLE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+certainlyWillInline /must/ return Nothing for a large INLINABLE thing,+even though we have a stable inlining, so that strictness w/w takes+place.  It makes a big difference to efficiency, and the w/w pass knows+how to transfer the INLINABLE info to the worker; see WorkWrap+Note [Worker/wrapper for INLINABLE functions]++Note [Thoughtful forcing in mkCoreUnfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Core expressions retained in unfoldings is one of biggest uses of memory when compiling+a program. Therefore we have to be careful about retaining copies of old or redundant+templates (see !6202 for a particularly bad case).++With that in mind we want to maintain the invariant that each unfolding only references+a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding.++* The template of the unfolding is the result of performing occurrence analysis+  (Note [OccInfo in unfoldings and rules] in GHC.Core)+* Predicates are applied to the unanalysed expression++Therefore if we are not thoughtful about forcing you can end up in a situation where the+template is forced but not all the predicates are forced so the unfolding will retain+both the old and analysed expressions.++I investigated this using ghc-debug and it was clear this situation did often arise:++```+(["ghc:GHC.Core:Lam","ghc-prim:GHC.Types:True","THUNK_1_0","THUNK_1_0","THUNK_1_0"],Count 4307)+```++Here the predicates are unforced but the template is forced.++Therefore we basically had two options in order to fix this:++1. Perform the predicates on the analysed expression.+2. Force the predicates to remove retainer to the old expression if we force the template.++Option 1 is bad because occurrence analysis is expensive and destroys any sharing of the unfolding+with the actual program. (Testing this approach showed peak 25G memory usage)++Therefore we got for Option 2 which performs a little more work but compensates by+reducing memory pressure.++The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when+compiling a very large module (peak 3 million terms). For more discussion see #20905.+-}
+ GHC/Core/Unify.hs view
@@ -0,0 +1,2541 @@+-- (c) The University of Glasgow 2006++{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-}++{-# LANGUAGE DeriveFunctor #-}++module GHC.Core.Unify (+        tcMatchTy, tcMatchTyKi,+        tcMatchTys, tcMatchTyKis,+        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,+        tcMatchTyX_BM, ruleMatchTyKiX,++        -- Side-effect free unification+        tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger,+        tcUnifyTysFG, tcUnifyTyForInjectivity,+        BindTvFun, BindFamFun, BindFlag(..),+        matchBindTv, alwaysBindTv, alwaysBindFam, dontCareBindFam,+        UnifyResult, UnifyResultM(..), MaybeApartReason(..),+        typesCantMatch, typesAreApart,++        -- Matching a type against a lifted type (coercion)+        liftCoMatch+   ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )+import GHC.Core.Type     hiding ( getTvSubstEnv )+import GHC.Core.Coercion hiding ( getCvSubstEnv )+import GHC.Core.Predicate( scopedSort )+import GHC.Core.TyCon+import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe )+import GHC.Core.TyCon.Env+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs )+import GHC.Core.TyCo.FVs     ( tyCoVarsOfCoList, tyCoFVsOfTypes )+import GHC.Core.TyCo.Subst   ( mkTvSubst )+import GHC.Core.Map.Type+import GHC.Core.Multiplicity++import GHC.Utils.FV( FV, fvVarList )+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Basic( SwapFlag(..) )+import GHC.Types.Unique.FM+import GHC.Exts( oneShot )+import GHC.Utils.Panic++import GHC.Data.Pair+import GHC.Data.TrieMap+import GHC.Data.Maybe( orElse )++import Control.Monad+import qualified Data.Semigroup as S+import GHC.Builtin.Types.Prim (fUNTyCon)++{- Note [The Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~+This module contains the (pure) unifier two types.  It is subtle in a number+of ways.  Here we summarise, but see Note [Specification of unification].++(CU1) It creates a substition only for "bindable" or "template" type variables.+  These are identified by a `um_bind_tv_fun` function passed down in the `UMEnv`+  environment.++(CU2) We want to match in the presence of foralls;+        e.g     (forall a. t1) ~ (forall b. t2)+   That is what the `um_rn_env :: RnEnv2` field of `UMEnv` is for; it does the+   alpha-renaming that makes it as if `a` and `b` were the same variable.+   Initialising the `RnEnv2`, so that it can generate a fresh binder when+   necessary, entails knowing the free variables of both types.++   Of course, we must be careful not to bind a template type variable to a+   locally bound variable.  E.g.+        (forall a. x) ~ (forall b. b)+   where `x` is the template type variable.  Then we do not want to+   bind `x` to a/b!  See `mentionsForAllBoundTyVarsL/R`.++(CU3) We want to take special care for type families.+  See the big Note [Apartness and type families]++(CU4) Rather than returning just "unifiable" or "not-unifiable" we do "fine-grained"+  unification (hence "fg" or "FG" in this module) returning three possiblities,+  captured in `UnifyResult`:+    - Unifiable subst : certainly unifiable with this type substitution+    - SurelyApart     : cannot be unifiable, regardless of how type familes reduce+    - MaybeApart      : neither of the above+  See Note [Unification result].++  Four reasons for MaybeApart (see `MaybeApartReason`).  The first two are the+  big ones!+    * MARTypeFamily:+         Family reduction might make the two types equal+             Maybe (F Int) ~ Maybe Bool+         See Note [Apartness and type families]+    * MARInfinite (occurs check):+         See Note [Infinitary substitutions]+    * MARTypeVsConstraint:+         See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+    * MARCast (obscure):+         See (KCU2) in Note [Kind coercions in Unify]++(CU5) We need to take care with kinds.  See Note [tcMatchTy vs tcMatchTyKi]++(CU6) The "unifier" can also do /matching/, governed by `um_unif :: AmIUnifying`.+   When matching, the LHS and RHS namespaces are unrelated. In particular, the+   bindable type variable can occur (unrelatedly) in the RHS.  E.g.+        match  (a,Maybe a) ~  ([a], Maybe [a])+   We get the substitution [a :-> [a]], without confusing the+   LHS `a` with the RHS `a`.  The substitition is "one-shot", and should not be+   iterated.++Note [Infinitary substitutions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" --+no substitution to finite types makes these match. This is the famous+"occurs check".++But, a substitution to *infinite* types can unify these two types:+  [x |-> [[...]]], y |-> [[[...]]] ].++Why do we care? Consider these two type family instances:++  type instance F x x   = Int+  type instance F [y] y = Bool++If we also have++  type instance Looper = [Looper]++then the instances potentially overlap -- they are not "apart". So we must+distinguish failure-to-unify from definitely-apart. The solution is to use+unification over infinite terms. This is possible (see [1] for lots of gory+details), but a full algorithm is a little more powerful than we need. Instead,+we make a conservative approximation and just omit the occurs check.++  [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf++tcUnifyTys considers an occurs-check problem as the same as general unification+failure.++See also #8162.++It's worth noting that unification in the presence of infinite types is not+complete. This means that, sometimes, a closed type family does not reduce+when it should. See test case indexed-types/should_fail/Overlap15 for an+example.++Note [tcMatchTy vs tcMatchTyKi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module offers two variants of matching: with kinds and without.+The TyKi variant takes two types, of potentially different kinds,+and matches them. Along the way, it necessarily also matches their+kinds. The Ty variant instead assumes that the kinds are already+eqType and so skips matching up the kinds.++How do you choose between them?++1. If you know that the kinds of the two types are eqType, use+   the Ty variant. It is more efficient, as it does less work.++2. If the kinds of variables in the template type might mention type families,+   use the Ty variant (and do other work to make sure the kinds+   work out). These pure unification functions do a straightforward+   syntactic unification and do no complex reasoning about type+   families. Note that the types of the variables in instances can indeed+   mention type families, so instance lookup must use the Ty variant.++   (Nothing goes terribly wrong -- no panics -- if there might be type+   families in kinds in the TyKi variant. You just might get match+   failure even though a reducing a type family would lead to success.)++3. Otherwise, if you're sure that the variable kinds do not mention+   type families and you're not already sure that the kind of the template+   equals the kind of the target, then use the TyKi version.++Note [Unification result]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See `UnifyResult` and `UnifyResultM`.  When unifying t1 ~ t2, we return+* Unifiable s, if s is a substitution such that s(t1) is syntactically the+  same as s(t2), modulo type-synonym expansion.+* SurelyApart, if there is no substitution s such that s(t1) = s(t2),+  where "=" includes type-family reductions.+* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.++Examples+* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify++* [(a,Int)] ~ [(Bool,b)]:  Unifiable++* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool+                    (the unifier does not try this)++* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart+    either; consider+       a := Loop+       where  type family Loop where Loop = Maybe Loop++Wrinkle (UR1): see `combineMAR`+   There is the possibility that two types are MaybeApart for *both* reasons:++   * (a, F Int) ~ (Maybe a, Bool)++   What reason should we use? The *only* consumer of the reason is described+   in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal+   there is identify which instances might match a target later (but don't+   match now) -- except that we want to ignore the possibility of infinitary+   substitutions. So let's examine a concrete scenario:++     class C a b c+     instance C a (Maybe a) Bool+     -- other instances, including one that will actually match+     [W] C b b (F Int)++   Do we want the instance as a future possibility? No. The only way that+   instance can match is in the presence of an infinite type (infinitely nested+   Maybes). We thus say that `MARInfinite` takes precedence, so that InstEnv treats+   this case as an infinitary substitution case; the fact that a type family is+   involved is only incidental. We thus define `combineMAR` to prefer+   `MARInfinite`.++Note [Apartness and type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't+match immediately while the second equation does. But, before reducing, we must+make sure that the target can never become (F Int Bool). Well, no matter what G+Float becomes, it certainly won't become *both* Int and Bool, so indeed we're+safe reducing (F (G Float) (G Float)) to Double.++So we must say that the argument list+     (G Float) (G Float)   is SurelyApart from   Int Bool++This is necessary not only to get more reductions (which we might be willing to+give up on), but for /substitutivity/. If we have (F x x), we can see that (F x x)+can reduce to Double. So, it had better be the case that (F blah blah) can+reduce to Double, no matter what (blah) is!++To achieve this, `go` in `uVarOrFam` does this;++* We maintain /two/ substitutions, not just one:+     * um_tv_env: the regular substitution, mapping TyVar :-> Type+     * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application+  In effect, these constitute one substitution mapping+     CanEqLHS :-> Types++* When we attempt to unify (G Float) ~ Int, we return MaybeApart..+  but we /also/ add a "family substitution" [G Float :-> Int],+  to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`.++* When we later encounter (G Float) ~ Bool, we apply the family substitution,+  very much as we apply the conventional [tyvar :-> type] substitution+  when we encounter a type variable.  See the `lookupFamEnv` in `go` in+  `uVarOrFam`.++  So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart.  Bingo.+++Wrinkles++(ATF0) Once we encounter a type-family application, we only ever return+             MaybeApart   or   SurelyApart+  but never `Unifiable`.  Accordingly, we only return a TyCoVar substitution+  from `tcUnifyTys` and friends; we don't return a type-family substitution as+  well.  (We could imagine doing so, though.)++(ATF1) Exactly the same mechanism is used in class-instance checking.+    If we have+        instance C (Maybe b)+        instance {-# OVERLAPPING #-} C (Maybe Bool)+        [W] C (Maybe (F a))+    we want to know that the second instance might match later, when we know more about `a`.+    The function `GHC.Core.InstEnv.instEnvMatchesAndUnifiers` uses `tcUnifyTysFG` to+    account for type families in the type being matched.++(ATF2) A very similar check is made in `GHC.Tc.Utils.Unify.mightEqualLater`, which+  again uses `tcUnifyTysFG` to account for the possibility of type families.  See+  Note [What might equal later?] in GHC.Tc.Utils.Unify, esp example (10).++(ATF3) What about foralls?   For example, supppose we are unifying+           (forall a. F a) -> (forall a. F a)+   against some other type. Those two (F a) types are unrelated, bound by+   different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah]++   So to keep things simple, the entire family-substitution machinery is used+   only if there are no enclosing foralls (see the `under_forall` check in+   `uSatFamApp`).  That's fine, because the apartness business is used only for+   reducing type-family applications, and class instances, and their arguments+   can't have foralls anyway.++   The bottom line is that we won't discover that+       (forall a. (a, F Int, F Int))+   is surely apart from+       (forall a. (a, Int, Bool))+   but that doesn't matter.  Fixing this would be possible, but would require+   quite a bit of head-scratching.++(ATF4) The family substitution only has /saturated/ family applications in+   its domain. Consider the following concrete example from #16995:++     type family Param :: Type -> Type   -- arity 0++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`.  So    (f Char) ~ (Param ())   must be SurelyApart.  Remember, since+   `Param` is a nullary type family, it is over-saturated in (Param ()).+   This unification will only be SurelyApart if we decompose the outer AppTy+   separately, to then give (() ~ Char).++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++(ATF5) Consider+          instance (Generic1 f, Ord (Rep1 f a))+                => Ord (Generically1 f a) where ...+              -- The "..." gives rise to [W] Ord (Generically1 f a)+   where Rep1 is a type family.++   We must use the instance decl (recursively) to simplify the [W] constraint;+   we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an+   alternative path.  So `noMatchableGivenDicts` must return False;+   so `mightMatchLater` must return False; so when um_bind_fam_fun returns+   `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`.  See+   `go` in `uVarOrFam`++   This looks a bit sketchy, because they aren't SurelyApart, but see+   Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring".++   If we are under a forall, we return `MaybeApart`; that seems more conservative,+   and class constraints are on tau-types so it doesn't matter.++(ATF6) When /matching/ can we ever have a type-family application on the LHS, in+   the template?  You might think not, because type-class-instance and+   type-family-instance heads can't include type families.  E.g.+            instance C (F a) where ...  -- Illegal++   But you'd be wrong: even when matching, we can see type families in the LHS template:+   * In `checkValidClass`, in `check_dm` we check that the default method has the+      right type, using matching, both ways.  And that type may have type-family+      applications in it. Examples in test CoOpt_Singletons and T26457.++   * In the specialiser: see the call to `tcMatchTy` in+     `GHC.Core.Opt.Specialise.beats_or_same`++   * With -fpolymorphic-specialisation, we might get a specialiation rule like+         RULE forall a (d :: Eq (Maybe (F a))) .+                 f @(Maybe (F a)) d = ...+     See #25965.++   * A user-written RULE could conceivably have a type-family application+     in the template.  It might not be a good rule, but I don't think we currently+     check for this.++    In all these cases we are only interested in finding a substitution /for+    type variables/ that makes the match work.  So we simply want to recurse into+    the arguments of the type family.  E.g.+       Template:   forall a.  Maybe (F a)+       Target:     Maybe (F Int)+    We want to succeed with substitution [a :-> Int].  See (ATF9).++    Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`,+    etc, we always end up in `tc_match_tys_x`.  There we invoke the unifier+    but we do not distinguish between `SurelyApart` and `MaybeApart`. So in+    these cases we can set `um_bind_fam_fun` to `neverBindFam`.++(ATF7) There is one other, very special case of matching where we /do/ want to+   bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call+   to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`.+   Consider+   of a match. Consider+      type family G6 a = r | r -> a+      type instance G6 [a]  = [G a]+      type instance G6 Bool = Int+   and suppose we have a Wanted constraint+      [W] G6 alpha ~ [Int]+   According to Section 5.2 of "Injective type families for Haskell", we /match/+   the RHS each of type instance with [Int].  So we try+        Template: [G a]    Target: [Int]+   and we want to succeed with MaybeApart, so that we can generate the improvement+   constraint+        [W] alpha ~ [beta]+   where beta is fresh.  We do this by binding [G a :-> Int]++(ATF8) The treatment of type families is governed by+         um_bind_fam_fun :: BindFamFun+  in UMEnv, where+         type BindFamFun = TyCon -> [Type] -> Type -> BindFlag+  There are some simple BindFamFun functions provided:+     alwaysBindFam    do the clever stuff above+     neverBindFam     treat type families as SurelyApart+     dontCareBindFam  type families shouldn't exist at all+  This function only affects the difference between the results MaybeApart and+  SurelyApart; it never does not affect whether or not we return Unifiable.++(ATF9) Decomposition.  Consider unifying+          F a  ~  F Int+  when `um_bind_fam_fun` says DontBindMe.  There is a unifying substitition [a :-> Int],+  and we want to find it, returning Unifiable. Why?+    - Remember, this is the Core unifier -- we are not doing type inference+    - When we have two equal types, like  F a ~ F a, it is ridiculous to say that they+      are MaybeApart.  Example: the two-way tcMatchTy in `checkValidClass` and #26457.++  (ATF9-1) But consider unifying+          F Int ~ F Bool+    Although Int and Bool are SurelyApart, we must return MaybeApart for the outer+    unification.  Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable+    alone, but weakens `SurelyApart` to `MaybeApart`.++  (ATF9-2) We want this decomposition to occur even under a forall (this was #26457).+    E.g.    (forall a. F Int) -> Int  ~   (forall a. F Int) ~ Int+++(ATF10) Injectivity.  Consider (AFT9) where F is known to be injective.  Then if we+  are unifying+          F Int ~ F Bool+  we /can/ say SurelyApart.  See the inj/noninj stuff in `go_fam_fam`.++(ATF11) Consider unifying+          [F Int, F Int, F Bool]  ~  [F Bool, Char, Double]+  We find (F Int ~ F Bool), so we can decompose.  But we /also/ want to remember+  the substitution [F Int :-> F Bool].  Then from (F Int ~ Char) we get the+  substitution [F Bool :-> Char].  And that flat-out contradicts (F Bool ~ Double)+  so we should get SurelyApart.++  Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the+  type-family substitution.++  (ATF11-1) All this cleverness only matters when unifying, not when matching++(ATF12) There is a horrid exception for the injectivity check. See (UR1) in+  in Note [Specification of unification].++(ATF13) We have to be careful about the occurs check.+  See Note [The occurs check in the Core unifier]++SIDE NOTE.  The paper "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+tries to achieve the same effect with a standard yes/no unifier, by "flattening"+the types (replacing each type-family application with a fresh type variable)+and then unifying.  But that does not work well. Consider (#25657)++    type MyEq :: k -> k -> Bool+    type family MyEq a b where+       MyEq a a = 'True+       MyEq _ _ = 'False++    type Var :: forall {k}. Tag -> k+    type family Var tag = a | a -> tag++Then, because Var is injective, we want+     MyEq (Var A) (Var B) --> False+     MyEq (Var A) (Var A) --> True++But if we flattten the types (Var A) and (Var B) we'll just get fresh type variables,+and all is lost.  But with the current algorithm we have that+    a a   ~    (Var A) (Var B)+is SurelyApart, so the first equation definitely doesn't match and we can try the+second, which does.  END OF SIDE NOTE.++Note [Shortcomings of the apartness test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Apartness and type families] is very clever.++But it still has shortcomings (#26358).  Consider unifying+    [F a, F Int, Int]  ~  [Bool, Char, a]+Working left to right you might think we would build the mapping+  F a   :-> Bool+  F Int :-> Char+Now we discover that `a` unifies with `Int`. So really these two lists are Apart+because F Int can't be both Bool and Char.++Just the same applies when adding a type-family binding to um_fam_env:+  [F (G Float), F Int, G Float] ~ [Bool, Char, Iont]+Again these are Apart, because (G Float = Int),+and (F Int) can't be both Bool and Char++But achieving this is very tricky! Perhaps whenever we unify a type variable,+or a type family, we should run it over the domain and (maybe range) of the+type-family mapping too?  Sigh.++For now we make no such attempt.+* The um_fam_env has only /un-substituted/ types.+* We look up only /un-substituted/ types in um_fam_env++This may make us say MaybeApart when we could say SurelyApart, but it has no+effect on the correctness of unification: if we return Unifiable, it really is+Unifiable.++This is all quite subtle. suppose we have:+    um_tv_env:   c :-> b+    um_fam_env   F b :-> a+and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will+fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq,+getting:+    um_tv_env:   a :-> F c, c :-> b+    um_fam_env   F b :-> a++Does that loop, like this:+   a --> F c --> F b --> a?+No, because we do not substitute (F c) to (F b) and then look up in um_fam_env;+we look up only un-substituted types.+-}++{- *********************************************************************+*                                                                      *+                Binding decisions+*                                                                      *+********************************************************************* -}++data BindFlag+  = BindMe      -- ^ A bindable type variable++  | DontBindMe  -- ^ Do not bind this type variable is /apart/+                -- See also Note [Super skolems: binding when looking up instances]+                -- in GHC.Core.InstEnv.+  deriving Eq++-- | Some unification functions are parameterised by a 'BindTvFun', which+-- says whether or not to allow a certain unification to take place.+-- A 'BindTvFun' takes the 'TyVar' involved along with the 'Type' it will+-- potentially be bound to.+--+-- It is possible for the variable to actually be a coercion variable+-- (Note [Matching coercion variables]), but only when one-way matching.+-- In this case, the 'Type' will be a 'CoercionTy'.+type BindTvFun = TyCoVar -> Type -> BindFlag++-- | BindFamFun is similiar to BindTvFun, but deals with a saturated+-- type-family application.  See Note [Apartness and type families].+type BindFamFun = TyCon -> [Type] -> Type -> BindFlag++-- | Allow binding only for any variable in the set. Variables may+-- be bound to any type.+-- Used when doing simple matching; e.g. can we find a substitution+--+-- @+-- S = [a :-> t1, b :-> t2] such that+--     S( Maybe (a, b->Int )  =   Maybe (Bool, Char -> Int)+-- @+matchBindTv :: TyCoVarSet -> BindTvFun+matchBindTv tvs tv _ty+  | tv `elemVarSet` tvs = BindMe+  | otherwise           = DontBindMe++-- | Allow the binding of any variable to any type+alwaysBindTv :: BindTvFun+alwaysBindTv _tv _ty = BindMe++-- | Allow the binding of a type-family application to any type+alwaysBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+alwaysBindFam _tc _args _rhs = BindMe++dontCareBindFam :: HasCallStack => BindFamFun+-- See (ATF8) in Note [Apartness and type families]+dontCareBindFam tc args rhs+  = pprPanic "dontCareBindFam" $+    vcat [ ppr tc <+> ppr args, text "rhs" <+> ppr rhs ]++-- | Don't allow the binding of a type-family application at all+neverBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+neverBindFam _tc _args _rhs = DontBindMe+++{- *********************************************************************+*                                                                      *+                Various wrappers for matching+*                                                                      *+********************************************************************* -}++-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))+-- @s@ such that @s(t1)@ equals @t2@.+-- The returned substitution might bind coercion variables,+-- if the variable is an argument to a GADT constructor.+--+-- Precondition: typeKind ty1 `eqType` typeKind ty2+--+-- We don't pass in a set of "template variables" to be bound+-- by the match, because tcMatchTy (and similar functions) are+-- always used on top-level types, so we can bind any of the+-- free variables of the LHS.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTy :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]++tcMatchTyX_BM :: HasDebugCallStack+              => BindTvFun -> Subst+              -> Type -> Type -> Maybe Subst+tcMatchTyX_BM bind_tv subst ty1 ty2+  = tc_match_tys_x bind_tv False subst [ty1] [ty2]++-- | Like 'tcMatchTy', but allows the kinds of the types to differ,+-- and thus matches them as well.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTyKi ty1 ty2+  = tc_match_tys alwaysBindTv True [ty1] [ty2]++-- | This is similar to 'tcMatchTy', but extends a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyX :: HasDebugCallStack+           => Subst               -- ^ Substitution to extend+           -> Type                -- ^ Template+           -> Type                -- ^ Target+           -> Maybe Subst+tcMatchTyX subst ty1 ty2+  = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2]++-- | Like 'tcMatchTy' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTys :: HasDebugCallStack+           => [Type]         -- ^ Template+           -> [Type]         -- ^ Target+           -> Maybe Subst    -- ^ One-shot; in principle the template+                             -- variables could be free in the target+                             -- See (CU6) in Note [The Core unifier]+tcMatchTys tys1 tys2+  = tc_match_tys alwaysBindTv False tys1 tys2++-- | Like 'tcMatchTyKi' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKis :: HasDebugCallStack+             => [Type]         -- ^ Template+             -> [Type]         -- ^ Target+             -> Maybe Subst    -- ^ One-shot substitution+                               -- See (CU6) in Note [The Core unifier]+tcMatchTyKis tys1 tys2+  = tc_match_tys alwaysBindTv True tys1 tys2++-- | Like 'tcMatchTys', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTysX :: HasDebugCallStack+            => Subst          -- ^ Substitution to extend+            -> [Type]         -- ^ Template+            -> [Type]         -- ^ Target+            -> Maybe Subst    -- ^ One-shot substitution+tcMatchTysX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv False subst tys1 tys2++-- | Like 'tcMatchTyKis', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKisX :: HasDebugCallStack+              => Subst        -- ^ Substitution to extend+              -> [Type]       -- ^ Template+              -> [Type]       -- ^ Target+              -> Maybe Subst  -- ^ One-shot substitution+tcMatchTyKisX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv True subst tys1 tys2++-- | Same as tc_match_tys_x, but starts with an empty substitution+tc_match_tys :: HasDebugCallStack+             => BindTvFun+             -> Bool          -- ^ match kinds?+             -> [Type]+             -> [Type]+             -> Maybe Subst+tc_match_tys bind_me match_kis tys1 tys2+  = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'+tc_match_tys_x :: HasDebugCallStack+               => BindTvFun+               -> Bool          -- ^ match kinds?+               -> Subst+               -> [Type]+               -> [Type]+               -> Maybe Subst+tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2+  = case tc_unify_tys neverBindFam  -- (ATF7) in Note [Apartness and type families]+                      bind_tv+                      False  -- Matching, not unifying+                      False  -- Not an injectivity check+                      match_kis+                      RespectMultiplicities+                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of+      Unifiable (tv_env', cv_env')+        -> Just $ Subst in_scope id_env tv_env' cv_env'+      _ -> Nothing++-- | This one is called from the expression matcher,+-- which already has a MatchEnv in hand+ruleMatchTyKiX+  :: TyCoVarSet          -- ^ template variables+  -> RnEnv2+  -> TvSubstEnv          -- ^ type substitution to extend+  -> Type                -- ^ Template+  -> Type                -- ^ Target+  -> Maybe TvSubstEnv+ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target+-- See Note [Kind coercions in Unify]+  = case tc_unify_tys neverBindFam (matchBindTv tmpl_tvs)+      -- neverBindFam: a type family probably shouldn't appear+      -- on the LHS of a RULE, although we don't currently prevent it.+      -- But even if it did, (ATF8) in Note [Apartness and type families]+      -- says it doesn't matter becuase here we only care about Unifiable.+      -- So neverBindFam is efficient, and sufficient.+                      False    -- Matching, not unifying+                      False    -- No doing an injectivity check+                      True     -- Match the kinds+                      IgnoreMultiplicities+                        -- See Note [Rewrite rules ignore multiplicities in FunTy]+                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of+      Unifiable (tenv', _) -> Just tenv'+      _                    -> Nothing++{-+************************************************************************+*                                                                      *+                GADTs+*                                                                      *+************************************************************************++Note [Pruning dead case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        data T a where+                   T1 :: T Int+                   T2 :: T a++                newtype X = MkX Int+                newtype Y = MkY Char++                type family F a+                type instance F Bool = Int++Now consider    case x of { T1 -> e1; T2 -> e2 }++The question before the house is this: if I know something about the type+of x, can I prune away the T1 alternative?++Suppose x::T Char.  It's impossible to construct a (T Char) using T1,+        Answer = YES we can prune the T1 branch (clearly)++Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated+to 'Bool', in which case x::T Int, so+        ANSWER = NO (clearly)++We see here that we want precisely the apartness check implemented within+tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely+apart. Note that since we are simply dropping dead code, a conservative test+suffices.+-}++-- | Given a list of pairs of types, are any two members of a pair surely+-- apart, even after arbitrary type function evaluation and substitution?+typesCantMatch :: [(Type,Type)] -> Bool+-- See Note [Pruning dead case alternatives]+typesCantMatch prs = any (uncurry typesAreApart) prs++typesAreApart :: Type -> Type -> Bool+typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFam alwaysBindTv [t1] [t2] of+                        SurelyApart -> True+                        _           -> False+{-+************************************************************************+*                                                                      *+             Various wrappers for unification+*                                                                      *+********************************************************************* -}++-- | Simple unification of two types; all type variables are bindable+-- Precondition: the kinds are already equal+tcUnifyTy :: Type -> Type       -- All tyvars are bindable+          -> Maybe Subst+                       -- A regular one-shot (idempotent) substitution+tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2]++tcUnifyDebugger :: Type -> Type -> Maybe Subst+tcUnifyDebugger t1 t2+  = case tc_unify_tys_fg+             True            -- Unify kinds+             neverBindFam    -- Does not affect Unifiable, so pick max efficient+                             -- See (ATF8) in Note [Apartness and type families]+             alwaysBindTv+             [t1] [t2] of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Like 'tcUnifyTys' but also unifies the kinds+tcUnifyFunDeps :: TyCoVarSet+               -> [Type] -> [Type]+               -> Maybe Subst+tcUnifyFunDeps qtvs tys1 tys2+  = case tc_unify_tys_fg+             True               -- Unify kinds+             dontCareBindFam    -- Class-instance heads never mention type families+             (matchBindTv qtvs)+             tys1 tys2 of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Unify or match a type-family RHS with a type (possibly another type-family RHS)+-- Precondition: kinds are the same+tcUnifyTyForInjectivity+    :: AmIUnifying  -- ^ True <=> do two-way unification;+                    --   False <=> do one-way matching.+                    --   See end of sec 5.2 from the paper+    -> InScopeSet     -- Should include the free tyvars of both Type args+    -> Type -> Type   -- Types to unify+    -> Maybe Subst+-- This algorithm is an implementation of the "Algorithm U" presented in+-- the paper "Injective type families for Haskell", Figures 2 and 3.+-- The code is incorporated with the standard unifier for convenience, but+-- its operation should match the specification in the paper.+tcUnifyTyForInjectivity unif in_scope t1 t2+  = case tc_unify_tys alwaysBindFam alwaysBindTv+                       unif   -- Am I unifying?+                       True   -- Do injectivity checks+                       False  -- Don't check outermost kinds+                       RespectMultiplicities+                       rn_env emptyTvSubstEnv emptyCvSubstEnv+                       [t1] [t2] of+      Unifiable          (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+      MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+                 -- We want to *succeed* in questionable cases.+                 -- This is a pre-unification algorithm.+      SurelyApart      -> Nothing+  where+    rn_env   = mkRnEnv2 in_scope++    maybe_fix | unif      = niFixSubst in_scope+              | otherwise = mkTvSubst in_scope -- when matching, don't confuse+                                               -- domain with range++-----------------+tcUnifyTys :: BindTvFun+           -> [Type] -> [Type]+           -> Maybe Subst+                                -- ^ A regular one-shot (idempotent) substitution+                                -- that unifies the erased types. See comments+                                -- for 'tcUnifyTysFG'++-- The two types may have common type variables, and indeed do so in the+-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD+tcUnifyTys bind_fn tys1 tys2+  = case tcUnifyTysFG neverBindFam bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- | (tcUnifyTysFG bind_fam bind_tv tys1 tys2) does "fine-grain" unification+-- of tys1 and tys2, under the control of `bind_fam` and `bind_tv`.+-- This version requires that the kinds of the types are the same,+-- if you unify left-to-right.+-- See Note [The Core unifier]+tcUnifyTysFG :: BindFamFun -> BindTvFun+             -> [Type] -> [Type]+             -> UnifyResult+tcUnifyTysFG bind_fam bind_tv tys1 tys2+  = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2++tc_unify_tys_fg :: Bool+                -> BindFamFun -> BindTvFun+                -> [Type] -> [Type]+                -> UnifyResult+tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2+  = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv+                                  True       -- Unifying+                                  False      -- Not doing an injectivity check+                                  match_kis  -- Match outer kinds+                                  RespectMultiplicities rn_env+                                  emptyTvSubstEnv emptyCvSubstEnv+                                  tys1 tys2+       ; return $ niFixSubst in_scope tv_env }+  where+    in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+    rn_env   = mkRnEnv2 in_scope++-- | This function is actually the one to call the unifier -- a little+-- too general for outside clients, though.+tc_unify_tys :: BindFamFun -> BindTvFun+             -> AmIUnifying -- ^ True <=> unify; False <=> match+             -> Bool        -- ^ True <=> doing an injectivity check+             -> Bool        -- ^ True <=> treat the kinds as well+             -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify+             -> RnEnv2+             -> TvSubstEnv  -- ^ substitution to extend+             -> CvSubstEnv+             -> [Type] -> [Type]+             -> UnifyResultM (TvSubstEnv, CvSubstEnv)+-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then+-- the kinds of the types should be the same. However, this doesn't work,+-- as the types may be a dependent telescope, where later types have kinds+-- that mention variables occurring earlier in the list of types. Here's an+-- example (from typecheck/should_fail/T12709):+--   template: [rep :: RuntimeRep,       a :: TYPE rep]+--   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]+-- We can see that matching the first pair will make the kinds of the second+-- pair equal. Yet, we still don't need a separate pass to unify the kinds+-- of these types, so it's appropriate to use the Ty variant of unification.+-- See also Note [tcMatchTy vs tcMatchTyKi].+tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2+  = initUM tv_env cv_env $+    do { when match_kis $+         unify_tys env kis1 kis2+       ; unify_tys env tys1 tys2 }+  where+    env = UMEnv { um_bind_tv_fun  = bind_tv+                , um_bind_fam_fun = bind_fam+                , um_foralls      = emptyVarSet+                , um_unif         = unif+                , um_inj_tf       = inj_check+                , um_arr_mult     = match_mults+                , um_rn_env       = rn_env }++    kis1 = map typeKind tys1+    kis2 = map typeKind tys2+++{- *********************************************************************+*                                                                      *+                UnifyResult, MaybeApart etc+*                                                                      *+********************************************************************* -}++{- Note [Rewrite rules ignore multiplicities in FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following (higher-order) rule:++m :: Bool -> Bool -> Bool+{-# RULES "m" forall f. m (f True) = f #-}++let x = m ((,) @Bool @Bool True True)++The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True ::+Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default]+in GHC.Core.Multiplicity) Should the rule match? Yes! According to the+principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation+shouldn't be constrained by linearity.++However, when matching the template variable `f` to `(,) True`, we do check that+their types unify (see Note [Matching variable types] in GHC.Core.Rules). So+when unifying types for the sake of rule-matching, the unification algorithm+must be able to ignore multiplicities altogether.++How is this done?+  (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching,+      and hence want to ignore multiplicities.+  (2) The field is set to True in by `ruleMatchTyKiX`.+  (3) It is consulted when matching `FunTy` in `unify_ty`.++Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it+was a regular type constructor. In this case, and when the types being unified+are *function* arrows, but not constraint arrows, then the first argument is a+multiplicity.++We select this situation by comparing the type constructor with fUNTyCon. In+this case, and this case only, we can safely drop the first argument (using the+tail function) and unify the rest.++Note [The substitution in MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?+Because consider unifying these:++(a, a, Int) ~ (b, [b], Bool)++If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we+apply the subst we have so far and discover that we need [b |-> [b]]. Because+this fails the occurs check, we say that the types are MaybeApart (see above+Note [Infinitary substitutions]). But, we can't stop there! Because if we+continue, we discover that Int is SurelyApart from Bool, and therefore the+types are apart. This has practical consequences for the ability for closed+type family applications to reduce. See test case+indexed-types/should_compile/Overlap14.+-}++-- This type does double-duty. It is used in the UM (unifier monad) and to+-- return the final result. See Note [Unification result]+type UnifyResult = UnifyResultM Subst++-- | See Note [Unification result]+data UnifyResultM a = Unifiable a        -- the subst that unifies the types+                    | MaybeApart MaybeApartReason+                                 a       -- the subst has as much as we know+                                         -- it must be part of a most general unifier+                                         -- See Note [The substitution in MaybeApart]+                    | SurelyApart+                    deriving Functor++-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:+-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv+-- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint;+-- it's really only MARInfinite that's interesting here.+data MaybeApartReason+  = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool++  | MARInfinite     -- ^ matching e.g. a ~? Maybe a++  | MARTypeVsConstraint  -- ^ matching Type ~? Constraint or the arrow types+    -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim++  | MARCast         -- ^ Very obscure.+    -- See (KCU2) in Note [Kind coercions in Unify]+++combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason+-- See (UR1) in Note [Unification result] for why MARInfinite wins+combineMAR MARInfinite         _ = MARInfinite   -- MARInfinite wins+combineMAR MARTypeFamily       r = r             -- Otherwise it doesn't really matter+combineMAR MARTypeVsConstraint r = r+combineMAR MARCast             r = r++instance Outputable MaybeApartReason where+  ppr MARTypeFamily       = text "MARTypeFamily"+  ppr MARInfinite         = text "MARInfinite"+  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"+  ppr MARCast             = text "MARCast"++instance Semigroup MaybeApartReason where+  (<>) = combineMAR++instance Applicative UnifyResultM where+  pure  = Unifiable+  (<*>) = ap++instance Monad UnifyResultM where+  SurelyApart  >>= _ = SurelyApart+  MaybeApart r1 x >>= f = case f x of+                            Unifiable y     -> MaybeApart r1 y+                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y+                            SurelyApart     -> SurelyApart+  Unifiable x  >>= f = f x++instance Outputable a => Outputable (UnifyResultM a) where+  ppr SurelyApart      = text "SurelyApart"+  ppr (Unifiable x)    = text "Unifiable" <+> ppr x+  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x++{-+************************************************************************+*                                                                      *+                Non-idempotent substitution+*                                                                      *+************************************************************************++Note [Non-idempotent substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During unification we use a TvSubstEnv/CvSubstEnv pair that is+  (a) non-idempotent+  (b) loop-free; ie repeatedly applying it yields a fixed point++Note [Finding the substitution fixpoint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Finding the fixpoint of a non-idempotent substitution arising from a+unification is much trickier than it looks, because of kinds.  Consider+   T k (H k (f:k)) ~ T * (g:*)+If we unify, we get the substitution+   [ k -> *+   , g -> H k (f:k) ]+To make it idempotent we don't want to get just+   [ k -> *+   , g -> H * (f:k) ]+We also want to substitute inside f's kind, to get+   [ k -> *+   , g -> H k (f:*) ]+If we don't do this, we may apply the substitution to something,+and get an ill-formed type, i.e. one where typeKind will fail.+This happened, for example, in #9106.++It gets worse.  In #14164 we wanted to take the fixpoint of+this substitution+   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)+                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))+   , a_aY6  :-> a_aXQ ]++We have to apply the substitution for a_aY6 two levels deep inside+the invocation of F!  We don't have a function that recursively+applies substitutions inside the kinds of variable occurrences (and+probably rightly so).++So, we work as follows:++ 1. Start with the current substitution (which we are+    trying to fixpoint+       [ xs :-> F a (z :: a) (rest :: G a (z :: a))+       , a  :-> b ]++ 2. Take all the free vars of the range of the substitution:+       {a, z, rest, b}+    NB: the free variable finder closes over+    the kinds of variable occurrences++ 3. If none are in the domain of the substitution, stop.+    We have found a fixpoint.++ 4. Remove the variables that are bound by the substitution, leaving+       {z, rest, b}++ 5. Do a topo-sort to put them in dependency order:+       [ b :: *, z :: a, rest :: G a z ]++ 6. Apply the substitution left-to-right to the kinds of these+    tyvars, extending it each time with a new binding, so we+    finish up with+       [ xs   :-> ..as before..+       , a    :-> b+       , b    :-> b    :: *+       , z    :-> z    :: b+       , rest :-> rest :: G b (z :: b) ]+    Note that rest now has the right kind++ 7. Apply this extended substitution (once) to the range of+    the /original/ substitution.  (Note that we do the+    extended substitution would go on forever if you tried+    to find its fixpoint, because it maps z to z.)++ 8. And go back to step 1++In Step 6 we use the free vars from Step 2 as the initial+in-scope set, because all of those variables appear in the+range of the substitution, so they must all be in the in-scope+set.  But NB that the type substitution engine does not look up+variables in the in-scope set; it is used only to ensure no+shadowing.+-}++niFixSubst :: InScopeSet -> TvSubstEnv -> Subst+-- Find the idempotent fixed point of the non-idempotent substitution+-- This is surprisingly tricky:+--   see Note [Finding the substitution fixpoint]+-- ToDo: use laziness instead of iteration?+niFixSubst in_scope tenv+  | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)+  | otherwise    = subst+  where+    range_fvs :: FV+    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)+          -- It's OK to use nonDetEltsUFM here because the+          -- order of range_fvs, range_tvs is immaterial++    range_tvs :: [TyVar]+    range_tvs = fvVarList range_fvs++    not_fixpoint  = any in_domain range_tvs+    in_domain tv  = tv `elemVarEnv` tenv++    free_tvs = scopedSort (filterOut in_domain range_tvs)++    -- See Note [Finding the substitution fixpoint], Step 6+    subst = foldl' add_free_tv+                  (mkTvSubst in_scope tenv)+                  free_tvs++    add_free_tv :: Subst -> TyVar -> Subst+    add_free_tv subst tv+      = extendTvSubst subst tv (mkTyVarTy tv')+     where+        tv' = updateTyVarKind (substTy subst) tv++{-+************************************************************************+*                                                                      *+                unify_ty: the main workhorse+*                                                                      *+************************************************************************++Note [Specification of unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pure unifier, unify_ty, defined in this module, tries to work out+a substitution to make two types say True to eqType. NB: eqType is+itself not purely syntactic; it accounts for CastTys;+see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep++Unlike the "impure unifiers" in the typechecker (the eager unifier in+GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality),+the pure unifier does /not/ work up to ~.++The algorithm implemented here is rather delicate, and we depend on it+to uphold certain properties. This is a summary of these required+properties.++Notation:+ θ,φ  substitutions+ ξ    type-function-free types+ τ,σ  other types+ τ♭   type τ, flattened++ ≡    eqType++(U1) Soundness.+     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).+     θ is a most general unifier for τ₁ and τ₂.++(U2) Completeness.+     If (unify ξ₁ ξ₂) = SurelyApart,+     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).++These two properties are stated as Property 11 in the "Closed Type Families"+paper (POPL'14). Below, this paper is called [CTF].++(U3) Apartness under substitution.+     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,+     for any θ. (Property 12 from [CTF])++(U4) Apart types do not unify.+     If (unify ξ τ♭) = SurelyApart, then there exists no θ+     such that θ(ξ) = θ(τ). (Property 13 from [CTF])++THEOREM. Completeness w.r.t ~+    If (unify τ₁♭ τ₂♭) = SurelyApart,+    then there exists no proof that (τ₁ ~ τ₂).++PROOF. See appendix of [CTF].+++The unification algorithm is used for type family injectivity, as described+in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run+in this mode, it has the following properties.++(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even+     after arbitrary type family reductions.++(I2) If (unify σ τ) = MaybeApart θ, and if some+     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.+++Furthermore, the RULES matching algorithm requires this property,+but only when using this algorithm for matching:++(M1) If (match σ τ) succeeds with θ, then all matchable tyvars+     in σ are bound in θ.++     Property M1 means that we must extend the substitution with,+     say (a ↦ a) when appropriate during matching.+     See also Note [Self-substitution when unifying or matching].++(M2) Completeness of matching.+     If θ(σ) = τ, then (match σ τ) = Unifiable φ,+     where θ is an extension of φ.++Wrinkle (SI1): um_inj_tf:+    Sadly, property M2 and I2 conflict. Consider++    type family F1 a b where+      F1 Int    Bool   = Char+      F1 Double String = Char++    Consider now two matching problems:++    P1. match (F1 a Bool) (F1 Int Bool)+    P2. match (F1 a Bool) (F1 Double String)++    In case P1, we must find (a ↦ Int) to satisfy M2.  In case P2, we must /not/+    find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for+    I2 is (a ↦ Int). There is no way to discover this, but we mustn't map a to+    anything else!)++    We thus must parameterize the algorithm over whether it's being used+    for an injectivity check (refrain from looking at non-injective arguments+    to type families) or not (do indeed look at those arguments).  This is+    implemented  by the um_inj_tf field of UMEnv.++    (It's all a question of whether or not to include equation (7) from Fig. 2+    of [ITF].)++    This extra parameter is a bit fiddly, perhaps, but seemingly less so than+    having two separate, almost-identical algorithms.++Note [Self-substitution when unifying or matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we are unifying or matching two identical type variables?+     a ~ a++* When /unifying/, just succeed, without binding [a :-> a] in the substitution,+  else we'd get an infinite substitution.  We need to make this check before+  we do the occurs check, of course.++* When /matching/, and `a` is a bindable variable from the template, we /do/+  want to extend the substitution.  Remember, a successful match should map all+  the template variables (except ones that disappear when expanding synonyms),++  But when `a` is /not/ a bindable variable (perhaps it is a globally-in-scope+  skolem) we want to treat it like a constant `Int ~ Int` and succeed.++  Notice: no occurs check!  It's fine to match (a ~ Maybe a), because the+  template vars of the template come from a different name space to the free+  vars of the target.++  Note that this arrangement was provoked by a real failure, where the same+  unique ended up in the template as in the target. (It was a rule firing when+  compiling Data.List.NonEmpty.)++* What about matching a /non-bindable/ variable?  For example:+      template-vars   : {a}+      matching problem: (forall b. b -> a) ~ (forall c. c -> Int)+  We want to emerge with the substitution [a :-> Int]+  But on the way we will encounter (b ~ b), when we match the bits before the+  arrow under the forall, having renamed `c` to `b`.  This match should just+  succeed, just like (Int ~ Int), without extending the substitution.++  It's important to do this for /non-bindable/ variables, not just for+  forall-bound ones.  In an associated type+         instance C (Maybe a) where {  type F (Maybe a) = Int }+  `checkConsistentFamInst` matches (Maybe a) from the header against (Maybe a)+  from the type-family instance, with `a` marked as non-bindable.+++Note [Matching coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++   type family F a++   data G a where+     MkG :: F a ~ Bool => G a++   type family Foo (x :: G a) :: F a+   type instance Foo MkG = False++We would like that to be accepted. For that to work, we need to introduce+a coercion variable on the left and then use it on the right. Accordingly,+at use sites of Foo, we need to be able to use matching to figure out the+value for the coercion. (See the desugared version:++   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)++) We never want this action to happen during *unification* though, when+all bets are off.++Note [Kind coercions in Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to match/unify while ignoring casts. But, we can't just ignore+them completely, or we'll end up with ill-kinded substitutions. For example,+say we're matching `a` with `ty |> co`. If we just drop the cast, we'll+return [a |-> ty], but `a` and `ty` might have different kinds. We can't+just match/unify their kinds, either, because this might gratuitously+fail. After all, `co` is the witness that the kinds are the same -- they+may look nothing alike.++So, we pass a kind coercion `kco` to the main `unify_ty`. This coercion witnesses+the equality between the substed kind of the left-hand type and the substed+kind of the right-hand type. Note that we do not unify kinds at the leaves+(as we did previously).++Hence: (UKINV) Unification Kind Invariant+* In the call+     unify_ty ty1 ty2 kco+  it must be that+     subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2))+  where `subst` is the ambient substitution in the UM monad+* In the call+     unify_tys tys1 tys2+  (which has no kco), after we unify any prefix of tys1,tys2, the kinds of the+  head of the remaining tys1,tys2 are identical after substitution.  This+  implies, for example, that the kinds of the head of tys1,tys2 are identical+  after substitution.++Preserving (UKINV) takes a bit of work, governed by the `match_kis` flag in+`tc_unify_tys`:++* When we're working with type applications (either TyConApp or AppTy) we+  need to worry about establishing (UKINV), as the kinds of the function+  & arguments aren't (necessarily) included in the kind of the result.+  When unifying two TyConApps, this is easy, because the two TyCons are+  the same. Their kinds are thus the same. As long as we unify left-to-right,+  we'll be sure to unify types' kinds before the types themselves. (For example,+  think about Proxy :: forall k. k -> *. Unifying the first args matches up+  the kinds of the second args.)++* For AppTy, we must unify the kinds of the functions, but once these are+  unified, we can continue unifying arguments without worrying further about+  kinds.++* The interface to this module includes both "...Ty" functions and+  "...TyKi" functions. The former assume that (UKINV) is already+  established, either because the kinds are the same or because the+  list of types being passed in are the well-typed arguments to some+  type constructor (see two paragraphs above). The latter take a separate+  pre-pass over the kinds to establish (UKINV). Sometimes, it's important+  not to take the second pass, as it caused #12442.++Wrinkles++(KCU1) We ensure that the `kco` argument never mentions variables in the+  domain of either RnEnvL or RnEnvR.  Why?++  * `kco` is used only to build the final well-kinded substitution+         a :-> ty |> kco+    The range of the substitution never mentions forall-bound variables,+    so `kco` cannot either.++  * `kco` mixes up types from both left and right arguments of+    `unify_ty`, which have different renamings in the RnEnv2.++  The easiest thing is to insist that `kco` does not need renaming with+  the RnEnv2; it mentions no forall-bound variables.++  To achieve this we do a `mentionsForAllBoundTyVars` test in the+  `CastTy` cases of `unify_ty`.++(KCU2) Suppose we are unifying+            (forall a. x |> (...F a b...) ~ (forall a. y)+  We can't bind y :-> x |> (...F a b...), becuase of that free `a`.++  But if we later learn that b=Int, and F a Int = Bool,+  that free `a` might disappear, so we could unify with+      y :-> x |> (...Bool...)++  Conclusion: if there is a free forall-bound variable in a cast,+  return MaybeApart, with a MaybeApartReason of MARCast.++(KCU3) We thought, at one point, that this was all unnecessary: why should+    casts be in types in the first place? But they are sometimes. In+    dependent/should_compile/KindEqualities2, we see, for example the+    constraint Num (Int |> (blah ; sym blah)).  We naturally want to find+    a dictionary for that constraint, which requires dealing with+    coercions in this manner.++Note [Matching in the presence of casts (1)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching, it is crucial that no variables from the template+end up in the range of the matching substitution (obviously!).+When unifying, that's not a constraint; instead we take the fixpoint+of the substitution at the end.++So what should we do with this, when matching?+   unify_ty (tmpl |> co) tgt kco++Previously, wrongly, we pushed 'co' in the (horrid) accumulating+'kco' argument like this:+   unify_ty (tmpl |> co) tgt kco+     = unify_ty tmpl tgt (kco ; co)++But that is obviously wrong because 'co' (from the template) ends+up in 'kco', which in turn ends up in the range of the substitution.++This all came up in #13910.  Because we match tycon arguments+left-to-right, the ambient substitution will already have a matching+substitution for any kinds; so there is an easy fix: just apply+the substitution-so-far to the coercion from the LHS.++Note that++* When matching, the first arg of unify_ty is always the template;+  we never swap round.++* The above argument is distressingly indirect. We seek a+  better way.++* One better way is to ensure that type patterns (the template+  in the matching process) have no casts.  See #14119.++Note [Matching in the presence of casts (2)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)+and we are matching+   tcMatchTy (T k (a::k))  (T j (b::j))++Then we'll match k :-> j, as expected. But then in unify_tys+we invoke+   unify_tys env (a::k) (b::j) (Refl j)++Although we have unified k and j, it's very important that we put+(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.+If we put (Refl k) we'd end up with the substitution+  a :-> b |> Refl k+which is bogus because one of the template variables, k,+appears in the range of the substitution.  Eek.++Similar care is needed in unify_ty_app.+++Note [Polykinded tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose  T :: forall k. Type -> K+and we are unifying+  ty1:  T @Type         Int       :: Type+  ty2:  T @(Type->Type) Int Int   :: Type++These two TyConApps have the same TyCon at the front but they+(legitimately) have different numbers of arguments.  They+are surelyApart, so we can report that without looking any+further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+   type family F a :: Type -> Type+   type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+  Since F is injective, we can reduce this to Int ~ Char,+  therefore SurelyApart.++* F Int ~ F Char, where F is not injective+  Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+  Even though G is injective and the arguments to G are different,+  we cannot deduce apartness because the RHS is oversaturated.+  For example, G might be defined as+    G Type = Maybe Int+    G (Type -> Type) = Maybe+  So we return MaybeApart.++* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)+  F Int Bool ~ Maybe a          -- MaybeApart+  F Int Bool ~ a b              -- MaybeApart+  F Int Bool ~ Char -> Bool     -- MaybeApart+  An oversaturated type family can match an application,+  whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+  We cannot decompose a saturated, or under-saturated+  type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+  A saturated application.+  Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+  A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+  An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+  If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families.++Note [Unifying type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of unifying two 'Type's of the form++  TyConApp tc [] ~ TyConApp tc []++where `tc` is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of `tc` may be large; it is+much better to rather compare the TyCons directly. Consequently, before+expanding type synonyms in type comparisons we first look for a nullary+TyConApp and simply compare the TyCons if we find one.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be unifiable.  E.g+    type T = S (a->a)+    type S a = [a]+and consider+    T Int ~ S (Int -> Int)++We can't decompose non-nullary synonyms.  E.g.+    type R a = F a    -- Where F is a type family+and consider+    R (a->a) ~ R Int+We can't conclude that  (a->) ~ Int.  (There is a currently-missed opportunity+here; if we knew that R was /injective/, perhaps we could decompose.)++We perform the nullary-type-synonym optimisation in a number of places:++ * GHC.Core.Unify.unify_ty+ * GHC.Tc.Solver.Equality.can_eq_nc'+ * GHC.Tc.Utils.Unify.uType++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.++c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare+-}++-------------- unify_ty: the main workhorse -----------++type AmIUnifying = Bool   -- True  <=> Unifying+                          -- False <=> Matching++type InType      = Type       -- Before applying the RnEnv2+type OutCoercion = Coercion   -- After applying the RnEnv2+++unify_ty :: UMEnv+         -> InType -> InType  -- Types to be unified+         -> OutCoercion       -- A nominal coercion between their kinds+                              -- OutCoercion: the RnEnv has already been applied+                              -- When matching, the coercion is in "target space",+                              --   not "template space"+                              -- See Note [Kind coercions in Unify]+         -> UM ()+-- Precondition: see (Unification Kind Invariant)+--+-- See Note [Specification of unification]+-- Respects newtypes, PredTypes+-- See Note [Computing equality on types] in GHC.Core.Type+unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco+  -- See Note [Unifying type synonyms]+  | tc1 == tc2+  = return ()++unify_ty env ty1 ty2 kco+    -- Now handle the cases we can "look through": synonyms and casts.+  | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco+  | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco++unify_ty env (CastTy ty1 co1) ty2 kco+  | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)++  | um_unif env+  = unify_ty env ty1 ty2 (co1 `mkTransCo` kco)++  | otherwise -- We are matching, not unifying+  = do { subst <- getSubst env+       ; let co' = substCo subst co1+         -- We match left-to-right, so the free template vars of the+         -- coercion should already have been matched.+         -- See Note [Matching in the presence of casts (1)]+         -- NB: co1 does not mention forall-bound vars, so no need to rename+       ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) }++unify_ty env ty1 (CastTy ty2 co2) kco+  | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)+  | otherwise+  = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2)+    -- NB: co2 does not mention forall-bound variables++-- Applications need a bit of care!+-- They can match FunTy and TyConApp, so use splitAppTy_maybe+unify_ty env (AppTy ty1a ty1b) ty2 _kco+  | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty env ty1 (AppTy ty2a ty2b) _kco+  | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()++unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco+  -- ToDo: See Note [Unifying coercion-foralls]+  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)+       ; let env' = umRnBndr2 env tv1 tv2+       ; unify_ty env' ty1 ty2 kco }++-- See Note [Matching coercion variables]+unify_ty env (CoercionTy co1) (CoercionTy co2) kco+  = do { c_subst <- getCvSubstEnv+       ; case co1 of+           CoVarCo cv+             | not (um_unif env)+             , not (cv `elemVarEnv` c_subst)   -- Not forall-bound+             , let (_mult_co, co_l, co_r) = decomposeFunCo kco+                     -- Because the coercion is used in a type, it should be safe to+                     -- ignore the multiplicity coercion, _mult_co+                      -- cv :: t1 ~ t2+                      -- co2 :: s1 ~ s2+                      -- co_l :: t1 ~ s1+                      -- co_r :: t2 ~ s2+                   rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r+             , BindMe <- um_bind_tv_fun env cv (CoercionTy rhs_co)+             -> if mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+                then surelyApart+                else extendCvEnv cv rhs_co++           _ -> return () }++unify_ty env (TyVarTy tv1) ty2 kco+  = uVarOrFam env (TyVarLHS tv1) ty2 kco++unify_ty env ty1 (TyVarTy tv2) kco+  | um_unif env  -- If unifying, can swap args; but not when matching+  = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco)++-- Deal with TyConApps+unify_ty env ty1 ty2 kco+  -- Handle non-oversaturated type families first+  -- See Note [Unifying type applications]+  | Just (tc,tys) <- mb_sat_fam_app1+  = uVarOrFam env (TyFamLHS tc tys) ty2 kco++  | um_unif env+  , Just (tc,tys) <- mb_sat_fam_app2+  = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco)++  -- Handle oversaturated type families. Suppose we have+  --     (F a b) ~ (c d)    where F has arity 1+  -- We definitely want to decompose that type application! (#22647)+  --+  -- If there is no application, an oversaturated type family can only+  -- match a type variable or a saturated type family,+  -- both of which we handled earlier. So we can say surelyApart.+  | Just (tc1, _) <- mb_tc_app1+  , isTypeFamilyTyCon tc1+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  | Just (tc2, _) <- mb_tc_app2+  , isTypeFamilyTyCon tc2+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  -- At this point, neither tc1 nor tc2 can be a type family.+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2+  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+       ; unify_tc_app env tc1 tys1 tys2+       }++  -- TYPE and CONSTRAINT are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  -- NB: at this point we know that the two TyCons do not match+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  -- The arrow types are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  --     wrinkle (W2)+  -- NB1: at this point we know that the two TyCons do not match+  -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via+  --      splitTyConApp_maybe.  But yes we do: we need to look at those implied+  --      kind argument in order to satisfy (Unification Kind Invariant)+  | FunTy {} <- ty1+  , FunTy {} <- ty2+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  where+    mb_tc_app1 = splitTyConApp_maybe ty1+    mb_tc_app2 = splitTyConApp_maybe ty2+    mb_sat_fam_app1 = isSatTyFamApp ty1+    mb_sat_fam_app2 = isSatTyFamApp ty2++unify_ty _ _ _ _ = surelyApart++-----------------------------+unify_tc_app :: UMEnv -> TyCon -> [Type] -> [Type] -> UM ()+-- Mainly just unifies the argument types;+-- but with a special case for fUNTyCon+unify_tc_app env tc tys1 tys2+  | tc == fUNTyCon+  , IgnoreMultiplicities <- um_arr_mult env+  , (_mult1 : no_mult_tys1) <- tys1+  , (_mult2 : no_mult_tys2) <- tys2+  = -- We're comparing function arrow types here (not constraint arrow+    -- types!), and they have at least one argument, which is the arrow's+    -- multiplicity annotation. The flag `um_arr_mult` instructs us to+    -- ignore multiplicities in this very case. This is a little tricky: see+    -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy].+     unify_tys env no_mult_tys1 no_mult_tys2++  | otherwise+  = unify_tys env tys1 tys2++-----------------------------+unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()+-- Deal with (t1 t1args) ~ (t2 t2args)+-- where   length t1args = length t2args+unify_ty_app env ty1 ty1args ty2 ty2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2+  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)++  | otherwise+  = do { let ki1 = typeKind ty1+             ki2 = typeKind ty2+           -- See Note [Kind coercions in Unify]+       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)+       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)+                 -- Very important: 'ki2' not 'ki1'+                 -- See Note [Matching in the presence of casts (2)]+       ; unify_tys env ty1args ty2args }++-----------------------------+unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()+-- Precondition: see (Unification Kind Invariant)+unify_tys env orig_xs orig_ys+  = go orig_xs orig_ys+  where+    go []     []     = return ()+    go (x:xs) (y:ys)+      -- See Note [Kind coercions in Unify]+      = do { unify_ty env x y (mkNomReflCo $ typeKind y)+                 -- Very important: 'y' not 'x'+                 -- See Note [Matching in the presence of casts (2)]+           ; go xs ys }+    go _ _ = surelyApart+      -- Possibly different saturations of a polykinded tycon+      -- See Note [Polykinded tycon applications]++---------------------------------+uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()+-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy+--             (b) both args have had coreView already applied+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+uVarOrFam env ty1 ty2 kco+  = do { substs <- getSubstEnvs+--       ; pprTrace "uVarOrFam" (vcat+--           [ text "ty1" <+> ppr ty1+--           , text "ty2" <+> ppr ty2+--           , text "tv_env" <+> ppr (um_tv_env substs)+--           , text "fam_env" <+> ppr (um_fam_env substs) ]) $+       ; go NotSwapped substs ty1 ty2 kco }+  where+    foralld_tvs  = um_foralls env+    under_forall = not (isEmptyVarSet foralld_tvs)++    -- `go` takes two bites at the cherry; if the first one fails+    -- it swaps the arguments and tries again; and then it fails.+    -- The SwapFlag argument tells `go` whether it is on the first+    -- bite (NotSwapped) or the second (IsSwapped).+    -- E.g.    a ~ F p q+    --         Starts with: go a (F p q)+    --         if `a` not bindable, swap to: go (F p q) a++    -----------------------------+    -- LHS is a type variable+    -- The sequence of tests is very similar to go_tv+    go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM ()+    go swapped substs lhs@(TyVarLHS tv1) ty2 kco+      | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'+      = -- We already have a substitution for tv1+        if | um_unif env                          -> unify_ty env ty1' ty2 kco+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> surelyApart+           -- Unifying: recurse into unify_ty+           -- Matching: we /don't/ want to just recurse here, because the range of+           --    the subst is the target type, not the template type. So, just check+           --    for normal type equality.+           -- NB: it's important to use `tcEqType` instead of `eqType` here,+           -- otherwise we might not reject a substitution+           -- which unifies `Type` with `Constraint`, e.g.+           -- a call to tc_unify_tys with arguments+           --+           --   tys1 = [k,k]+           --   tys2 = [Type, Constraint]+           --+           -- See test cases: T11715b, T20521.++      -- If we are matching or unifying a ~ a, take care+      -- See Note [Self-substitution when unifying or matching]+      | TyVarTy tv2 <- ty2+      , let tv2' = umRnOccR env tv2+      , tv1' == tv2'+      = if | um_unif env     -> return ()+           | tv1_is_bindable -> extendTvEnv tv1' ty2+           | otherwise       -> return ()++      | tv1_is_bindable+      , not (mentionsForAllBoundTyVarsR env ty2_fvs)+            -- ty2_fvs: kco does not mention forall-bound vars+      , not occurs_check+      = -- No occurs check, nor skolem-escape; just bind the tv+        -- We don't need to rename `rhs` because it mentions no forall-bound vars+        extendTvEnv tv1' rhs     -- Bind tv1:=rhs and continue++      -- When unifying, try swapping:+      -- e.g.   a    ~ F p q       with `a` not bindable: we might succeed with go_fam+      -- e.g.   a    ~ beta        with `a` not bindable: we might be able to bind `beta`+      -- e.g.   beta ~ F beta Int  occurs check; but MaybeApart after swapping+      | um_unif env+      , NotSwapped <- swapped  -- If we have swapped already, don't do so again+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco)++      | occurs_check = maybeApart MARInfinite   -- Occurs check+      | otherwise    = surelyApart++      where+        tv1'            = umRnOccL env tv1+        ty2_fvs         = tyCoVarsOfType ty2+        rhs             = ty2 `mkCastTy` mkSymCo kco+        tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs)+                          -- tv1' is not forall-bound, but tv1 can still differ+                          -- from tv1; see Note [Cloning the template binders]+                          -- in GHC.Core.Rules.  So give tv1' to um_bind_tv_fun.+                        , BindMe <- um_bind_tv_fun env tv1' rhs+                        = True+                        | otherwise+                        = False++        occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs+          -- Occurs check, only when unifying+          -- see Note [Infinitary substitutions]+          -- Make sure you include `kco` in rhs #14846++    -----------------------------+    -- LHS is a saturated type-family application+    -- Invariant: ty2 is not a TyVarTy+    go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco+      -- Check if we have an existing substitution for the LHS; if so, recurse+      -- But not under a forall; see (ATF3) in Note [Apartness and type families]+      -- Hence the RnEnv2 is empty+      | not under_forall+      , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1+      = if | um_unif env                          -> unify_ty env ty1' ty2 kco+           -- Below here we are matching+           -- The return () case deals with:+           --    Template:   (F a)..(F a)+           --    Target:     (F b)..(F b)+           -- This should match! With [a :-> b]+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> maybeApart MARTypeFamily++      -- Check for equality  F tys1 ~ F tys2+      -- Very important that this can happen under a forall, so that we+      -- successfully match  (forall a. F a) ~ (forall b. F b)  See (ATF9-2)+      | Just (tc2, tys2) <- isSatTyFamApp ty2+      , tc1 == tc2+      = go_fam_fam substs tc1 tys1 tys2 kco++      -- If we are under a forall, just give up+      -- see (ATF3) and (ATF5) in Note [Apartness and type families]+      | under_forall+      = maybeApart MARTypeFamily++      -- Now check if we can bind the (F tys) to the RHS+      -- Again, not under a forall; see (ATF3)+      -- This can happen even when matching: see (ATF7)+      | BindMe <- um_bind_fam_fun env tc1 tys1 rhs+      = if uOccursCheck substs emptyVarSet lhs rhs+        then maybeApart MARInfinite+        else do { extendFamEnv tc1 tys1 rhs+                     -- We don't substitute tys1 before extending+                     -- See Note [Shortcomings of the apartness test]+                ; maybeApart MARTypeFamily }++      -- Swap in case of (F a b) ~ (G c d e)+      -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e)+      -- NB: a type family can appear on the template when matching+      --     see (ATF6) in Note [Apartness and type families]+      -- (Only worth doing this if we are not under a forall.)+      | um_unif env+      , NotSwapped <- swapped+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco)++      | otherwise   -- See (ATF5) in Note [Apartness and type families]+      = surelyApart++      where+        rhs = ty2 `mkCastTy` mkSymCo kco++    -----------------------------+    -- go_fam_fam: LHS and RHS are both saturated type-family applications,+    --             for the same type-family F+    go_fam_fam substs tc tys1 tys2 kco+       -- Decompose (F tys1 ~ F tys2): (ATF9)+       -- Use injectivity information of F: (ATF10)+       -- But first bind the type-fam if poss: (ATF11)+      = do { bind_fam_if_poss                 -- (ATF11)+           ; unify_tys env inj_tys1 inj_tys2  -- (ATF10)+           ; unless (um_inj_tf env) $         -- (ATF12)+             don'tBeSoSure MARTypeFamily $    -- (ATF9-1)+             unify_tys env noninj_tys1 noninj_tys2 }+     where+       inj = case tyConInjectivityInfo tc of+                NotInjective -> repeat False+                Injective bs -> bs++       (inj_tys1, noninj_tys1) = partitionByList inj tys1+       (inj_tys2, noninj_tys2) = partitionByList inj tys2++       bind_fam_if_poss+         | not (um_unif env)  -- Not when matching (ATF11-1)+         = return ()+         | under_forall       -- Not under a forall (ATF3)+         = return ()+         | BindMe <- um_bind_fam_fun env tc tys1 rhs1+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $+           extendFamEnv tc tys1 rhs1+         -- At this point um_unif=True, so we can unify either way+         | BindMe <- um_bind_fam_fun env tc tys2 rhs2+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $+           extendFamEnv tc tys2 rhs2+         | otherwise+         = return ()++       rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco+       rhs2 = mkTyConApp tc tys1 `mkCastTy` kco+++uOccursCheck :: UMState+             -> TyVarSet -- Bound by enclosing foralls; see (OCU1)+             -> CanEqLHS -> Type   -- Can we unify (lhs := ty)?+             -> Bool+-- See Note [The occurs check in the Core unifier] and (ATF13)+uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty+  = go bvs ty+  where+    go :: TyCoVarSet   -- Bound by enclosing foralls; see (OCU1)+       -> Type -> Bool+    go bvs ty | Just ty' <- coreView ty = go bvs ty'+    go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv+                        = go bvs ty'+                        | TyVarLHS tv' <- lhs, tv==tv'+                        = True+                        | otherwise+                        = go bvs (tyVarKind tv)+    go bvs (AppTy ty1 ty2)           = go bvs ty1 || go bvs ty2+    go _   (LitTy {})                = False+    go bvs (FunTy _ w arg res)       = go bvs w || go bvs arg || go bvs res+    go bvs (TyConApp tc tys)         = go_tc bvs tc tys++    go bvs (ForAllTy (Bndr tv _) ty)+      = go bvs (tyVarKind tv) ||+        (case lhs of+           TyVarLHS tv' | tv==tv'   -> False  -- Shadowing+                        | otherwise -> go (bvs `extendVarSet` tv) ty+           TyFamLHS {} -> False)  -- Lookups don't happen under a forall++    go bvs (CastTy ty  _co) = go bvs ty  -- ToDo: should we worry about `co`?+    go _   (CoercionTy _co) = False      -- ToDo: should we worry about `co`?++    go_tc bvs tc tys+      | isEmptyVarSet bvs   -- Never look up in um_fam_env under a forall (ATF3)+      , isTypeFamilyTyCon tc+      , Just ty' <- lookupFamEnv fam_env tc (take arity tys)+             -- NB: we look up /un-substituted/ types;+             -- See Note [Shortcomings of the apartness test]+      = go bvs ty' || any (go bvs) (drop arity tys)++      | TyFamLHS tc' tys' <- lhs+      , tc == tc'+      , tys `lengthAtLeast` arity  -- Saturated, or over-saturated+      , tcEqTyConAppArgs tys tys'+      = True++      | otherwise+      = any (go bvs) tys+      where+        arity = tyConArity tc++{- Note [The occurs check in the Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes,+so we'll get an infinite loop if we have, for example+    um_tv_env:   a :-> F b      -- (1)+    um_fam_env   F b :-> a      -- (2)++So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty`+could lead to a loop. That is, could there by a type `s` such that+  applySubsts( (substs + lhs:->ty), s ) is infinite++It's vital that we do both at once: we might have (1) already and add (2);+or we might have (2) already and add (1).++A very similar task is done by GHC.Tc.Utils.Unify.checkTyEqRhs.++(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive+  under a forall; indeed it is /unsound/ to consult it because we may have a binding+  (F a :-> Int), and then unify (forall a. ...(F a)...) with something.  We don't+  want to map that (F a) to Int!++(OCU2) Performance. Consider unifying+         [a, b] ~ [big-ty, (a,a,a)]+  We'll unify a:=big-ty.  Then we'll attempt b:=(a,a,a), but must do an occurs check.+  So we'll walk over big-ty, looking for `b`.  And then again, and again, once for+  each occurrence of `a`.  A similar thing happens for+         [a, (b,b,b)] ~ [big-ty, (a,a,a)]+  albeit a bit less obviously.++  Potentially we could use a cache to record checks we have already done;+  but I have not attempted that yet.  Precisely similar remarks would apply+  to GHC.Tc.Utils.Unify.checkTyEqRhs++Note [Unifying coercion-foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we try to unify (forall cv. t1) ~ (forall cv. t2).+See Note [ForAllTy] in GHC.Core.TyCo.Rep.++The problem with coercion variables is that coercion abstraction is not erased:+the `kco` shouldn't propagate from outside the ForAllTy to inside. Instead, I think+the correct new `kco` for the recursive call is `mkNomReflCo liftedTypeKind` (but I'm+a little worried it might be Constraint sometimes).++This potential problem has been there a long time, and I'm going to let+sleeping dogs lie for now.+-}++{-+************************************************************************+*                                                                      *+                Unification monad+*                                                                      *+************************************************************************+-}++data UMEnv+  = UMEnv { um_unif :: AmIUnifying++          , um_inj_tf :: Bool+            -- Checking for injectivity?+            -- See (SI1) in Note [Specification of unification]++          , um_arr_mult :: MultiplicityFlag+            -- Whether to unify multiplicity arguments when unifying arrows.+            -- See Note [Rewrite rules ignore multiplicities in FunTy]++          , um_rn_env :: RnEnv2+            -- Renaming InTyVars to OutTyVars; this eliminates shadowing, and+            -- lines up matching foralls on the left and right+            -- See (CU2) in Note [The Core unifier]++          , um_foralls :: TyVarSet+            -- OutTyVars bound by a forall in this unification;+            -- Do not bind these in the substitution!+            -- See the function tvBindFlag++          , um_bind_tv_fun :: BindTvFun+            -- User-supplied BindFlag function, for variables not in um_foralls+            -- See (CU1) in Note [The Core unifier]++          , um_bind_fam_fun :: BindFamFun+            -- Similar to um_bind_tv_fun, but for type-family applications+            -- See (ATF8) in Note [Apartness and type families]+          }++type FamSubstEnv = TyConEnv (ListMap TypeMap Type)+  -- Map a TyCon and a list of types to a type+  -- Domain of FamSubstEnv is exactly-saturated type-family+  -- applications (F t1...tn)++lookupFamEnv :: FamSubstEnv -> TyCon -> [Type] -> Maybe Type+lookupFamEnv env tc tys+  = do { tys_map <- lookupTyConEnv env tc+       ; lookupTM tys tys_map }++data UMState = UMState+                   { um_tv_env   :: TvSubstEnv+                   , um_cv_env   :: CvSubstEnv+                   , um_fam_env  :: FamSubstEnv }+  -- um_tv_env, um_cv_env, um_fam_env are all "global" substitutions;+  -- that is, neither their domains nor their ranges mention any variables+  -- in um_foralls; i.e. variables bound by foralls inside the types being unified++  -- When /matching/ um_fam_env is usually empty; but not quite always.+  -- See (ATF7) of Note [Apartness and type families]++newtype UM a+  = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }+    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad++pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern UM m <- UM' m+  where+    UM m = UM' (oneShot m)+{-# COMPLETE UM #-}++instance Functor UM where+  fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s))++instance Applicative UM where+      pure a = UM (\s -> pure (s, a))+      (<*>)  = ap++instance Monad UM where+  {-# INLINE (>>=) #-}+  -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad+  m >>= k  = UM (\state ->+                  do { (state', v) <- unUM m state+                     ; unUM (k v) state' })++instance MonadFail UM where+    fail _   = UM (\_ -> SurelyApart) -- failed pattern match++initUM :: TvSubstEnv  -- subst to extend+       -> CvSubstEnv+       -> UM ()+       -> UnifyResultM (TvSubstEnv, CvSubstEnv)+initUM subst_env cv_subst_env um+  = case unUM um state of+      Unifiable (state, _)    -> Unifiable (get state)+      MaybeApart r (state, _) -> MaybeApart r (get state)+      SurelyApart             -> SurelyApart+  where+    state = UMState { um_tv_env = subst_env+                    , um_cv_env = cv_subst_env+                    , um_fam_env = emptyTyConEnv }+    get (UMState { um_tv_env = tv_env, um_cv_env = cv_env }) = (tv_env, cv_env)++getTvSubstEnv :: UM TvSubstEnv+getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)++getCvSubstEnv :: UM CvSubstEnv+getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)++getSubstEnvs :: UM UMState+getSubstEnvs = UM $ \state -> Unifiable (state, state)++getSubst :: UMEnv -> UM Subst+getSubst env = do { tv_env <- getTvSubstEnv+                  ; cv_env <- getCvSubstEnv+                  ; let in_scope = rnInScopeSet (um_rn_env env)+                  ; return (mkTCvSubst in_scope tv_env cv_env) }++extendTvEnv :: TyVar -> Type -> UM ()+extendTvEnv tv ty = UM $ \state ->+  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())++extendCvEnv :: CoVar -> Coercion -> UM ()+extendCvEnv cv co = UM $ \state ->+  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())++extendFamEnv :: TyCon -> [Type] -> Type -> UM ()+extendFamEnv tc tys ty = UM $ \state ->+  Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ())+  where+    extend :: FamSubstEnv -> TyCon -> FamSubstEnv+    extend = alterTyConEnv alter_tm++    alter_tm :: Maybe (ListMap TypeMap Type) -> Maybe (ListMap TypeMap Type)+    alter_tm m_elt = Just (alterTM tys (\_ -> Just ty) (m_elt `orElse` emptyTM))++umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv+umRnBndr2 env v1 v2+  = env { um_rn_env = rn_env', um_foralls = um_foralls env `extendVarSet` v' }+  where+    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2++mentionsForAllBoundTyVarsL, mentionsForAllBoundTyVarsR :: UMEnv -> VarSet -> Bool+-- See (CU2) in Note [The Core unifier]+mentionsForAllBoundTyVarsL = mentions_forall_bound_tvs inRnEnvL+mentionsForAllBoundTyVarsR = mentions_forall_bound_tvs inRnEnvR++mentions_forall_bound_tvs :: (RnEnv2 -> TyVar -> Bool) -> UMEnv -> VarSet -> Bool+mentions_forall_bound_tvs in_rn_env env varset+  | isEmptyVarSet (um_foralls env)               = False+  | anyVarSet (in_rn_env (um_rn_env env)) varset = True+  | otherwise                                    = False+    -- NB: That isEmptyVarSet guard is a critical optimization;+    -- it means we don't have to calculate the free vars of+    -- the type, often saving quite a bit of allocation.++-- | Converts any SurelyApart to a MaybeApart+don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()+don'tBeSoSure r um = UM $ \ state ->+  case unUM um state of+    SurelyApart -> MaybeApart r (state, ())+    other       -> other++umRnOccL :: UMEnv -> TyVar -> TyVar+umRnOccL env v = rnOccL (um_rn_env env) v++umRnOccR :: UMEnv -> TyVar -> TyVar+umRnOccR env v = rnOccR (um_rn_env env) v++umSwapRn :: UMEnv -> UMEnv+umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }++maybeApart :: MaybeApartReason -> UM ()+maybeApart r = UM (\state -> MaybeApart r (state, ()))++surelyApart :: UM a+surelyApart = UM (\_ -> SurelyApart)++{-+%************************************************************************+%*                                                                      *+            Matching a (lifted) type against a coercion+%*                                                                      *+%************************************************************************++This section defines essentially an inverse to liftCoSubst. It is defined+here to avoid a dependency from Coercion on this module.++-}++data MatchEnv = ME { me_tmpls :: TyVarSet+                   , me_env   :: RnEnv2 }++-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if+--   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,+--   where @==@ there means that the result of 'liftCoSubst' has the same+--   type as the original co; but may be different under the hood.+--   That is, it matches a type against a coercion of the same+--   "shape", and returns a lifting substitution which could have been+--   used to produce the given coercion from the given type.+--   Note that this function is incomplete -- it might return Nothing+--   when there does indeed exist a possible lifting context.+--+-- This function is incomplete in that it doesn't respect the equality+-- in `eqType`. That is, it's possible that this will succeed for t1 and+-- fail for t2, even when t1 `eqType` t2. That's because it depends on+-- there being a very similar structure between the type and the coercion.+-- This incompleteness shouldn't be all that surprising, especially because+-- it depends on the structure of the coercion, which is a silly thing to do.+--+-- The lifting context produced doesn't have to be exacting in the roles+-- of the mappings. This is because any use of the lifting context will+-- also require a desired role. Thus, this algorithm prefers mapping to+-- nominal coercions where it can do so.+liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext+liftCoMatch tmpls ty co+  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co+       ; cenv2 <- ty_co_match menv cenv1       ty co+                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)+       ; return (LC (mkEmptySubst in_scope) cenv2) }+  where+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)+    -- Like tcMatchTy, assume all the interesting variables+    -- in ty are in tmpls++    ki       = typeKind ty+    ki_co    = promoteCoercion co+    ki_ki_co = mkNomReflCo liftedTypeKind++    Pair co_lkind co_rkind = coercionKind ki_co++-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.+ty_co_match :: MatchEnv   -- ^ ambient helpful info+            -> LiftCoEnv  -- ^ incoming subst+            -> Type       -- ^ ty, type to match+            -> Coercion   -- ^ co :: lty ~r rty, coercion to match against+            -> Coercion   -- ^ :: kind(lsubst(ty)) ~N kind(lty)+            -> Coercion   -- ^ :: kind(rsubst(ty)) ~N kind(rty)+            -> Maybe LiftCoEnv+   -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles.+   -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty,+   -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env)+ty_co_match menv subst ty co lkco rkco+  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco++  -- handle Refl case:+  | tyCoVarsOfType ty `isNotInDomainOf` subst+  , Just (ty', _) <- isReflCo_maybe co+  , ty `eqType` ty'+    -- Why `eqType` and not `tcEqType`? Because this function is only used+    -- during coercion optimisation, after type-checking has finished.+  = Just subst++  where+    isNotInDomainOf :: VarSet -> VarEnv a -> Bool+    isNotInDomainOf set env+      = noneSet (\v -> elemVarEnv v env) set++    noneSet :: (Var -> Bool) -> VarSet -> Bool+    noneSet f = allVarSet (not . f)++ty_co_match menv subst ty co lkco rkco+  | CastTy ty' co' <- ty+     -- See Note [Matching in the presence of casts (1)]+  = let empty_subst  = mkEmptySubst (rnInScopeSet (me_env menv))+        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'+        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'+    in+    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)+                                  (substed_co_r `mkTransCo` rkco)++  | SymCo co' <- co+  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco++  -- Match a type variable against a non-refl coercion+ty_co_match menv subst (TyVarTy tv1) co lkco rkco+  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1+  = if eqCoercionX (nukeRnEnvL rn_env) co1' co+    then Just subst+    else Nothing       -- no match since tv1 matches two different coercions++  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var+  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)+    then Nothing      -- occurs check failed+    else Just $ extendVarEnv subst tv1' $+                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)++  | otherwise+  = Nothing++  where+    rn_env = me_env menv+    tv1' = rnOccL rn_env tv1++  -- just look through SubCo's. We don't really care about roles here.+ty_co_match menv subst ty (SubCo co) lkco rkco+  = ty_co_match menv subst ty co lkco rkco++ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco+  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]+ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco+  | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+       -- yes, the one from Type, not TcType; this is for coercion optimization+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]++ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco+  = ty_co_match_tc menv subst tc1 tys tc2 cos++ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })+            (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco+  = ty_co_match_args menv subst [w,    rep1,    rep2,    ty1, ty2]+                                [co_w, co1_rep, co2_rep, co1, co2]+  where+     rep1    = getRuntimeRep ty1+     rep2    = getRuntimeRep ty2+     co1_rep = mkRuntimeRepCo co1+     co2_rep = mkRuntimeRepCo co2+    -- NB: we include the RuntimeRep arguments in the matching;+    --     not doing so caused #21205.++ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)+                       (ForAllCo tv2 vis1c vis2c kind_co2 co2)+                       lkco rkco+  | isTyVar tv1 && isTyVar tv2+  , vis1t == vis1c && vis1c == vis2c -- Is this necessary?+      -- Is this visibility check necessary?  @rae says: yes, I think the+      -- check is necessary, if we're caring about visibility (and we are).+      -- But ty_co_match is a dark and not important corner.+  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2+                               ki_ki_co ki_ki_co+       ; let rn_env0 = me_env menv+             rn_env1 = rnBndr2 rn_env0 tv1 tv2+             menv'   = menv { me_env = rn_env1 }+       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }+  where+    ki_ki_co = mkNomReflCo liftedTypeKind++-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)+--                        (ForAllCo cv2 kind_co2 co2)+--                        lkco rkco+--   | isCoVar cv1 && isCoVar cv2+--   We seems not to have enough information for this case+--   1. Given:+--        cv1      :: (s1 :: k1) ~r (s2 :: k2)+--        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)+--        eta1      = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2)+--                 :: s1' ~ t1+--        eta2      = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2)+--                 :: s2' ~ t2+--      Wanted:+--        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2+--        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4+--      Question: How do we get kcoi?+--   2. Given:+--        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep+--        rkco :: <*>+--      Wanted:+--        ty_co_match menv' subst2 ty1 co2 lkco' rkco'+--      Question: How do we get lkco' and rkco'?++ty_co_match _ subst (CoercionTy {}) _ _ _+  = Just subst -- don't inspect coercions++ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco+  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)++ty_co_match menv subst ty co1 lkco rkco+  | Just (CastTy t co, r) <- isReflCo_maybe co1+  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us+  -- t |> co ~ t ; <t> ; t ~ t |> co+  -- But transitive coercions are not helpful. Therefore we deal+  -- with it here: we do recursion on the smaller reflexive coercion,+  -- while propagating the correct kind coercions.+  = let kco' = mkSymCo co+    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')+                                                (rkco `mkTransCo` kco')++ty_co_match menv subst ty co lkco rkco+  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco+  | otherwise               = Nothing++ty_co_match_tc :: MatchEnv -> LiftCoEnv+               -> TyCon -> [Type]+               -> TyCon -> [Coercion]+               -> Maybe LiftCoEnv+ty_co_match_tc menv subst tc1 tys1 tc2 cos2+  = do { guard (tc1 == tc2)+       ; ty_co_match_args menv subst tys1 cos2 }++ty_co_match_app :: MatchEnv -> LiftCoEnv+                -> Type -> [Type] -> Coercion -> [Coercion]+                -> Maybe LiftCoEnv+ty_co_match_app menv subst ty1 ty1args co2 co2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (co2', co2a) <- splitAppCo_maybe co2+  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)++  | otherwise+  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co+       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2+       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco+       ; ty_co_match_args menv subst2 ty1args co2args }+  where+    ki1 = typeKind ty1+    ki2 = promoteCoercion co2+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion]+                 -> Maybe LiftCoEnv+ty_co_match_args menv subst (ty:tys) (arg:args)+  = do { let Pair lty rty = coercionKind arg+             lkco = mkNomReflCo (typeKind lty)+             rkco = mkNomReflCo (typeKind rty)+       ; subst' <- ty_co_match menv subst ty arg lkco rkco+       ; ty_co_match_args menv subst' tys args }+ty_co_match_args _    subst []       [] = Just subst+ty_co_match_args _    _     _        _  = Nothing++pushRefl :: Coercion -> Maybe Coercion+pushRefl co =+  case (isReflCo_maybe co) of+    Just (AppTy ty1 ty2, Nominal)+      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))+    Just (FunTy af w ty1 ty2, r)+      ->  Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2))+    Just (TyConApp tc tys, r)+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))+    Just (ForAllTy (Bndr tv vis) ty, r)+      -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis+                        , fco_kind = mkNomReflCo (varType tv)+                        , fco_body = mkReflCo r ty })+    _ -> Nothing
+ GHC/Core/UsageEnv.hs view
@@ -0,0 +1,116 @@+module GHC.Core.UsageEnv+  ( Usage(..)+  , UsageEnv+  , addUE+  , addUsage+  , bottomUE+  , deleteUE+  , lookupUE+  , popUE+  , scaleUE+  , scaleUsage+  , supUE+  , supUEs+  , singleUsageUE+  , zeroUE+  ) where++import Data.Foldable+import GHC.Prelude+import GHC.Core.Multiplicity+import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Utils.Outputable+import GHC.Utils.Panic++--+-- * Usage environments+--++-- The typechecker and the linter output usage environments. See Note [Usages]+-- in Multiplicity. Every absent name being considered to map to 'Zero' of+-- 'Bottom' depending on a flag. See Note [Zero as a usage] in Multiplicity, see+-- Note [Bottom as a usage] in Multiplicity.++data Usage = Zero | Bottom | MUsage Mult++instance Outputable Usage where+  ppr Zero = text "0"+  ppr Bottom = text "Bottom"+  ppr (MUsage x) = ppr x++addUsage :: Usage -> Usage -> Usage+addUsage Zero x = x+addUsage x Zero = x+addUsage Bottom x = x+addUsage x Bottom = x+addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y++scaleUsage :: Mult -> Usage -> Usage+scaleUsage OneTy Bottom     = Bottom+scaleUsage _     Zero       = Zero+scaleUsage x     Bottom     = MUsage x+scaleUsage x     (MUsage y) = MUsage $ mkMultMul x y++-- For now, we use extra multiplicity Bottom for empty case.+data UsageEnv = UsageEnv !(NameEnv Mult) Bool++-- | Record a single usage of an Id, i.e. {n: 1}+-- Exception: We do not record external names (both GlobalIds and top-level LocalIds)+-- because they're not relevant to linearity checking.+singleUsageUE :: Id -> UsageEnv+singleUsageUE x | isExternalName n = zeroUE+                | otherwise = UsageEnv (unitNameEnv n OneTy) False+  where n = getName x++zeroUE, bottomUE :: UsageEnv+zeroUE = UsageEnv emptyNameEnv False++bottomUE = UsageEnv emptyNameEnv True++addUE :: UsageEnv -> UsageEnv -> UsageEnv+addUE (UsageEnv e1 b1) (UsageEnv e2 b2) =+  UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2)++scaleUE :: Mult -> UsageEnv -> UsageEnv+scaleUE OneTy ue = ue+scaleUE w (UsageEnv e _) =+  UsageEnv (mapNameEnv (mkMultMul w) e) False++supUE :: UsageEnv -> UsageEnv -> UsageEnv+supUE (UsageEnv e1 False) (UsageEnv e2 False) =+  UsageEnv (plusNameEnv_CD mkMultSup e1 ManyTy e2 ManyTy) False+supUE (UsageEnv e1 b1) (UsageEnv e2 b2) = UsageEnv (plusNameEnv_CD2 combineUsage e1 e2) (b1 && b2)+   where combineUsage (Just x) (Just y) = mkMultSup x y+         combineUsage Nothing  (Just x) | b1        = x+                                        | otherwise = ManyTy+         combineUsage (Just x) Nothing  | b2        = x+                                        | otherwise = ManyTy+         combineUsage Nothing  Nothing  = pprPanic "supUE" (ppr e1 <+> ppr e2)+-- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well.++-- Used with @f = '[]'@ and @f = 'NonEmpty'@+supUEs :: Foldable f => f UsageEnv -> UsageEnv+supUEs = foldr supUE bottomUE++-- INLINE to ensure specialization at use site, and to avoid multiple specialization on the same+-- type+{-# INLINE supUEs #-}++deleteUE :: NamedThing n => UsageEnv -> n -> UsageEnv+deleteUE (UsageEnv e b) x = UsageEnv (delFromNameEnv e (getName x)) b++-- | |lookupUE x env| returns the multiplicity assigned to |x| in |env|, if |x| is not+-- bound in |env|, then returns |Zero| or |Bottom|.+lookupUE :: NamedThing n => UsageEnv -> n -> Usage+lookupUE (UsageEnv e has_bottom) x =+  case lookupNameEnv e (getName x) of+    Just w  -> MUsage w+    Nothing -> if has_bottom then Bottom else Zero++popUE :: NamedThing n => UsageEnv -> n -> (Usage, UsageEnv)+popUE ue x = (lookupUE ue x, deleteUE ue x)++instance Outputable UsageEnv where+  ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b
+ GHC/Core/Utils.hs view
@@ -0,0 +1,3066 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Utility functions on @Core@ syntax+-}++-- | Commonly useful utilities for manipulating the Core language+module GHC.Core.Utils (+        -- * Constructing expressions+        mkCast, mkCastMCo, mkPiMCo,+        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,+        bindNonRec, needsCaseBinding, needsCaseBindingL,+        mkAltExpr, mkDefaultCase, mkSingleAltCase,++        -- * Taking expressions apart+        findDefault, addDefault, findAlt, isDefaultAlt,+        mergeAlts, mergeCaseAlts, trimConArgs,+        filterAlts, combineIdenticalAlts, refineDefaultAlt,+        scaleAltsBy,++        -- * Properties of expressions+        exprType, coreAltType, coreAltsType,+        mkLamType, mkLamTypes,+        mkFunctionType,+        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,+        trivial_expr_fold,+        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,+        exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval,+        exprIsWorkFree, exprIsConLike,+        isCheapApp, isExpandableApp, isSaturatedConApp,+        exprIsTickedString, exprIsTickedString_maybe,+        exprIsTopLevelBindable,+        exprIsUnaryClassFun, isUnaryClassId,+        altsAreExhaustive, etaExpansionTick,++        -- * Equality+        cheapEqExpr, cheapEqExpr', diffBinds,++        -- * Manipulating data constructors and types+        exprToType,+        applyTypeToArgs,+        dataConRepInstPat, dataConRepFSInstPat,+        isEmptyTy, normSplitTyConApp_maybe,++        -- * Working with ticks+        stripTicksTop, stripTicksTopE, stripTicksTopT,+        stripTicksE, stripTicksT,++        -- * InScopeSet things which work over CoreBinds+        mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,++        -- * StaticPtr+        collectMakeStaticArgs,++        -- * Join points+        isJoinBind,++        -- * Tag inference+        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,++        -- * unsafeEqualityProof+        isUnsafeEqualityCase,++        -- * Dumping stuff+        dumpIdInfoOfProgram+    ) where++import GHC.Prelude+import GHC.Platform++import GHC.Core+import GHC.Core.Ppr+import GHC.Core.FVs( bindFreeVars )+import GHC.Core.DataCon+import GHC.Core.Type as Type+import GHC.Core.Predicate( isEqPred )+import GHC.Core.Predicate( isUnaryClass )+import GHC.Core.FamInstEnv+import GHC.Core.TyCo.Compare( eqType, eqTypeX )+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.TyCon+import GHC.Core.Multiplicity++import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey )+import GHC.Builtin.PrimOps++import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic( Arity )+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Demand+import GHC.Types.RepType (isZeroBitTy)++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.List.SetOps( minusList )+import GHC.Data.OrdList++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.ByteString     ( ByteString )+import Data.Function       ( on )+import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )+import qualified Data.List as Partial ( init, last )+import Data.Ord            ( comparing )+import Control.Monad       ( guard )+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+\subsection{Find the type of a Core atom/expression}+*                                                                      *+************************************************************************+-}++exprType :: HasDebugCallStack => CoreExpr -> Type+-- ^ Recover the type of a well-typed Core expression. Fails when+-- applied to the actual 'GHC.Core.Type' expression as it cannot+-- really be said to have a type+exprType (Var var)           = idType var+exprType (Lit lit)           = literalType lit+exprType (Coercion co)       = coercionType co+exprType (Let bind body)+  | NonRec tv rhs <- bind    -- See Note [Type bindings]+  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)+  | otherwise                = exprType body+exprType (Case _ _ ty _)     = ty+exprType (Cast _ co)         = coercionRKind co+exprType (Tick _ e)          = exprType e+exprType (Lam binder expr)   = mkLamType binder (exprType expr)+exprType e@(App _ _)+  = case collectArgs e of+        (fun, args) -> applyTypeToArgs (exprType fun) args+exprType (Type ty) = pprPanic "exprType" (ppr ty)++coreAltType :: CoreAlt -> Type+-- ^ Returns the type of the alternatives right hand side+coreAltType alt@(Alt _ bs rhs)+  = case occCheckExpand bs rhs_ty of+      -- Note [Existential variables and silly type synonyms]+      Just ty -> ty+      Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty)+  where+    rhs_ty = exprType rhs++coreAltsType :: [CoreAlt] -> Type+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives+coreAltsType (alt:_) = coreAltType alt+coreAltsType []      = panic "coreAltsType"++mkLamType  :: HasDebugCallStack => Var -> Type -> Type+-- ^ Makes a @(->)@ type or an implicit forall type, depending+-- on whether it is given a type variable or a term variable.+-- This is used, for example, when producing the type of a lambda.+--+mkLamTypes :: [Var] -> Type -> Type+-- ^ 'mkLamType' for multiple type or value arguments++mkLamType v body_ty+   | isTyVar v+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty+     -- coreTyLamForAllTyFlag: see Note [Required foralls in Core]+     --                        in GHC.Core.TyCo.Rep++   | isCoVar v+   , v `elemVarSet` tyCoVarsOfType body_ty+     -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty++   | otherwise+   = mkFunctionType (idMult v) (idType v) body_ty++mkLamTypes vs ty = foldr mkLamType ty vs++{-+Note [Type bindings]+~~~~~~~~~~~~~~~~~~~~+Core does allow type bindings, although such bindings are+not much used, except in the output of the desugarer.+Example:+     let a = Int in (\x:a. x)+Given this, exprType must be careful to substitute 'a' in the+result type (#8522).++Note [Existential variables and silly type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. T (Funny a)+        type Funny a = Bool+        f :: T -> Bool+        f (T x) = x++Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.+That means that 'exprType' and 'coreAltsType' may give a result that *appears*+to mention an out-of-scope type variable.  See #3409 for a more real-world+example.++Various possibilities suggest themselves:++ - Ignore the problem, and make Lint not complain about such variables++ - Expand all type synonyms (or at least all those that discard arguments)+      This is tricky, because at least for top-level things we want to+      retain the type the user originally specified.++ - Expand synonyms on the fly, when the problem arises. That is what+   we are doing here.  It's not too expensive, I think.++Note that there might be existentially quantified coercion variables, too.+-}++applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type+-- ^ Determines the type resulting from applying an expression with given type+--- to given argument expressions.+applyTypeToArgs op_ty args+  = go op_ty args+  where+    go op_ty []                   = op_ty+    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args+    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args+    go op_ty (_ : args)           | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty+                                  = go res_ty args+    go _ args = pprPanic "applyTypeToArgs" (panic_msg args)++    -- go_ty_args: accumulate type arguments so we can+    -- instantiate all at once with piResultTys+    go_ty_args op_ty rev_tys (Type ty : args)+       = go_ty_args op_ty (ty:rev_tys) args+    go_ty_args op_ty rev_tys (Coercion co : args)+       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args+    go_ty_args op_ty rev_tys args+       = go (piResultTys op_ty (reverse rev_tys)) args++    panic_msg as = vcat [ text "Type:" <+> ppr op_ty+                        , text "Args:" <+> ppr args+                        , text "Args':" <+> ppr as ]++mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr+mkCastMCo e MRefl    = e+mkCastMCo e (MCo co) = Cast e co+  -- We are careful to use (MCo co) only when co is not reflexive+  -- Hence (Cast e co) rather than (mkCast e co)++mkPiMCo :: Var -> MCoercionR -> MCoercionR+mkPiMCo _  MRefl   = MRefl+mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)+++{- *********************************************************************+*                                                                      *+             Casts+*                                                                      *+********************************************************************* -}++-- | Wrap the given expression in the coercion safely, dropping+-- identity coercions and coalescing nested coercions+mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr++mkCast expr co+  = assertPpr (coercionRole co == Representational)+              (text "coercion" <+> ppr co <+> text "passed to mkCast"+               <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $+    warnPprTrace (not (coercionLKind co `eqType` exprType expr))+          "Trying to coerce" (text "(" <> ppr expr+          $$ text "::" <+> ppr (exprType expr) <> text ")"+          $$ ppr co $$ ppr (coercionType co)+          $$ callStackDoc) $+    case expr of+      Cast expr co2 -> mkCast expr (mkTransCo co2 co)+      Tick t expr   -> Tick t (mkCast expr co)++      Coercion e_co | isEqPred (coercionRKind co)+         -- The guard here checks that g has a (~#) on both sides,+         -- otherwise decomposeCo fails.  Can in principle happen+         -- with unsafeCoerce+                      -> Coercion (mkCoCast e_co co)++      _ | isReflCo co -> expr+        | otherwise   -> Cast expr co+++{- *********************************************************************+*                                                                      *+             Attaching ticks+*                                                                      *+********************************************************************* -}++-- | Wraps the given expression in the source annotation, dropping the+-- annotation if possible.+mkTick :: CoreTickish -> CoreExpr -> CoreExpr+mkTick t orig_expr = mkTick' id id orig_expr+ where+  -- Some ticks (cost-centres) can be split in two, with the+  -- non-counting part having laxer placement properties.+  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t+  -- mkTick' handles floating of ticks *into* the expression.+  -- In this function, `top` is applied after adding the tick, and `rest` before.+  -- This will result in applications that look like (top $ Tick t $ rest expr).+  -- If we want to push the tick deeper, we pre-compose `top` with a function+  -- adding the tick.+  mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through)+          -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with)+          -> CoreExpr               -- current expression+          -> CoreExpr+  mkTick' top rest expr = case expr of+    -- Float ticks into unsafe coerce the same way we would do with a cast.+    Case scrut bndr ty alts@[Alt ac abs _rhs]+      | Just rhs <- isUnsafeEqualityCase scrut bndr alts+      -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs++    -- Cost centre ticks should never be reordered relative to each+    -- other. Therefore we can stop whenever two collide.+    Tick t2 e+      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr++    -- Otherwise we assume that ticks of different placements float+    -- through each other.+      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e++    -- For annotations this is where we make sure to not introduce+    -- redundant ticks.+      | tickishContains t t2              -> mkTick' top rest e+      | tickishContains t2 t              -> orig_expr+      | otherwise                         -> mkTick' top (rest . Tick t2) e++    -- Ticks don't care about types, so we just float all ticks+    -- through them. Note that it's not enough to check for these+    -- cases top-level. While mkTick will never produce Core with type+    -- expressions below ticks, such constructs can be the result of+    -- unfoldings. We therefore make an effort to put everything into+    -- the right place no matter what we start with.+    Cast e co   -> mkTick' (top . flip Cast co) rest e+    Coercion co -> Coercion co++    Lam x e+      -- Always float through type lambdas. Even for non-type lambdas,+      -- floating is allowed for all but the most strict placement rule.+      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime+      -> mkTick' (top . Lam x) rest e++      -- If it is both counting and scoped, we split the tick into its+      -- two components, often allowing us to keep the counting tick on+      -- the outside of the lambda and push the scoped tick inside.+      -- The point of this is that the counting tick can probably be+      -- floated, and the lambda may then be in a position to be+      -- beta-reduced.+      | canSplit+      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e++    App f arg+      -- Always float through type applications.+      | not (isRuntimeArg arg)+      -> mkTick' (top . flip App arg) rest f++      -- We can also float through constructor applications, placement+      -- permitting. Again we can split.+      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)+      -> if tickishPlace t == PlaceCostCentre+         then top $ rest $ tickHNFArgs t expr+         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr++    Var x+      | notFunction && tickishPlace t == PlaceCostCentre+      -> orig_expr+      | notFunction && canSplit+      -> top $ Tick (mkNoScope t) $ rest expr+      where+        -- SCCs can be eliminated on variables provided the variable+        -- is not a function.  In these cases the SCC makes no difference:+        -- the cost of evaluating the variable will be attributed to its+        -- definition site.  When the variable refers to a function, however,+        -- an SCC annotation on the variable affects the cost-centre stack+        -- when the function is called, so we must retain those.+        notFunction = not (isFunTy (idType x))++    Lit{}+      | tickishPlace t == PlaceCostCentre+      -> orig_expr++    -- Catch-all: Annotate where we stand+    _any -> top $ Tick t $ rest expr++mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr+mkTicks ticks expr = foldr mkTick expr ticks++isSaturatedConApp :: CoreExpr -> Bool+isSaturatedConApp e = go e []+  where go (App f a) as = go f (a:as)+        go (Var fun) args+           = isConLikeId fun && idArity fun == valArgCount args+        go (Cast f _) as = go f as+        go _ _ = False++mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr+mkTickNoHNF t e+  | exprIsHNF e = tickHNFArgs t e+  | otherwise   = mkTick t e++-- push a tick into the arguments of a HNF (call or constructor app)+tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr+tickHNFArgs t e = push t e+ where+  push t (App f (Type u)) = App (push t f) (Type u)+  push t (App f arg) = App (push t f) (mkTick t arg)+  push _t e = e++-- | Strip ticks satisfying a predicate from top of an expression+stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)+stripTicksTop p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts other            = (reverse ts, other)++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the remaining expression+stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksTopE p = go+  where go (Tick t e) | p t = go e+        go other            = other++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the ticks+stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksTopT p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts _                = ts++-- | Completely strip ticks satisfying a predicate from an+-- expression. Note this is O(n) in the size of the expression!+stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksE p expr = go expr+  where go (App e a)        = App (go e) (go a)+        go (Lam b e)        = Lam b (go e)+        go (Let b e)        = Let (go_bs b) (go e)+        go (Case e b t as)  = Case (go e) b t (map go_a as)+        go (Cast e c)       = Cast (go e) c+        go (Tick t e)+          | p t             = go e+          | otherwise       = Tick t (go e)+        go other            = other+        go_bs (NonRec b e)  = NonRec b (go e)+        go_bs (Rec bs)      = Rec (map go_b bs)+        go_b (b, e)         = (b, go e)+        go_a (Alt c bs e)   = Alt c bs (go e)++stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksT p expr = fromOL $ go expr+  where go (App e a)        = go e `appOL` go a+        go (Lam _ e)        = go e+        go (Let b e)        = go_bs b `appOL` go e+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)+        go (Cast e _)       = go e+        go (Tick t e)+          | p t             = t `consOL` go e+          | otherwise       = go e+        go _                = nilOL+        go_bs (NonRec _ e)  = go e+        go_bs (Rec bs)      = concatOL (map go_b bs)+        go_b (_, e)         = go e+        go_a (Alt _ _ e)    = go e++{-+************************************************************************+*                                                                      *+\subsection{Other expression construction}+*                                                                      *+************************************************************************+-}++bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr+-- ^ @bindNonRec x r b@ produces either:+--+-- > let x = r in b+--+-- or:+--+-- > case r of x { _DEFAULT_ -> b }+--+-- depending on whether we have to use a @case@ or @let@+-- binding for the expression (see 'needsCaseBinding').+-- It's used by the desugarer to avoid building bindings+-- that give Core Lint a heart attack, although actually+-- the simplifier deals with them perfectly well. See+-- also 'GHC.Core.Make.mkCoreLet'+bindNonRec bndr rhs body+  | isTyVar bndr                       = let_bind+  | isCoVar bndr                       = if isCoArg rhs then let_bind+    {- See Note [Binding coercions] -}                  else case_bind+  | isJoinId bndr                      = let_bind+  | needsCaseBinding (idType bndr) rhs = case_bind+  | otherwise                          = let_bind+  where+    case_bind = mkDefaultCase rhs bndr body+    let_bind  = Let (NonRec bndr rhs) body++-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@+-- binding for this expression as per the invariants of 'CoreExpr': see+-- "GHC.Core#let_can_float_invariant"+-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else+-- `typeLevity ty` will fail; but that should be the case because+-- `needsCaseBinding` is only called once typechecking is complete+needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool+needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs++needsCaseBindingL :: Levity -> CoreExpr -> Bool+-- True <=> make a case expression instead of a let+-- These can arise either from the desugarer,+-- or from beta reductions: (\x.e) (x +# y)+needsCaseBindingL Lifted   _rhs = False+needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs)++mkAltExpr :: AltCon     -- ^ Case alternative constructor+          -> [CoreBndr] -- ^ Things bound by the pattern match+          -> [Type]     -- ^ The type arguments to the case alternative+          -> CoreExpr+-- ^ This guy constructs the value that the scrutinee must have+-- given that you are in one particular branch of a case+mkAltExpr (DataAlt con) args inst_tys+  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)+mkAltExpr (LitAlt lit) [] []+  = Lit lit+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"++mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr+-- Make (case x of y { DEFAULT -> e }+mkDefaultCase scrut case_bndr body+  = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]++mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr+-- Use this function if possible, when building a case,+-- because it ensures that the type on the Case itself+-- doesn't mention variables bound by the case+-- See Note [Care with the type of a case expression]+mkSingleAltCase scrut case_bndr con bndrs body+  = Case scrut case_bndr case_ty [Alt con bndrs body]+  where+    body_ty = exprType body++    case_ty -- See Note [Care with the type of a case expression]+      | Just body_ty' <- occCheckExpand bndrs body_ty+      = body_ty'++      | otherwise+      = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty)++{- Note [Care with the type of a case expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a phantom type synonym+   type S a = Int+and we want to form the case expression+   case x of K (a::*) -> (e :: S a)++We must not make the type field of the case-expression (S a) because+'a' isn't in scope.  Hence the call to occCheckExpand.  This caused+issue #17056.++NB: this situation can only arise with type synonyms, which can+falsely "mention" type variables that aren't "really there", and which+can be eliminated by expanding the synonym.++Note [Binding coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider binding a CoVar, c = e.  Then, we must satisfy+Note [Core type and coercion invariant] in GHC.Core,+which allows only (Coercion co) on the RHS.++************************************************************************+*                                                                      *+               Operations over case alternatives+*                                                                      *+************************************************************************++The default alternative must be first, if it exists at all.+This makes it easy to find, though it makes matching marginally harder.+-}++-- | Extract the default case alternative+findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)+findDefault alts                          =                    (alts, Nothing)++addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]+addDefault alts Nothing    = alts+addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts++isDefaultAlt :: Alt b -> Bool+isDefaultAlt (Alt DEFAULT _ _) = True+isDefaultAlt _                 = False++-- | Find the case alternative corresponding to a particular+-- constructor: panics if no such constructor exists+findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)+    -- A "Nothing" result *is* legitimate+    -- See Note [Unreachable code]+findAlt con alts+  = case alts of+        (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt)+        _                              -> go alts Nothing+  where+    go []                     deflt = deflt+    go (alt@(Alt con1 _ _) : alts) deflt+      = case con `cmpAltCon` con1 of+          LT -> deflt   -- Missed it already; the alts are in increasing order+          EQ -> Just alt+          GT -> assert (not (con1 == DEFAULT)) $ go alts deflt++{- Note [Unreachable code]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible (although unusual) for GHC to find a case expression+that cannot match.  For example:++     data Col = Red | Green | Blue+     x = Red+     f v = case x of+              Red -> ...+              _ -> ...(case x of { Green -> e1; Blue -> e2 })...++Suppose that for some silly reason, x isn't substituted in the case+expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff+gets in the way; cf #3118.)  Then the full-laziness pass might produce+this++     x = Red+     lvl = case x of { Green -> e1; Blue -> e2 })+     f v = case x of+             Red -> ...+             _ -> ...lvl...++Now if x gets inlined, we won't be able to find a matching alternative+for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing+we generate (error "Inaccessible alternative").++Similar things can happen (augmented by GADTs) when the Simplifier+filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.+-}++---------------------------------+mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])+-- See Note [Merge Nested Cases]+mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)+  | Just (joins, inner_alts) <- go deflt_rhs+  = Just (joins, mergeAlts outer_alts inner_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!+  where+    go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])++    -- Whizzo: we can merge!+    go (Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       | inner_scrut_var == outer_bndr+       , not (inner_bndr == outer_bndr)   -- Avoid shadowing+       , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs'+                -- inner_bndr is never dead!  It's the scrutinee!+                -- The let is OK even for unboxed binders+                -- See Note [Merge Nested Cases] wrinkle (MC2)+             do_one (Alt con bndrs rhs)+               | any (== outer_bndr) bndrs = Nothing+               | otherwise                 = Just (Alt con bndrs (wrap_let rhs))+       = do { alts' <- mapM do_one inner_alts+            ; return ([], alts') }++    -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3)+    go (App (App (Var f) (Type type_arg)) (Var v))+      | v == outer_bndr+      , Just TagToEnumOp <- isPrimOpId_maybe f+      , Just tc  <- tyConAppTyCon_maybe type_arg+      , Just (dc1:dcs) <- tyConDataCons_maybe tc   -- At least one data constructor+      , dcs `lengthAtMost` 3  -- Arbitrary+      = return ( [], mk_alts dc1 dcs)+      where+        mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc+        mk_rhs dc = Var (dataConWorkId dc)+        mk_alts dc1 dcs =  Alt DEFAULT              [] (mk_rhs dc1)+                        : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs]++    -- Float out let/join bindings+    -- See Note [Merge Nested Cases] wrinkle (MC4)+    go (Let bind body)+      | null outer_alts || isJoinBind bind+      = do { (joins, alts) <- go body++             -- Check for capture; but only if we could otherwise do a merge+           ; let capture = outer_bndr `elem` bindersOf bind+                           || outer_bndr `elemVarSet` bindFreeVars bind+           ; guard (not capture)++           ; return (bind:joins, alts ) }+      | otherwise+      = Nothing++    -- We don't want ticks to get in the way; just push them inwards.+    -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)+    go (Tick t body)+      = do { (joins, alts) <- go body+           ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }++    go _ = Nothing++mergeCaseAlts _ _ = Nothing++---------------------------------+mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]+-- ^ Merge alternatives preserving order; alternatives in+-- the first argument shadow ones in the second+mergeAlts [] as2 = as2+mergeAlts as1 [] = as1+mergeAlts (a1:as1) (a2:as2)+  = case a1 `cmpAlt` a2 of+        LT -> a1 : mergeAlts as1      (a2:as2)+        EQ -> a1 : mergeAlts as1      as2       -- Discard a2+        GT -> a2 : mergeAlts (a1:as1) as2+++---------------------------------+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]+-- ^ Given:+--+-- > case (C a b x y) of+-- >        C b x y -> ...+--+-- We want to drop the leading type argument of the scrutinee+-- leaving the arguments to match against the pattern++trimConArgs DEFAULT      args = assert (null args) []+trimConArgs (LitAlt _)   args = assert (null args) []+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args++filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)+           -> [Type]               -- ^ And its type arguments+           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee+           -> [Alt b] -- ^ Alternatives+           -> ([AltCon], [Alt b])+             -- Returns:+             --  1. Constructors that will never be encountered by the+             --     *default* case (if any).  A superset of imposs_cons+             --  2. The new alternatives, trimmed by+             --        a) remove imposs_cons+             --        b) remove constructors which can't match because of GADTs+             --+             -- NB: the final list of alternatives may be empty:+             -- This is a tricky corner case.  If the data type has no constructors,+             -- which GHC allows, or if the imposs_cons covers all constructors (after taking+             -- account of GADTs), then no alternatives can match.+             --+             -- If callers need to preserve the invariant that there is always at least one branch+             -- in a "case" statement then they will need to manually add a dummy case branch that just+             -- calls "error" or similar.+filterAlts _tycon inst_tys imposs_cons alts+  = imposs_deflt_cons `seqList`+      (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)+  -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which+  -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter+  -- leads to a huge space leak (see #22102 and !8896)+  where+    (alts_wo_default, maybe_deflt) = findDefault alts+    alt_cons = [con | Alt con _ _ <- alts_wo_default]++    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default++    imposs_cons_set = Set.fromList imposs_cons+    imposs_deflt_cons =+      imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons+         -- "imposs_deflt_cons" are handled+         --   EITHER by the context,+         --   OR by a non-DEFAULT branch in this case expression.++    impossible_alt :: [Type] -> Alt b -> Bool+    impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True+    impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con+    impossible_alt _  _                             = False++-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.+-- See Note [Refine DEFAULT case alternatives]+refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders+                 -> Mult              -- ^ Multiplicity annotation of the case expression+                 -> TyCon             -- ^ Type constructor of scrutinee's type+                 -> [Type]            -- ^ Type arguments of scrutinee's type+                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)+                 -> [CoreAlt]+                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'+refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts+  | Alt DEFAULT _ rhs : rest_alts <- all_alts+  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.+  , not (isNewTyCon tycon)      -- Exception 1 in Note [Refine DEFAULT case alternatives]+  , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]+  , Just all_cons <- tyConDataCons_maybe tycon+  , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]+                             -- We now know it's a data type, so we can use+                             -- UniqSet rather than Set (more efficient)+        impossible con   = con `elementOfUniqSet` imposs_data_cons+                             || dataConCannotMatch tys con+  = case filterOut impossible all_cons of+       -- Eliminate the default alternative+       -- altogether if it can't match:+       []    -> (False, rest_alts)++       -- It matches exactly one constructor, so fill it in:+       [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs])+                       -- We need the mergeAlts to keep the alternatives in the right order+             where+                (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys++       -- It matches more than one, so do nothing+       _  -> (False, all_alts)++  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)+        -- Check for no data constructors+        -- This can legitimately happen for abstract types and type families,+        -- so don't report that+  = (False, all_alts)++  | otherwise      -- The common case+  = (False, all_alts)++{- 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 scrutinises the same variable as the outer case. This+transformation is called Case Merging.  It avoids that the same+variable is scrutinised multiple times.++Wrinkles++(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner+     single-alternative case-on-variable. For example+       case x of {+          ...outer-alts...+          DEFAULT -> case y of (a,b) ->+                     case x of { A -> rhs1; B -> rhs2 }+    ===>+       case x of+         ...outer-alts...+         a -> case y of (a,b) -> rhs1+         B -> case y of (a,b) -> rhs2++    This duplicates the `case y` but it removes the case x; so it is a win+    in terms of execution time (combining the cases on x) at the cost of+    perhaps duplicating the `case y`.  A case in point is integerEq, which+    is defined thus+        integerEq :: Integer -> Integer -> Bool+        integerEq !x !y = isTrue# (integerEq# x y)+    which becomes+        integerEq+          = \ (x :: Integer) (y_aAL :: Integer) ->+              case x of x1 { __DEFAULT ->+              case y of y1 { __DEFAULT ->+              case x1 of {+                IS x2 -> case y1 of {+                           __DEFAULT -> GHC.Types.False;+                           IS y2     -> tagToEnum# @Bool (==# x2 y2) };+                IP x2 -> ...+                IN x2 -> ...+    We want to merge the outer `case x` with the inner `case x1`.++    But (a) this is all a bit dubious: see #24251, and+        (b) it is hard to combine with (MC4)+    So I'm not doing this any more.  If we want to do it, we'll handle it+    separately: #24251.++    End of historical note++(MC2) The auxiliary bindings b'=b are annoying, because they force another+      simplifier pass, but there seems no easy way to avoid them.  See+      Note [Which transformations are innocuous] in GHC.Core.Opt.Stats.++(MC3) Consider+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      `mergeCaseAlts` as a special case to treat this as if it was+         case f x of r ->+           case r of { 0# -> False; 1# -> True }+      which can be merged to+         case f x of { 0# -> False; 1# -> True }++      To see why this is important, return to+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      and supppose `f` inlines to a case expression.  Then then we get+         let $j r = tagToEnum# r+         case .. of { .. jump $j 0#; ...jump $j 1# ... }+      Now if the entire expression is consumed by another case-expression,+      that outer case will only see (tagToEnum# r) which it can't do much+      with.  Whereas the result of the above case-merge generates much better+      code: no branching on Int#++(MC4) Consider+          case f x of r ->+            join $j y = <rhs> in+            case r of { ...alts ... }+      This is pretty common, and it a pity for it to defeat the case-merge+      transformation; and it makes the optimiser fragile to inlining decisions+      for join points.++      So `mergeCaseAlts` floats out any join points. It doesn't float out+      non-join-points unless the /outer/ case has just one alternative; doing+      so would risk more allocation++(MC5) See Note [Cascading case merge]++See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because the Simplifier tries it /after/+simplifying (and hence case-merging) the inner case.  For example++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==> {simplify inner case}+      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-merge on outer case}+      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 correct, 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.+++Note [Refine DEFAULT case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+refineDefaultAlt replaces the DEFAULT alt with a constructor if there+is one possible value it could be.++The simplest example being+    foo :: () -> ()+    foo x = case x of !_ -> ()+which rewrites to+    foo :: () -> ()+    foo x = case x of () -> ()++There are two reasons in general why replacing a DEFAULT alternative+with a specific constructor is desirable.++1. We can simplify inner expressions.  For example++       data Foo = Foo1 ()++       test :: Foo -> ()+       test x = case x of+                  DEFAULT -> mid (case x of+                                    Foo1 x1 -> x1)++   refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then+   x becomes bound to `Foo ip1` so is inlined into the other case+   which causes the KnownBranch optimisation to kick in. If we don't+   refine DEFAULT to `Foo ip1`, we are left with both case expressions.++2. combineIdenticalAlts does a better job. For example (Simon Jacobi)+       data D = C0 | C1 | C2++       case e of+         DEFAULT -> e0+         C0      -> e1+         C1      -> e1++   When we apply combineIdenticalAlts to this expression, it can't+   combine the alts for C0 and C1, as we already have a default case.+   But if we apply refineDefaultAlt first, we get+       case e of+         C0 -> e1+         C1 -> e1+         C2 -> e0+   and combineIdenticalAlts can turn that into+       case e of+         DEFAULT -> e1+         C2 -> e0++   It isn't obvious that refineDefaultAlt does this but if you look+   at its one call site in GHC.Core.Opt.Simplify.Utils then the+   `imposs_deflt_cons` argument is populated with constructors which+   are matched elsewhere.++There are two exceptions where we avoid refining a DEFAULT case:++* Exception 1: Newtypes++  We can have a newtype, if we are just doing an eval:++    case x of { DEFAULT -> e }++  And we don't want to fill in a default for them!++* Exception 2: `type data` declarations++  The data constructors for a `type data` declaration (see+  Note [Type data declarations] in GHC.Rename.Module) do not exist at the+  value level. Nevertheless, it is possible to strictly evaluate a value+  whose type is a `type data` declaration. Test case+  type-data/should_compile/T2294b.hs contains an example:++    type data T a where+      A :: T Int++    f :: T a -> ()+    f !x = ()++  We want to generate the following Core for f:++    f = \(@a) (x :: T a) ->+         case x of+           __DEFAULT -> ()++  Namely, we do _not_ want to match on `A`, as it doesn't exist at the value+  level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module+++Note [Combine identical alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If several alternatives are identical, merge them into a single+DEFAULT alternative.  I've occasionally seen this making a big+difference:++     case e of               =====>     case e of+       C _ -> f x                         D v -> ....v....+       D v -> ....v....                   DEFAULT -> f x+       DEFAULT -> f x++The point is that we merge common RHSs, at least for the DEFAULT case.+[One could do something more elaborate but I've never seen it needed.]+To avoid an expensive test, we just merge branches equal to the *first*+alternative; this picks up the common cases+     a) all branches equal+     b) some branches equal to the DEFAULT (which occurs first)++The case where Combine Identical Alternatives transformation showed up+was like this (base/Foreign/C/Err/Error.hs):++        x | p `is` 1 -> e1+          | p `is` 2 -> e2+        ...etc...++where @is@ was something like++        p `is` n = p /= (-1) && p == n++This gave rise to a horrible sequence of cases++        case p of+          (-1) -> $j p+          1    -> e1+          DEFAULT -> $j p++and similarly in cascade for all the join points!++Note [Combine identical alternatives: wrinkles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++* It's important that we try to combine alternatives *before*+  simplifying them, rather than after. Reason: because+  Simplify.simplAlt may zap the occurrence info on the binders in the+  alternatives, which in turn defeats combineIdenticalAlts use of+  isDeadBinder (see #7360).++  You can see this in the call to combineIdenticalAlts in+  GHC.Core.Opt.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt+  (the "In" meaning input) rather than OutAlt.++* combineIdenticalAlts does not work well for nullary constructors+      case x of y+         []    -> f []+         (_:_) -> f y+  Here we won't see that [] and y are the same.  Sigh! This problem+  is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version+  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have+  here.+  See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE).++Note [Care with impossible-constructors when combining alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#10538)+   data T = A | B | C | D++      case x::T of   (Imposs-default-cons {A,B})+         DEFAULT -> e1+         A -> e2+         B -> e1++When calling combineIdentialAlts, we'll have computed that the+"impossible constructors" for the DEFAULT alt is {A,B}, since if x is+A or B we'll take the other alternatives.  But suppose we combine B+into the DEFAULT, to get++      case x::T of   (Imposs-default-cons {A})+         DEFAULT -> e1+         A -> e2++Then we must be careful to trim the impossible constructors to just {A},+else we risk compiling 'e1' wrong!++Not only that, but we take care when there is no DEFAULT beforehand,+because we are introducing one.  Consider++   case x of   (Imposs-default-cons {A,B,C})+     A -> e1+     B -> e2+     C -> e1++Then when combining the A and C alternatives we get++   case x of   (Imposs-default-cons {B})+     DEFAULT -> e1+     B -> e2++Note that we have a new DEFAULT branch that we didn't have before.  So+we need delete from the "impossible-default-constructors" all the+known-con alternatives that we have eliminated. (In #11172 we+missed the first one.)++-}++combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT+                     -> [CoreAlt]+                     -> (Bool,      -- True <=> something happened+                         [AltCon],  -- New constructors that cannot match DEFAULT+                         [CoreAlt]) -- New alternatives+-- See Note [Combine identical alternatives]+-- True <=> we did some combining, result is a single DEFAULT alternative+combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)+  | all isDeadBinder bndrs1    -- Remember the default+  , not (null elim_rest) -- alternative comes first+  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)+  where+    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts+    deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1)++     -- See Note [Care with impossible-constructors when combining alternatives]+    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons+    elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest+    elim_con1 = case con1 of     -- Don't forget con1!+                  DEFAULT -> []+                  _       -> [con1]++    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2+    identical_to_alt1 (Alt _con bndrs rhs)+      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1+    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest++combineIdenticalAlts imposs_cons alts+  = (False, imposs_cons, alts)++-- Scales the multiplicity of the binders of a list of case alternatives. That+-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.+scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]+scaleAltsBy w alts = map scaleAlt alts+  where+    scaleAlt :: CoreAlt -> CoreAlt+    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs++    scaleBndr :: CoreBndr -> CoreBndr+    scaleBndr b = scaleVarBy w b+++{- *********************************************************************+*                                                                      *+             exprIsTrivial+*                                                                      *+************************************************************************++Note [exprIsTrivial]+~~~~~~~~~~~~~~~~~~~~+@exprIsTrivial@ is true of expressions we are unconditionally happy to+                duplicate; simple variables and constants, and type+                applications.  Note that primop Ids aren't considered+                trivial unless++Note [Variables are trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There used to be a gruesome test for (hasNoBinding v) in the+Var case:+        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0+The idea here is that a constructor worker, like \$wJust, is+really short for (\x -> \$wJust x), because \$wJust has no binding.+So it should be treated like a lambda.  Ditto unsaturated primops.+But now constructor workers are not "have-no-binding" Ids.  And+completely un-applied primops and foreign-call Ids are sufficiently+rare that I plan to allow them to be duplicated and put up with+saturating them.++Note [Tick trivial]+~~~~~~~~~~~~~~~~~~~+Ticks are only trivial if they are pure annotations. If we treat+"tick<n> x" as trivial, it will be inlined inside lambdas and the+entry count will be skewed, for example.  Furthermore "scc<n> x" will+turn into just "x" in mkTick. At least if `x` is not a function.++Note [Empty case is trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (case (x::Int) Bool of {}) is just a type-changing+case used when we are sure that 'x' will not return.  See+Note [Empty case alternatives] in GHC.Core.++If the scrutinee is trivial, then so is the whole expression; and the+CoreToSTG pass in fact drops the case expression leaving only the+scrutinee.++Having more trivial expressions is good.  Moreover, if we don't treat+it as trivial we may land up with let-bindings like+   let v = case x of {} in ...+and after CoreToSTG that gives+   let v = x in ...+and that confuses the code generator (#11155). So best to kill+it off at source.+-}++{-# INLINE trivial_expr_fold #-}+trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r+-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]+-- This is meant to have the code of both functions in one place and make it+-- easy to derive custom predicates.+--+-- (trivial_expr_fold k_id k_triv k_not_triv e)+-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)+-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)+-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)+-- * returns k_not_triv otherwise+--+-- where "trivial wrapping" is+-- * Type application or abstraction+-- * Ticks other than `tickishIsCode`+-- * `case e of {}` an empty case+trivial_expr_fold k_id k_lit k_triv k_not_triv = go+  where+    -- If you change this function, be sure to change+    -- SetLevels.notWorthFloating as well!+    -- (Or yet better: Come up with a way to share code with this function.)+    go (Var v)                            = k_id v  -- See Note [Variables are trivial]+    go (Lit l)    | litIsTrivial l        = k_lit l+    go (Type _)                           = k_triv+    go (Coercion _)                       = k_triv+    go (App f arg)+      | not (isRuntimeArg arg)            = go f+      | exprIsUnaryClassFun f             = go arg+      | otherwise                         = k_not_triv+    go (Lam b e)  | not (isRuntimeVar b)  = go e+    go (Tick t e) | not (tickishIsCode t) = go e              -- See Note [Tick trivial]+    go (Cast e _)                         = go e+    go (Case e b _ as)+      | null as+      = go e     -- See Note [Empty case is trivial]+      | Just rhs <- isUnsafeEqualityCase e b as+      = go rhs   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+    go _                                  = k_not_triv++exprIsTrivial :: CoreExpr -> Bool+exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e++{-+Note [getIdFromTrivialExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When substituting in a breakpoint we need to strip away the type cruft+from a trivial expression and get back to the Id.  The invariant is+that the expression we're substituting was originally trivial+according to exprIsTrivial, AND the expression is not a literal.+See Note [substTickish] for how breakpoint substitution preserves+this extra invariant.++We also need this functionality in CorePrep to extract out Id of a+function which we are saturating.  However, in this case we don't know+if the variable actually refers to a literal; thus we use+'getIdFromTrivialExpr_maybe' to handle this case.  See test+T12076lit for an example where this matters.+-}++getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id+-- See Note [getIdFromTrivialExpr]+getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e+  where+    panic = pprPanic "getIdFromTrivialExpr" (ppr e)++getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id+getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e++{- *********************************************************************+*                                                                      *+             exprIsDupable+*                                                                      *+************************************************************************++Note [exprIsDupable]+~~~~~~~~~~~~~~~~~~~~+@exprIsDupable@ is true of expressions that can be duplicated at a modest+                cost in code size.  This will only happen in different case+                branches, so there's no issue about duplicating work.++                That is, exprIsDupable returns True of (f x) even if+                f is very very expensive to call.++                Its only purpose is to avoid fruitless let-binding+                and then inlining of case join points+-}++exprIsDupable :: Platform -> CoreExpr -> Bool+exprIsDupable platform e+  = isJust (go dupAppSize e)+  where+    go :: Int -> CoreExpr -> Maybe Int+    go n (Type {})     = Just n+    go n (Coercion {}) = Just n+    go n (Var {})      = decrement n+    go n (Tick _ e)    = go n e+    go n (Cast e _)    = go n e+    go n (App f a) | Just n' <- go n a = go n' f+    go n (Lit lit) | litIsDupable platform lit = decrement n+    go _ _ = Nothing++    decrement :: Int -> Maybe Int+    decrement 0 = Nothing+    decrement n = Just (n-1)++dupAppSize :: Int+dupAppSize = 8   -- Size of term we are prepared to duplicate+                 -- This is *just* big enough to make test MethSharing+                 -- inline enough join points.  Really it should be+                 -- smaller, and could be if we fixed #4960.++{-+************************************************************************+*                                                                      *+             exprIsCheap, exprIsExpandable+*                                                                      *+************************************************************************++Note [exprIsWorkFree]+~~~~~~~~~~~~~~~~~~~~~+exprIsWorkFree is used when deciding whether to inline something; we+don't inline it if doing so might duplicate work, by peeling off a+complete copy of the expression.  Here we do not want even to+duplicate a primop (#5623):+   eg   let x = a #+ b in x +# x+   we do not want to inline/duplicate x++Previously we were a bit more liberal, which led to the primop-duplicating+problem.  However, being more conservative did lead to a big regression in+one nofib benchmark, wheel-sieve1.  The situation looks like this:++   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool+       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->+         case GHC.Prim.<=# x_aRs 2 of _ {+           GHC.Types.False -> notDivBy ps_adM qs_adN;+           GHC.Types.True -> lvl_r2Eb }}+       go = \x. ...(noFactor (I# y))....(go x')...++The function 'noFactor' is heap-allocated and then called.  Turns out+that 'notDivBy' is strict in its THIRD arg, but that is invisible to+the caller of noFactor, which therefore cannot do w/w and+heap-allocates noFactor's argument.  At the moment (May 12) we are just+going to put up with this, because the previous more aggressive inlining+(which treated 'noFactor' as work-free) was duplicating primops, which+in turn was making inner loops of array calculations runs slow (#5623)++Note [Case expressions are work-free]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Are case-expressions work-free?  Consider+    let v = case x of (p,q) -> p+        go = \y -> ...case v of ...+Should we inline 'v' at its use site inside the loop?  At the moment+we do.  I experimented with saying that case are *not* work-free, but+that increased allocation slightly.  It's a fairly small effect, and at+the moment we go for the slightly more aggressive version which treats+(case x of ....) as work-free if the alternatives are.++Moreover it improves arities of overloaded functions where+there is only dictionary selection (no construction) involved++Note [exprIsCheap]+~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold++@exprIsCheap@ looks at a Core expression and returns \tr{True} if+it is obviously in weak head normal form, or is cheap to get to WHNF.+Note that that's not the same as exprIsDupable; an expression might be+big, and hence not dupable, but still cheap.++By ``cheap'' we mean a computation we're willing to:+        push inside a lambda, or+        inline at more than one place+That might mean it gets evaluated more than once, instead of being+shared.  The main examples of things which aren't WHNF but are+``cheap'' are:++  *     case e of+          pi -> ei+        (where e, and all the ei are cheap)++  *     let x = e in b+        (where e and b are cheap)++  *     op x1 ... xn+        (where op is a cheap primitive operator)++  *     error "foo"+        (because we are happy to substitute it inside a lambda)++Notice that a variable is considered 'cheap': we can push it inside a lambda,+because sharing will make sure it is only evaluated once.++Note [exprIsCheap and exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that exprIsHNF does not imply exprIsCheap.  Eg+        let x = fac 20 in Just x+This responds True to exprIsHNF (you can discard a seq), but+False to exprIsCheap.++Note [Arguments and let-bindings exprIsCheapX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What predicate should we apply to the argument of an application, or the+RHS of a let-binding?++We used to say "exprIsTrivial arg" due to concerns about duplicating+nested constructor applications, but see #4978.  So now we just recursively+use exprIsCheapX.++We definitely want to treat let and app the same.  The principle here is+that+   let x = blah in f x+should behave equivalently to+   f blah++This in turn means that the 'letrec g' does not prevent eta expansion+in this (which it previously was):+    f = \x. let v = case x of+                      True -> letrec g = \w. blah+                              in g+                      False -> \x. x+            in \w. v True+-}++-------------------------------------+type CheapAppFun = Id -> Arity -> Bool+  -- Is an application of this function to n *value* args+  -- always cheap, assuming the arguments are cheap?+  -- True mainly of data constructors, partial applications;+  -- but with minor variations:+  --    isWorkFreeApp+  --    isCheapApp+  --    isExpandableApp++exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool+{-# INLINE exprIsCheapX #-}+-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable+-- instead of having an unknown call to ok_app+-- expandable=True <=> Treat Case and Let as cheap, if their sub-expressions are.+--                     This flag is set for exprIsExpandable+exprIsCheapX ok_app expandable e+  = ok e+  where+    ok e = go 0 e++    -- n is the number of value arguments+    go n (Var v)                      = ok_app v n+    go _ (Lit {})                     = True+    go _ (Type {})                    = True+    go _ (Coercion {})                = True+    go n (Cast e _)                   = go n e+    go n (Case scrut _ _ alts)        = not expandable && ok scrut &&+                                        and [ go n rhs | Alt _ _ rhs <- alts ]+    go n (Tick t e) | tickishCounts t = False+                    | otherwise       = go n e+    go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e+                    | otherwise       = go n e+    go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e+                    | otherwise       = go n f+    go n (Let (NonRec _ r) e)         = not expandable && go n e && ok r+    go n (Let (Rec prs) e)            = not expandable && go n e && all (ok . snd) prs++      -- Case: see Note [Case expressions are work-free]+      -- App, Let: see Note [Arguments and let-bindings exprIsCheapX]++--------------------+exprIsWorkFree :: CoreExpr -> Bool+-- See Note [exprIsWorkFree]+exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e++--------------------+exprIsCheap :: CoreExpr -> Bool+-- See Note [exprIsCheap]+exprIsCheap e = exprIsCheapX isCheapApp False e++--------------------+exprIsExpandable :: CoreExpr -> Bool+-- See Note [exprIsExpandable]+exprIsExpandable e = exprIsCheapX isExpandableApp True e++isWorkFreeApp :: CheapAppFun+isWorkFreeApp fn n_val_args+  | n_val_args == 0           -- No value args+  = True+  | n_val_args < idArity fn   -- Partial application+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      PrimOpId op _    -> primOpIsWorkFree op+      _                -> False++isCheapApp :: CheapAppFun+isCheapApp fn n_val_args+  | isWorkFreeApp fn n_val_args = True+  | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]+  | otherwise+  = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp+      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {}     -> n_val_args == 1+      PrimOpId op _    -> primOpIsCheap op+      _                -> False+        -- In principle we should worry about primops+        -- that return a type variable, since the result+        -- might be applied to something, but I'm not going+        -- to bother to check the number of args++isExpandableApp :: CheapAppFun+isExpandableApp fn n_val_args+  | isWorkFreeApp fn n_val_args = True+  | otherwise+  = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp+      RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {} -> n_val_args == 1+      PrimOpId {}  -> False+      _ | isDeadEndId fn     -> False+          -- See Note [isExpandableApp: bottoming functions]+        | isConLikeId fn     -> True+        | all_args_are_preds -> True+        | otherwise          -> False++  where+     -- See if all the arguments are PredTys (implicit params or classes)+     -- If so we'll regard it as expandable; see Note [Expandable overloadings]+     all_args_are_preds = all_pred_args n_val_args (idType fn)++     all_pred_args n_val_args ty+       | n_val_args == 0+       = True++       | Just (bndr, ty) <- splitPiTy_maybe ty+       = case bndr of+           Named {}  -> all_pred_args n_val_args ty+           Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty++       | otherwise+       = False++{- Note [isCheapApp: bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm not sure why we have a special case for bottoming+functions in isCheapApp.  Maybe we don't need it.++Note [exprIsExpandable]+~~~~~~~~~~~~~~~~~~~~~~~+An expression is "expandable" if we are willing to duplicate it, if doing+so might make a RULE or case-of-constructor fire.  Consider+   let x = (a,b)+       y = build g+   in ....(case x of (p,q) -> rhs)....(foldr k z y)....++We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),+but we do want++ * the case-expression to simplify+   (via exprIsConApp_maybe, exprIsLiteral_maybe)++ * the foldr/build RULE to fire+   (by expanding the unfolding during rule matching)++So we classify the unfolding of a let-binding as "expandable" (via the+uf_expandable field) if we want to do this kind of on-the-fly+expansion.  Specifically:++* True of constructor applications (K a b)++* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.+  (NB: exprIsCheap might not be true of this)++* False of case-expressions.  If we have+    let x = case ... in ...(case x of ...)...+  we won't simplify.  We have to inline x.  See #14688.++* False of let-expressions (same reason); and in any case we+  float lets out of an RHS if doing so will reveal an expandable+  application (see SimplEnv.doFloatFromRhs).++* Take care: exprIsExpandable should /not/ be true of primops.  I+  found this in test T5623a:+    let q = /\a. Ptr a (a +# b)+    in case q @ Float of Ptr v -> ...q...++  q's inlining should not be expandable, else exprIsConApp_maybe will+  say that (q @ Float) expands to (Ptr a (a +# b)), and that will+  duplicate the (a +# b) primop, which we should not do lightly.+  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)++Note [isExpandableApp: bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important that isExpandableApp does not respond True to bottoming+functions.  Recall  undefined :: HasCallStack => a+Suppose isExpandableApp responded True to (undefined d), and we had:++  x = undefined <dict-expr>++Then Simplify.prepareRhs would ANF the RHS:++  d = <dict-expr>+  x = undefined d++This is already bad: we gain nothing from having x bound to (undefined+var), unlike the case for data constructors.  Worse, we get the+simplifier loop described in OccurAnal Note [Cascading inlines].+Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will+certainly_inline; so we end up inlining d right back into x; but in+the end x doesn't inline because it is bottom (preInlineUnconditionally);+so the process repeats.. We could elaborate the certainly_inline logic+some more, but it's better just to treat bottoming bindings as+non-expandable, because ANFing them is a bad idea in the first place.++Note [Record selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm experimenting with making record selection+look cheap, so we will substitute it inside a+lambda.  Particularly for dictionary field selection.++BUT: Take care with (sel d x)!  The (sel d) might be cheap, but+there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)++Note [Expandable overloadings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose the user wrote this+   {-# RULE  forall x. foo (negate x) = h x #-}+   f x = ....(foo (negate x))....+They'd expect the rule to fire. But since negate is overloaded, we might+get this:+    f = \d -> let n = negate d in \x -> ...foo (n x)...+So we treat the application of a function (negate in this case) to a+*dictionary* as expandable.  In effect, every function is CONLIKE when+it's applied only to dictionaries.+-}++isUnaryClassId :: Id -> Bool+-- True of (a) the method selector (classop)+--         (b) the dictionary data constructor+-- of a unary class+isUnaryClassId v+  | Just cls <- isClassOpId_maybe v     = isUnaryClass cls+  | Just dc  <- isDataConWorkId_maybe v = isUnaryClassDataCon dc+  | otherwise                           = False++exprIsUnaryClassFun :: CoreExpr -> Bool+-- True of an a type application (f @t1 .. @tn),+-- where `f` is a unary-class-id+-- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon+exprIsUnaryClassFun (App f (Type {}))       = exprIsUnaryClassFun f+exprIsUnaryClassFun (Var v)                 = isUnaryClassId v+exprIsUnaryClassFun _                       = False+++{- *********************************************************************+*                                                                      *+             exprOkForSpeculation+*                                                                      *+********************************************************************* -}++-----------------------------+-- | To a first approximation, 'exprOkForSpeculation' returns True of+-- an expression that is:+--+--  * Safe to evaluate even if normal order eval might not+--    evaluate the expression at all, and+--+--  * Safe /not/ to evaluate even if normal order would do so+--+-- More specifically, this means that:+--  * A: Evaluation of the expression reaches weak-head-normal-form,+--  * B: soon,+--  * C: without causing a write side effect (e.g. writing a mutable variable).+--+-- In particular, an expression that may+--  * throw a synchronous Haskell exception, or+--  * risk an unchecked runtime exception (e.g. array+--    out of bounds, divide by zero)+-- is /not/ considered OK-for-speculation, as these violate condition A.+--+-- For 'exprOkToDiscard', condition A is weakened to allow expressions+-- that might risk an unchecked runtime exception but must otherwise+-- reach weak-head-normal-form.+-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard')+--+-- But in fact both functions are a bit more conservative than the above,+-- in at least the following ways:+--+--  * W1: We do not take advantage of already-evaluated lifted variables.+--        As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation';+--        if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is+--        'True', while @exprOkForSpeculation y@ is 'False'.+--        See Note [exprOkForSpeculation and evaluated variables] for why.+--  * W2: Read-effects on mutable variables are currently also included.+--        See Note [Classifying primop effects] "GHC.Builtin.PrimOps".+--  * W3: Currently, 'exprOkForSpeculation' always returns 'False' for+--        let-expressions.  Lets can be stacked deeply, so we just give up.+--        In any case, the argument of 'exprOkForSpeculation' is usually in+--        a strict context, so any lets will have been floated away.+--+--+-- As an example of the considerations in this test, consider:+--+-- > let x = case y# +# 1# of { r# -> I# r# }+-- > in E+--+-- being translated to:+--+-- > case y# +# 1# of { r# ->+-- >    let x = I# r#+-- >    in E+-- > }+--+-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no+-- side effects, and can't diverge or raise an exception.+--+--+-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps"+-- and Note [Transformations affected by primop effects].+--+-- 'exprOkForSpeculation' is used to define Core's let-can-float+-- invariant.  (See Note [Core let-can-float invariant] in+-- "GHC.Core".)  It is therefore frequently called on arguments of+-- unlifted type, especially via 'needsCaseBinding'.  But it is+-- sometimes called on expressions of lifted type as well.  For+-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep".+++exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool+exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation+exprOkToDiscard      = expr_ok fun_always_ok primOpOkToDiscard++fun_always_ok :: Id -> Bool+fun_always_ok _ = True++-- | A special version of 'exprOkForSpeculation' used during+-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False+-- for `b`, then `b` is never considered ok-for-spec.+exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool+exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation++expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool+expr_ok _ _ (Lit _)      = True+expr_ok _ _ (Type _)     = True+expr_ok _ _ (Coercion _) = True++expr_ok fun_ok primop_ok (Var v)    = app_ok fun_ok primop_ok v []+expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e+expr_ok fun_ok primop_ok (Lam b e)+                 | isTyVar b = expr_ok fun_ok primop_ok  e+                 | otherwise = True++-- Tick annotations that *tick* cannot be speculated, because these+-- are meant to identify whether or not (and how often) the particular+-- source expression was evaluated at runtime.+expr_ok fun_ok primop_ok (Tick tickish e)+   | tickishCounts tickish = False+   | otherwise             = expr_ok fun_ok primop_ok e++expr_ok _ _ (Let {}) = False+-- See W3 in the Haddock comment for exprOkForSpeculation++expr_ok fun_ok primop_ok (Case scrut bndr _ alts)+  =  -- See Note [exprOkForSpeculation: case expressions]+     expr_ok fun_ok primop_ok scrut+  && isUnliftedType (idType bndr)+      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep+  && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts+  && altsAreExhaustive alts++expr_ok fun_ok primop_ok other_expr+  | (expr, args) <- collectArgs other_expr+  = case stripTicksTopE (not . tickishCounts) expr of+        Var f ->+           app_ok fun_ok primop_ok f args++        -- 'LitRubbish' is the only literal that can occur in the head of an+        -- application and will not be matched by the above case (Var /= Lit).+        -- See Note [How a rubbish literal can be the head of an application]+        -- in GHC.Types.Literal+        Lit lit | debugIsOn, not (isLitRubbish lit)+                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)+                 | otherwise+                 -> True++        _ -> False++-----------------------------+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool+app_ok fun_ok primop_ok fun args+  | not (fun_ok fun)+  = False -- This code path is only taken for Note [Speculative evaluation]++  | idArity fun > n_val_args+  -- Partial application: just check passing the arguments is OK+  = args_ok++  | otherwise+  = case idDetails fun of+      DFunId unary_class -> not unary_class+         -- DFuns terminate, unless the dict is implemented+         -- by a no-op in which case they may not+         -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon++      DataConWorkId dc+        | isLazyDataConRep dc+        -> args_ok+        | otherwise+        -> fields_ok (dataConRepStrictness dc)++      ClassOpId _ is_terminating_result+        | is_terminating_result -- See Note [exprOkForSpeculation and type classes]+        -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $+           True+           -- assert: terminating result type => can't be applied;+           -- c.f the _other case below++      PrimOpId op _+        | primOpIsDiv op+        , Lit divisor <- Partial.last args+            -- there can be 2 args (most div primops) or 3 args+            -- (WordQuotRem2Op), hence the use of last/init+        -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)+              -- Special case for dividing operations that fail+              -- In general they are NOT ok-for-speculation+              -- (which primop_ok will catch), but they ARE OK+              -- if the divisor is definitely non-zero.+              -- Often there is a literal divisor, and this+              -- can get rid of a thunk in an inner loop++        | otherwise -> primop_ok op && args_ok++      _other  -- Unlifted and terminating types;+              -- Also c.f. the Var case of exprIsHNF+         |  isTerminatingType fun_ty  -- See Note [exprOkForSpeculation and type classes]+         || definitelyUnliftedType fun_ty+         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)+            True  -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)+                  -- are non-functions and so will have no value args.  The assert is+                  -- just to check this.+                  -- (If we added unlifted function types this would change,+                  -- and we'd need to actually test n_val_args == 0.)++         -- Functions that terminate fast without raising exceptions etc+         -- See (U12) of Note [Implementing unsafeCoerce]+         | fun `hasKey` unsafeEqualityProofIdKey -> True++         | otherwise -> False+             -- NB: even in the nullary case, do /not/ check+             --     for evaluated-ness of the fun;+             --     see Note [exprOkForSpeculation and evaluated variables]+  where+    fun_ty       = idType fun+    n_val_args   = valArgCount args+    (arg_tys, _) = splitPiTys fun_ty++    -- Even if a function call itself is OK, any unlifted+    -- args are still evaluated eagerly and must be checked+    args_ok = all2Prefix arg_ok arg_tys args+    arg_ok :: PiTyVarBinder -> CoreExpr -> Bool+    arg_ok (Named _) _ = True   -- A type argument+    arg_ok (Anon ty _) arg      -- A term argument+       | definitelyLiftedType (scaledThing ty)+       = True -- lifted args are not evaluated eagerly+       | otherwise+       = expr_ok fun_ok primop_ok arg++    -- Used for strict DataCon worker arguments+    -- See (SFC1) of Note [Strict fields in Core]+    fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args+    field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool+    field_ok (Named _)   _   _ = True+    field_ok (Anon ty _) str arg+       | NotMarkedStrict <- str                 -- iff it's a lazy field+       , definitelyLiftedType (scaledThing ty)  -- and its type is lifted+       = True                                   -- then the worker app does not eval+       | otherwise+       = expr_ok fun_ok primop_ok arg++-----------------------------+altsAreExhaustive :: [Alt b] -> Bool+-- True  <=> the case alternatives are definitely exhaustive+-- False <=> they may or may not be+altsAreExhaustive []+  = True    -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core+altsAreExhaustive (Alt con1 _ _ : alts)+  = case con1 of+      DEFAULT   -> True+      LitAlt {} -> False+      DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1)+      -- It is possible to have an exhaustive case that does not+      -- enumerate all constructors, notably in a GADT match, but+      -- we behave conservatively here -- I don't think it's important+      -- enough to deserve special treatment++-- | Should we look past this tick when eta-expanding the given function?+--+-- See Note [Ticks and mandatory eta expansion]+-- Takes the function we are applying as argument.+etaExpansionTick :: Id -> GenTickish pass -> Bool+etaExpansionTick id t+  = hasNoBinding id &&+    ( tickishFloatable t || isProfTick t )++{- Note [exprOkForSpeculation and type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22745, #15205)++  \(d :: C a b). case eq_sel (sc_sel d) of+                   (co :: t1 ~# t2) [Dead] ->  blah++We know that+* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates+  (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core)+* eq_sel is simply a superclass selector, and hence is fast+* The field that eq_sel picks is of unlifted type, and hence can't be bottom+  (remember the dictionary argument itself is non-bottom)++So we can treat (eq_sel (sc_sel d)) as ok-for-speculation.  We must check++a) That the function is a class-op, with IdDetails of ClassOpId++b) That the result type of the class-op is terminating or unlifted.  E.g. for+     class C a => D a where ...+     class C a where { op :: a -> a }+   Since C is represented by a newtype, (sc_sel (d :: D a)) might+   not be terminating.++Rather than repeatedly test if the result of the class-op is a+terminating/unlifted type, we cache it as a field of ClassOpId. See+GHC.Types.Id.Make.mkDictSelId for where this field is initialised.++Note [exprOkForSpeculation: case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+exprOkForSpeculation accepts very special case expressions.+Reason: (a ==# b) is ok-for-speculation, but the litEq rules+in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to+   case a of { DEFAULT -> 0#; 3# -> 1# }+for excellent reasons described in+  GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case].+So, annoyingly, we want that case expression to be+ok-for-speculation too. Bother.++But we restrict it sharply:++* We restrict it to unlifted scrutinees. Consider this:+     case x of y {+       DEFAULT -> ... (let v::Int# = case y of { True  -> e1+                                               ; False -> e2 }+                       in ...) ...++  Does the RHS of v satisfy the let-can-float invariant?  Previously we said+  yes, on the grounds that y is evaluated.  But the binder-swap done+  by GHC.Core.Opt.SetLevels would transform the inner alternative to+     DEFAULT -> ... (let v::Int# = case x of { ... }+                     in ...) ....+  which does /not/ satisfy the let-can-float invariant, because x is+  not evaluated. See Note [Binder-swap during float-out]+  in GHC.Core.Opt.SetLevels.  To avoid this awkwardness it seems simpler+  to stick to unlifted scrutinees where the issue does not+  arise.++* We restrict it to exhaustive alternatives. A non-exhaustive+  case manifestly isn't ok-for-speculation. for example,+  this is a valid program (albeit a slightly dodgy one)+    let v = case x of { B -> ...; C -> ... }+    in case x of+         A -> ...+         _ ->  ...v...v....+  Should v be considered ok-for-speculation?  Its scrutinee may be+  evaluated, but the alternatives are incomplete so we should not+  evaluate it strictly.++  Now, all this is for lifted types, but it'd be the same for any+  finite unlifted type. We don't have many of them, but we might+  add unlifted algebraic types in due course.+++----- Historical note: #15696: --------+  Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide+  floating of single-alternative cases; it now uses exprIsHNF+  Note [Floating single-alternative cases].++  But in those days, consider+    case e of x { DEAFULT ->+      ...(case x of y+            A -> ...+            _ -> ...(case (case x of { B -> p; C -> p }) of+                       I# r -> blah)...+  If GHC.Core.Opt.SetLevels considers the inner nested case as+  ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels).+  So we'd float to:+    case e of x { DEAFULT ->+    case (case x of { B -> p; C -> p }) of I# r ->+    ...(case x of y+            A -> ...+            _ -> ...blah...)...+  which is utterly bogus (seg fault); see #5453.++----- Historical note: #3717: --------+    foo :: Int -> Int+    foo 0 = 0+    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)++In earlier GHCs, we got this:+    T.$wfoo =+      \ (ww :: GHC.Prim.Int#) ->+        case ww of ds {+          __DEFAULT -> case (case <# ds 5 of _ {+                          GHC.Types.False -> lvl1;+                          GHC.Types.True -> lvl})+                       of _ { __DEFAULT ->+                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };+          0 -> 0 }++Before join-points etc we could only get rid of two cases (which are+redundant) by recognising that the (case <# ds 5 of { ... }) is+ok-for-speculation, even though it has /lifted/ type.  But now join+points do the job nicely.+------- End of historical note ------------+++Note [exprOkForSpeculation and evaluated variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples:+ * case x of y { DEFAULT -> ....y.... }+   Should 'y' (alone) be considered ok-for-speculation?++ * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... }+   Should (dataToTagLarge# y) be considered ok-for-spec? Recall that+     dataToTagLarge# :: forall a. a -> Int#+   must always evaluate its argument. (See also Note [DataToTag overview].)++You could argue 'yes', because in the case alternative we know that+'y' is evaluated.  But the binder-swap transformation, which is+extremely useful for float-out, changes these expressions to+   case x of y { DEFAULT -> ....x.... }+   case x of y { DEFAULT -> ....let z = dataToTagLarge# x... }++And now the expression does not obey the let-can-float invariant!  Yikes!+Moreover we really might float (dataToTagLarge# x) outside the case,+and then it really, really doesn't obey the let-can-float invariant.++The solution is simple: exprOkForSpeculation does not try to take+advantage of the evaluated-ness of (lifted) variables.  And it returns+False (always) for primops that perform evaluation.  We achieve the latter+by marking the relevant primops as "ThrowsException" or+"ReadWriteEffect"; see also Note [Classifying primop effects] in+GHC.Builtin.PrimOps.++Note that exprIsHNF /can/ and does take advantage of evaluated-ness;+it doesn't have the trickiness of the let-can-float invariant to worry about.++************************************************************************+*                                                                      *+             exprIsHNF, exprIsConLike+*                                                                      *+************************************************************************+-}++-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]+-- ~~~~~~~~~~~~~~~~+-- | exprIsHNF returns true for expressions that are certainly /already/+-- evaluated to /head/ normal form.  This is used to decide whether it's ok+-- to perform case-to-let for lifted expressions, which changes:+--+-- > case x of x' { _ -> e }+--+--    into:+--+-- > let x' = x in e+--+-- and in so doing makes the binding lazy.+--+-- So, it does /not/ treat variables as evaluated, unless they say they are.+--+-- However, it /does/ treat partial applications and constructor applications+-- as values, even if their arguments are non-trivial, provided the argument+-- type is lifted. For example, both of these are values:+--+-- > (:) (f x) (map f xs)+-- > map (...redex...)+--+-- because 'seq' on such things completes immediately.+--+-- For unlifted argument types, we have to be careful:+--+-- > C (f x :: Int#)+--+-- Suppose @f x@ diverges; then @C (f x)@ is not a value.+-- We check for this using needsCaseBinding below+exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding++-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as+-- data constructors. Conlike arguments are considered interesting by the+-- inliner.+exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding++-- | Returns true for values or value-like expressions. These are lambdas,+-- constructors / CONLIKE functions (as determined by the function argument)+-- or PAPs.+--+exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool+exprIsHNFlike is_con is_con_unf e+  = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $+    is_hnf_like e+  where+    is_hnf_like (Var v) -- NB: There are no value args at this point+      =  id_app_is_value v [] -- Catches nullary constructors,+                              --      so that [] and () are values, for example+                              -- and (e.g.) primops that don't have unfoldings+      || is_con_unf (idUnfolding v)+        -- Check the thing's unfolding; it might be bound to a value+        --   or to a guaranteed-evaluated variable (isEvaldUnfolding)+        --   Contrast with Note [exprOkForSpeculation and evaluated variables]+        -- We don't look through loop breakers here, which is a bit conservative+        -- but otherwise I worry that if an Id's unfolding is just itself,+        -- we could get an infinite loop++      || definitelyUnliftedType (idType v)+        -- Unlifted binders are always evaluated (#20140)++    is_hnf_like (Lit l)          = not (isLitRubbish l)+        -- Regarding a LitRubbish as ConLike leads to unproductive inlining in+        -- WWRec, see #20035+    is_hnf_like (Type _)         = True       -- Types are honorary Values;+                                              -- we don't mind copying them+    is_hnf_like (Coercion _)     = True       -- Same for coercions+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e+    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)+                                   && is_hnf_like e+                                      -- See Note [exprIsHNF Tick]+    is_hnf_like (Cast e _)       = is_hnf_like e+    is_hnf_like (App e a)+      | isValArg a               = app_is_value e [a]+      | otherwise                = is_hnf_like e+    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us+    is_hnf_like (Case e b _ as)+      | Just rhs <- isUnsafeEqualityCase e b as+      = is_hnf_like rhs+    is_hnf_like _                = False++    -- Collect arguments through Casts and Ticks and call id_app_is_value+    app_is_value :: CoreExpr -> [CoreArg] -> Bool+    app_is_value (Var f)    as = id_app_is_value f as+    app_is_value (Tick _ f) as = app_is_value f as+    app_is_value (Cast f _) as = app_is_value f as+    app_is_value (App f a)  as | isValArg a = app_is_value f (a:as)+                               | otherwise  = app_is_value f as+    app_is_value _          _  = False++    id_app_is_value id val_args+      | Just dc <- isDataConWorkId_maybe id+      , isUnaryClassDataCon  dc+      = all is_hnf_like val_args  -- Look through unary class data cons+      | otherwise+      -- See Note [exprIsHNF for function applications]+      --   for the specification and examples+      = case compare (idArity id) (length val_args) of+          EQ | is_con id ->      -- Saturated app of a DataCon/CONLIKE Id+            case mb_str_marks id of+              Just str_marks ->  -- with strict fields; see (SFC1) of Note [Strict fields in Core]+                assert (val_args `equalLength` str_marks) $+                fields_hnf str_marks+              Nothing ->         -- without strict fields: like PAP+                args_hnf         -- NB: CONLIKEs are lazy!++          GT ->                  -- PAP: Check unlifted val_args+            args_hnf++          _  -> False++      where+        -- Saturated, Strict DataCon: Check unlifted val_args and strict fields+        fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args++        -- PAP: Check unlifted val_args+        args_hnf             = all2Prefix check_arg   val_arg_tys           val_args++        fun_ty = idType id+        val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty)+          -- val_arg_tys = map exprType val_args, but much less costly.+          -- The obvious definition regresses T16577 by 30% so we don't do it.++        check_arg a_ty a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | otherwise                = True+         -- Check unliftedness; for example f (x /# 12#) where f has arity two,+         -- and the first argument is unboxed. This is not a value!+         -- But  f 34#  is a value, so check args for HNFs.+         -- NB: We check arity (and CONLIKEness) first because it's cheaper+         --     and we reject quickly on saturated apps.+        check_field a_ty str a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | isMarkedStrict str       = is_hnf_like a+          | otherwise                = True+          -- isMarkedStrict: Respect Note [Strict fields in Core]++        mb_str_marks id+          | Just dc <- isDataConWorkId_maybe id+          , not (isLazyDataConRep dc)+          = Just (dataConRepStrictness dc)+          | otherwise+          = Nothing++{-# INLINE exprIsHNFlike #-}++{-+Note [exprIsHNF Tick]+~~~~~~~~~~~~~~~~~~~~~+We can discard source annotations on HNFs as long as they aren't+tick-like:++  scc c (\x . e)    =>  \x . e+  scc c (C x1..xn)  =>  C x1..xn++So we regard these as HNFs.  Tick annotations that tick are not+regarded as HNF if the expression they surround is HNF, because the+tick is there to tell us that the expression was evaluated, so we+don't want to discard a seq on it.++Note [exprIsHNF for function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application with an Id head where the argument is a redex:++  f <redex>++Is this expression a value?++The answer depends on the type of `f`, its arity and whether or not it is a+strict data constructor. The decision diagram is as follows:++* If <redex> is unlifted, it is *not* a value (regardless of arity!)+* Otherwise, <redex> is lifted.+  Does its `idArity` (a lower bound on the actual arity)+  exceed the number of actual arguments (= 1)?+  * If so, it is a PAP and thus a value+  * If not, it is a saturated call.+    Is it a lazy data constructor?   Then it is a value.+    Is it a strict data constructor? Then it is *not* a value. (See also Note [Strict fields in Core].)+    Otherwise, it is a regular, possibly saturated function call, and hence *not* a value.++The code in exprIsHNF is tweaked for efficiency, hence it delays the+unliftedness check after the arity check.++Here are a few examples (enshrined in testcase AppIsHNF) to bring home this+point. Let us say that++  f :: Int# -> Int -> Int -> Int, with idArity 3+  expensive# :: Int -> Int#  -- unlifted result+  expensive  :: Int -> Int   -- lifted result+  data T where+    K1 :: !Int -> Int -> T -- strict field+    K2 :: Int# -> Int -> T -- unlifted field++Now consider++  f (expensive# 1) 2    -- Not HNF+  f 1# (expensive 2)    -- HNF++  K1 1 (expensive 2)   -- HNF+  K1 (expensive 1) 2   -- Not HNF+  K1 (expensive 1)     -- HNF      (!)++  K2 1# (expensive 1)   -- HNF+  K2 (expensive# 1) 2   -- Not HNF+  K2 (expensive# 1)     -- Not HNF (!)++Note that the cases marked (!) exemplify that strict fields are different to+unlifted fields when considering partial applications: Unlifted fields are+evaluated eagerly whereas evaluation of strict fields is delayed until the call+is saturated.+-}++-- | Can we bind this 'CoreExpr' at the top level?+exprIsTopLevelBindable :: CoreExpr -> Type -> Bool+-- See Note [Core top-level string literals]+-- Precondition: exprType expr = ty+-- Top-level literal strings can't even be wrapped in ticks+--   see Note [Core top-level string literals] in "GHC.Core"+exprIsTopLevelBindable expr ty+  = not (mightBeUnliftedType ty)+    -- Note that 'expr' may not have a fixed runtime representation here,+    -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',+    -- as the latter would panic.+  || exprIsTickedString expr++-- | Check if the expression is zero or more Ticks wrapped around a literal+-- string.+exprIsTickedString :: CoreExpr -> Bool+exprIsTickedString = isJust . exprIsTickedString_maybe++-- | Extract a literal string from an expression that is zero or more Ticks+-- wrapped around a literal string. Returns Nothing if the expression has a+-- different shape.+-- Used to "look through" Ticks in places that need to handle literal strings.+exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString+exprIsTickedString_maybe (Lit (LitString bs)) = Just bs+exprIsTickedString_maybe (Tick t e)+  -- we don't tick literals with CostCentre ticks, compare to mkTick+  | tickishPlace t == PlaceCostCentre = Nothing+  | otherwise = exprIsTickedString_maybe e+exprIsTickedString_maybe _ = Nothing++{-+************************************************************************+*                                                                      *+             Instantiating data constructors+*                                                                      *+************************************************************************++These InstPat functions go here to avoid circularity between DataCon and Id+-}++dataConRepInstPat   ::                 [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])+dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])++dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))+dataConRepFSInstPat = dataConInstPat++dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names+               -> [Unique]              -- An equally long list of uniques, at least one for each binder+               -> Mult                  -- The multiplicity annotation of the case expression: scales the multiplicity of variables+               -> DataCon+               -> [Type]                -- Types to instantiate the universally quantified tyvars+               -> ([TyCoVar], [Id])     -- Return instantiated variables+-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple+-- (ex_tvs, arg_ids),+--+--   ex_tvs are intended to be used as binders for existential type args+--+--   arg_ids are intended to be used as binders for value arguments,+--     and their types have been instantiated with inst_tys and ex_tys+--     The arg_ids include both evidence and+--     programmer-specified arguments (both after rep-ing)+--+-- Example.+--  The following constructor T1+--+--  data T a where+--    T1 :: forall b. Int -> b -> T(a,b)+--    ...+--+--  has representation type+--   forall a. forall a1. forall b. (a ~ (a1,b)) =>+--     Int -> b -> T a+--+--  dataConInstPat fss us T1 (a1',b') will return+--+--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])+--+--  where the double-primed variables are created with the FastStrings and+--  Uniques given as fss and us+dataConInstPat fss uniqs mult con inst_tys+  = assert (univ_tvs `equalLength` inst_tys) $+    (ex_bndrs, arg_ids)+  where+    univ_tvs = dataConUnivTyVars con+    ex_tvs   = dataConExTyCoVars con+    arg_tys  = dataConRepArgTys con+    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys+    n_ex = length ex_tvs++      -- split the Uniques and FastStrings+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs+    (ex_fss,   id_fss)   = splitAt n_ex fss++      -- Make the instantiating substitution for universals+    univ_subst = zipTvSubst univ_tvs inst_tys++      -- Make existential type variables, applying and extending the substitution+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst+                                       (zip3 ex_tvs ex_fss ex_uniqs)++    mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv+                                       new_tv+                                     , new_tv)+      where+        new_tv | isTyVar tv+               = mkTyVar (mkSysTvName uniq fs) kind+               | otherwise+               = mkCoVar (mkSystemVarName uniq fs) kind+        kind   = Type.substTyUnchecked subst (varType tv)++      -- Make value vars, instantiating types+    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs+    mk_id_var uniq fs (Scaled m ty) str+      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]+        mkUserLocalOrCoVar (mkVarOccFS fs) uniq+                           (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan++{-+Note [Mark evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When pattern matching on a constructor with strict fields, the binder+can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that+when loading an interface file unfolding like:+  data T = MkT !Int+  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1+                             in ... }+we don't want Lint to complain.  The 'y' is evaluated, so the+case in the RHS of the binding for 'v' is fine.  But only if we+*know* that 'y' is evaluated.++c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt++************************************************************************+*                                                                      *+         Equality+*                                                                      *+************************************************************************+-}++-- | A cheap equality test which bales out fast!+--      If it returns @True@ the arguments are definitely equal,+--      otherwise, they may or may not be equal.+cheapEqExpr :: Expr b -> Expr b -> Bool+cheapEqExpr = cheapEqExpr' (const False)++-- | Cheap expression equality test, can ignore ticks by type.+cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool+{-# INLINE cheapEqExpr' #-}+cheapEqExpr' ignoreTick e1 e2+  = go e1 e2+  where+    go (Var v1)   (Var v2)         = v1 == v2+    go (Lit lit1) (Lit lit2)       = lit1 == lit2+    go (Type t1)  (Type t2)        = t1 `eqType` t2+    go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2+    go (App f1 a1) (App f2 a2)     = f1 `go` f2 && a1 `go` a2+    go (Cast e1 t1) (Cast e2 t2)   = e1 `go` e2 && t1 `eqCoercion` t2++    go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2+    go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2+    go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2++    go _ _ = False++++-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots+eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool+eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)+      = lid == rid &&+        map (rnOccL env) lids == map (rnOccR env) rids &&+        lext == rext+eqTickish _ l r = l == r++-- | Finds differences between core bindings, see @diffExpr@.+--+-- The main problem here is that while we expect the binds to have the+-- same order in both lists, this is not guaranteed. To do this+-- properly we'd either have to do some sort of unification or check+-- all possible mappings, which would be seriously expensive. So+-- instead we simply match single bindings as far as we can. This+-- leaves us just with mutually recursive and/or mismatching bindings,+-- which we then speculatively match by ordering them. It's by no means+-- perfect, but gets the job done well enough.+--+-- Only used in GHC.Core.Lint.lintAnnots+diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]+          -> ([SDoc], RnEnv2)+diffBinds top env binds1 = go (length binds1) env binds1+ where go _    env []     []+          = ([], env)+       go _fuel env [] binds2+          -- No binds remaining to compare on the left? Bail out early.+          = (warn env [] binds2, env)+       go _fuel env binds1 []+          -- No binds remaining to compare on the right? Bail out early.+          = (warn env binds1 [], env)+       go fuel env binds1@(bind1:_) binds2@(_:_)+          -- Iterated over all binds without finding a match? Then+          -- try speculatively matching binders by order.+          | fuel == 0+          = if not $ env `inRnEnvL` fst bind1+            then let env' = uncurry (rnBndrs2 env) $ unzip $+                            zip (sort $ map fst binds1) (sort $ map fst binds2)+                 in go (length binds1) env' binds1 binds2+            -- If we have already tried that, give up+            else (warn env binds1 binds2, env)+       go fuel env ((bndr1,expr1):binds1) binds2+          | let matchExpr (bndr,expr) =+                  (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) &&+                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)++          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2+          = go (length binds1) (rnBndr2 env bndr1 bndr2)+                binds1 (binds2l ++ binds2r)+          | otherwise -- No match, so push back (FIXME O(n^2))+          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2++       -- We have tried everything, but couldn't find a good match. So+       -- now we just return the comparison results when we pair up+       -- the binds in a pseudo-random order.+       warn env binds1 binds2 =+         concatMap (uncurry (diffBind env)) (zip binds1' binds2') +++         unmatched "unmatched left-hand:" (drop l binds1') +++         unmatched "unmatched right-hand:" (drop l binds2')+        where binds1' = sortBy (comparing fst) binds1+              binds2' = sortBy (comparing fst) binds2+              l = min (length binds1') (length binds2')+       unmatched _   [] = []+       unmatched txt bs = [text txt $$ ppr (Rec bs)]+       diffBind env (bndr1,expr1) (bndr2,expr2)+         | ds@(_:_) <- diffExpr top env expr1 expr2+         = locBind "in binding" bndr1 bndr2 ds+         -- Special case for TyVar, which we checked were bound to the same types in+         -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo.+         -- These let-bound types are created temporarily by the simplifier but inlined+         -- immediately.+         | isTyVar bndr1 && isTyVar bndr2+         = []+         | otherwise+         = diffIdInfo env bndr1 bndr2++-- | Finds differences between core expressions, modulo alpha and+-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be+-- checked for differences as well.+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []+diffExpr _   env (Coercion co1) (Coercion co2)+                                       | eqCoercionX env co1 co2        = []+diffExpr top env (Cast e1 co1)  (Cast e2 co2)+  | eqCoercionX env co1 co2                = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   e2+  | not (tickishIsCode n1)                 = diffExpr top env e1 e2+diffExpr top env e1             (Tick n2 e2)+  | not (tickishIsCode n2)                 = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   (Tick n2 e2)+  | eqTickish env n1 n2                    = diffExpr top env e1 e2+ -- The error message of failed pattern matches will contain+ -- generated names, which are allowed to differ.+diffExpr _   _   (App (App (Var absent) _) _)+                 (App (App (Var absent2) _) _)+  | isDeadEndId absent && isDeadEndId absent2 = []+diffExpr top env (App f1 a1)    (App f2 a2)+  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2+diffExpr top env (Lam b1 e1)  (Lam b2 e2)+  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination+  = diffExpr top (rnBndr2 env b1 b2) e1 e2+diffExpr top env (Let bs1 e1) (Let bs2 e2)+  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])+    in ds ++ diffExpr top env' e1 e2+diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+  | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2+    -- See Note [Empty case alternatives] in GHC.Data.TrieMap+  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)+  where env' = rnBndr2 env b1 b2+        diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2)+          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]+          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2+diffExpr _  _ e1 e2+  = [fsep [ppr e1, text "/=", ppr e2]]++-- | Find differences in @IdInfo@. We will especially check whether+-- the unfoldings match, if present (see @diffUnfold@).+diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]+diffIdInfo env bndr1 bndr2+  | arityInfo info1 == arityInfo info2+    && cafInfo info1 == cafInfo info2+    && oneShotInfo info1 == oneShotInfo info2+    && inlinePragInfo info1 == inlinePragInfo info2+    && occInfo info1 == occInfo info2+    && demandInfo info1 == demandInfo info2+    && callArityInfo info1 == callArityInfo info2+  = locBind "in unfolding of" bndr1 bndr2 $+    diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)+  | otherwise+  = locBind "in Id info of" bndr1 bndr2+    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]+  where info1 = idInfo bndr1; info2 = idInfo bndr2++-- | Find differences in unfoldings. Note that we will not check for+-- differences of @IdInfo@ in unfoldings, as this is generally+-- redundant, and can lead to an exponential blow-up in complexity.+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]+diffUnfold _   NoUnfolding    NoUnfolding                 = []+diffUnfold _   BootUnfolding  BootUnfolding               = []+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []+diffUnfold env (DFunUnfolding bs1 c1 a1)+               (DFunUnfolding bs2 c2 a2)+  | c1 == c2 && equalLength bs1 bs2+  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)+  where env' = rnBndrs2 env bs1 bs2+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)+               (CoreUnfolding t2 _ _ c2 g2)+  | c1 == c2 && g1 == g2+  = diffExpr False env t1 t2+diffUnfold _   uf1 uf2+  = [fsep [ppr uf1, text "/=", ppr uf2]]++-- | Add location information to diff messages+locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]+locBind loc b1 b2 diffs = map addLoc diffs+  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))+        bindLoc | b1 == b2  = ppr b1+                | otherwise = ppr b1 <> char '/' <> ppr b2+++{- *********************************************************************+*                                                                      *+\subsection{Determining non-updatable right-hand-sides}+*                                                                      *+************************************************************************++Top-level constructor applications can usually be allocated+statically, but they can't if the constructor, or any of the+arguments, come from another DLL (because we can't refer to static+labels in other DLLs).++If this happens we simply make the RHS into an updatable thunk,+and 'execute' it rather than allocating it statically.+-}++{-+************************************************************************+*                                                                      *+\subsection{Type utilities}+*                                                                      *+************************************************************************+-}++-- | True if the type has no non-bottom elements, e.g. when it is an empty+-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.+-- See Note [Bottoming expressions]+--+-- See Note [No alternatives lint check] for another use of this function.+isEmptyTy :: Type -> Bool+isEmptyTy ty+    -- Data types where, given the particular type parameters, no data+    -- constructor matches, are empty.+    -- This includes data types with no constructors, e.g. Data.Void.Void.+    | Just (tc, inst_tys) <- splitTyConApp_maybe ty+    , Just dcs <- tyConDataCons_maybe tc+    , all (dataConCannotMatch inst_tys) dcs+    = True+    | otherwise+    = False++-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@+-- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through+-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix.+--+-- Postcondition: tc is not a newtype (guaranteed by topNormaliseType_maybe)+normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)+normSplitTyConApp_maybe fam_envs ty+  | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty+                           `orElse` (mkReflRedn Representational ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , not (isNewTyCon tc)  -- How can tc be a newtype, after `topNormaliseType`?+                         -- Answer: if it is a recursive newtype, `topNormaliseType`+                         --         may be a no-op.   Example: tc226+  = Just (tc, tc_args, co)+normSplitTyConApp_maybe _ _ = Nothing++{-+*****************************************************+*+* InScopeSet things+*+*****************************************************+-}+++extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet+extendInScopeSetBind (InScope in_scope) binds+   = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds++extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet+extendInScopeSetBndrs (InScope in_scope) binds+   = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds++mkInScopeSetBndrs :: [CoreBind] -> InScopeSet+mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds++{-+*****************************************************+*+* StaticPtr+*+*****************************************************+-}++-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields+-- @Just (makeStatic, t, srcLoc, e)@.+--+-- Returns @Nothing@ for every other expression.+collectMakeStaticArgs+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)+collectMakeStaticArgs e+    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e+    , idName b == makeStaticName = Just (fun, t, loc, arg)+collectMakeStaticArgs _          = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Does this binding bind a join point (or a recursive group of join points)?+isJoinBind :: CoreBind -> Bool+isJoinBind (NonRec b _)       = isJoinId b+isJoinBind (Rec ((b, _) : _)) = isJoinId b+isJoinBind _                  = False++dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc+dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)+  where+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)+  getIds (NonRec i _) = [ i ]+  getIds (Rec bs)     = map fst bs+  -- By default only include full info for exported ids, unless we run in the verbose+  -- pprDebug mode.+  printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))+             | otherwise       = empty++{-+************************************************************************+*                                                                      *+\subsection{Tag inference things}+*                                                                      *+************************************************************************+-}++{- Note [Call-by-value for worker args]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we unbox a constructor with strict fields we want to+preserve the information that some of the arguments came+out of strict fields and therefore should be already properly+tagged, however we can't express this directly in core.++Instead what we do is generate a worker like this:++  data T = MkT A !B++  foo = case T of MkT a b -> $wfoo a b++  $wfoo a b = case b of b' -> rhs[b/b']++This makes the worker strict in b causing us to use a more efficient+calling convention for `b` where the caller needs to ensure `b` is+properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].++Usually the argument will be known to be properly tagged at the call site so there is+no additional work for the caller and the worker can be more efficient since it can+assume the presence of a tag.++This is especially true for recursive functions like this:+    -- myPred expect it's argument properly tagged+    myPred !x = ...++    loop :: MyPair -> Int+    loop (MyPair !x !y) =+        case x of+            A -> 1+            B -> 2+            _ -> loop (MyPair (myPred x) (myPred y))++Here we would ordinarily not be strict in y after unboxing.+However if we pass it as a regular argument then this means on+every iteration of loop we will incur an extra seq on y before+we can pass it to `myPred` which isn't great! That is in STG after+tag inference we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, ~])],+    Arity=2,+    Str=<1L><ML>,+    Unf=OtherCon []] =+        {} \r [x y]+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case y of y' [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here comes the tricky part: If we make $wloop strict in both x/y and we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, !])],+    Arity=2,+    Str=<1L><!L>,+    Unf=OtherCon []] =+        {} \r [x y]+            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.+This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.++The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated.+But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated+already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this.+This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.++We only apply this when we think there is a benefit in doing so however. There are a number of cases in which+it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the+simplifier. See Note [Which Ids should be strictified] for details on this.+-}+mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)+mkStrictFieldSeqs args rhs =+  foldr addEval rhs args+    where+      case_ty = exprType rhs+      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)+      addEval (arg_id,arg_cbv) (rhs)+        -- Argument representing strict field.+        | isMarkedStrict arg_cbv+        , shouldStrictifyIdForCbv arg_id+        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.+        = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs])+        -- Normal argument+        | otherwise = do+          rhs++{- Note [Which Ids should be strictified]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some arguments we would like to convince GHC to pass them call by value.+One way to achieve this is described in see Note [Call-by-value for worker args].++We separate the concerns of "should we pass this argument using cbv" and+"should we do so by making the rhs strict in this argument".+This note deals with the second part.++There are multiple reasons why we might not want to insert a seq in the rhs to+strictify a functions argument:++1) The argument doesn't exist at runtime.++For zero width types (like Types) there is no benefit as we don't operate on them+at runtime at all. This includes things like void#, coercions and state tokens.++2) The argument is a unlifted type.++If the argument is a unlifted type the calling convention already is explicitly+cbv. This means inserting a seq on this argument wouldn't do anything as the seq+would be a no-op *and* it wouldn't affect the calling convention.++3) The argument is absent.++If the argument is absent in the body there is no advantage to it being passed as+cbv to the function. The function won't ever look at it so we don't safe any work.++This mostly happens for join point. For example we might have:++    data T = MkT ![Int] [Char]+    f t = case t of MkT xs{strict} ys-> snd (xs,ys)++and abstract the case alternative to:++    f t = join j1 = \xs ys -> snd (xs,ys)+          in case t of MkT xs{strict} ys-> j1 xs xy++While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.+In short a absent demand means neither our RHS, nor any function we pass the argument+to will inspect it. So there is no work to be saved by forcing `xs` early.++NB: There is an edge case where if we rebox we *can* end up seqing an absent value.+Note [Absent fillers] has an example of this. However this is so rare it's not worth+caring about here.++4) The argument is already strict.++Consider this code:++    data T = MkT ![Int]+    f t = case t of MkT xs{strict} -> reverse xs++The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.+If we do a w/w split, and add the extra eval on `xs`, we'll get++    $wf xs =+        case xs of xs1 ->+            let t = MkT xs1 in+            case t of MkT xs2 -> reverse xs2++That's not wrong; but the w/w body will simplify to++    $wf xs = case xs of xs1 -> reverse xs1++and now we'll drop the `case xs` because `xs1` is used strictly in its scope.+Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.++5) Functions++Functions are tricky (see Note [TagInfo of functions] in EnforceEpt).+But the gist of it even if we make a higher order function argument strict+we can't avoid the tag check when it's used later in the body.+So there is no benefit.++-}+-- | Do we expect there to be any benefit if we make this var strict+-- in order for it to get treated as as cbv argument?+-- See Note [Which Ids should be strictified]+-- See Note [CBV Function Ids] for more background.+shouldStrictifyIdForCbv :: Var -> Bool+shouldStrictifyIdForCbv = wantCbvForId False++-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.+shouldUseCbvForId :: Var -> Bool+shouldUseCbvForId = wantCbvForId True++-- When we strictify we want to skip strict args otherwise the logic is the same+-- as for shouldUseCbvForId so we common up the logic here.+-- Basically returns true if it would be beneficial for runtime to pass this argument+-- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args+-- we are not allowed to force.+wantCbvForId :: Bool -> Var -> Bool+wantCbvForId cbv_for_strict v+  -- Must be a runtime var.+  -- See Note [Which Ids should be strictified] point 1)+  | isId v+  , not $ isZeroBitTy ty+  -- Unlifted things don't need special measures to be treated as cbv+  -- See Note [Which Ids should be strictified] point 2)+  , mightBeLiftedType ty+  -- Functions sometimes get a zero tag so we can't eliminate the tag check.+  -- See Note [TagInfo of functions] in EnforceEpt.+  -- See Note [Which Ids should be strictified] point 5)+  , not $ isFunTy ty+  -- If the var is strict already a seq is redundant.+  -- See Note [Which Ids should be strictified] point 4)+  , not (isStrictDmd dmd) || cbv_for_strict+  -- If the var is absent a seq is almost always useless.+  -- See Note [Which Ids should be strictified] point 3)+  , not (isAbsDmd dmd)+  = True+  | otherwise+  = False+  where+    ty = idType v+    dmd = idDemandInfo v++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr+-- See (U3) and (U4) in+-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+isUnsafeEqualityCase scrut bndr alts+  | [Alt ac _ rhs] <- alts+  , DataAlt dc <- ac+  , dc `hasKey` unsafeReflDataConKey+  , isDeadBinder bndr+      -- We can only discard the case if the case-binder is dead+      -- It usually is, but see #18227+  , Var v `App` _ `App` _ `App` _ <- scrut+  , v `hasKey` unsafeEqualityProofIdKey+      -- Check that the scrutinee really is unsafeEqualityProof+      -- and not, say, error+  = Just rhs+  | otherwise+  = Nothing
+ GHC/CoreToIface.hs view
@@ -0,0 +1,801 @@+{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]++-- | Functions for converting Core things to interface file things.+module GHC.CoreToIface+    ( -- * Binders+      toIfaceTvBndr+    , toIfaceTvBndrs+    , toIfaceIdBndr+    , toIfaceBndr+    , toIfaceTopBndr+    , toIfaceForAllBndr+    , toIfaceForAllBndrs+    , toIfaceTyVar+      -- * Types+    , toIfaceType, toIfaceTypeX+    , toIfaceKind+    , toIfaceTcArgs+    , toIfaceTyCon+    , toIfaceTyCon_name+    , toIfaceTyLit+      -- * Tidying types+    , tidyToIfaceType+    , tidyToIfaceContext+    , tidyToIfaceTcArgs+      -- * Coercions+    , toIfaceCoercion, toIfaceCoercionX+      -- * Pattern synonyms+    , patSynToIfaceDecl+      -- * Expressions+    , toIfaceExpr+    , toIfaceBang+    , toIfaceSrcBang+    , toIfaceLetBndr+    , toIfaceIdDetails+    , toIfaceIdInfo+    , toIfUnfolding+    , toIfaceTickish+    , toIfaceBind+    , toIfaceTopBind+    , toIfaceAlt+    , toIfaceCon+    , toIfaceApp+    , toIfaceVar+      -- * Other stuff+    , toIfaceLFInfo+    , toIfaceBooleanFormula+    ) where++import GHC.Prelude++import GHC.StgToCmm.Types++import GHC.Core+import GHC.Core.TyCon hiding ( pprPromotionQuote )+import GHC.Core.Coercion.Axiom+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.PatSyn+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCo.Tidy++import GHC.Builtin.Types.Prim ( eqPrimTyCon, eqReprPrimTyCon )+import GHC.Builtin.Types ( heqTyCon )++import GHC.Iface.Syntax+import GHC.Data.FastString+import GHC.Data.BooleanFormula qualified as BF(BooleanFormula(..))++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName )+import GHC.Types.Literal+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Tickish+import GHC.Types.Demand ( isNopSig )+import GHC.Types.Cpr ( topCprSig )+import GHC.Types.SrcLoc (unLoc)++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Hs.Extension (GhcRn)++import Data.Maybe ( isNothing, catMaybes )++{- Note [Avoiding space leaks in toIface*]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Building a interface file depends on the output of the simplifier.+If we build these lazily this would mean keeping the Core AST alive+much longer than necessary causing a space "leak".++This happens for example when we only write the interface file to disk+after code gen has run, in which case we might carry megabytes of core+AST in the heap which is no longer needed.++We avoid this in two ways.+* First we use -XStrict in GHC.CoreToIface which avoids many thunks+  to begin with.+* Second we define NFData instance for Iface syntax and use them to+  force any remaining thunks.++-XStrict is not sufficient as patterns of the form `f (g x)` would still+result in a thunk being allocated for `g x`.++NFData is sufficient for the space leak, but using -XStrict reduces allocation+by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370).+It's essentially free performance hence we use -XStrict on top of NFData.++MR !1633 on gitlab, has more discussion on the topic.+-}++----------------+toIfaceTvBndr :: TyVar -> IfaceTvBndr+toIfaceTvBndr = toIfaceTvBndrX emptyVarSet++toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr+toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))+                          , toIfaceTypeX fr (tyVarKind tyvar)+                          )++toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]+toIfaceTvBndrs = map toIfaceTvBndr++toIfaceIdBndr :: Id -> IfaceIdBndr+toIfaceIdBndr = toIfaceIdBndrX emptyVarSet++toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr+toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)+                          , mkIfLclName (occNameFS (getOccName covar))+                          , toIfaceTypeX fr (varType covar)+                          )++toIfaceBndr :: Var -> IfaceBndr+toIfaceBndr var+  | isId var  = IfaceIdBndr (toIfaceIdBndr var)+  | otherwise = IfaceTvBndr (toIfaceTvBndr var)++toIfaceBndrX :: VarSet -> Var -> IfaceBndr+toIfaceBndrX fr var+  | isId var  = IfaceIdBndr (toIfaceIdBndrX fr var)+  | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var)++toIfaceForAllBndrs :: [VarBndr TyCoVar vis] -> [VarBndr IfaceBndr vis]+toIfaceForAllBndrs = map toIfaceForAllBndr++toIfaceForAllBndr :: VarBndr TyCoVar flag -> VarBndr IfaceBndr flag+toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet++toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)+toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis++{-+************************************************************************+*                                                                      *+        Conversion from Type to IfaceType+*                                                                      *+************************************************************************+-}++toIfaceKind :: Type -> IfaceType+toIfaceKind = toIfaceType++---------------------+toIfaceType :: Type -> IfaceType+toIfaceType = toIfaceTypeX emptyVarSet++toIfaceTypeX :: VarSet -> Type -> IfaceType+-- (toIfaceTypeX free ty)+--    translates the tyvars in 'free' as IfaceFreeTyVars+--+-- Synonyms are retained in the interface type+toIfaceTypeX fr (TyVarTy tv)   -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type+  | tv `elemVarSet` fr         = IfaceFreeTyVar tv+  | otherwise                  = IfaceTyVar (toIfaceTyVar tv)+toIfaceTypeX fr ty@(AppTy {})  =+  -- Flatten as many argument AppTys as possible, then turn them into an+  -- IfaceAppArgs list.+  -- See Note [Suppressing invisible arguments] in GHC.Iface.Type.+  let (head, args) = splitAppTys ty+  in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args)+toIfaceTypeX _  (LitTy n)      = IfaceLitTy (toIfaceTyLit n)+toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b)+                                               (toIfaceTypeX (fr `delVarSet` binderVar b) t)+toIfaceTypeX fr (FunTy { ft_arg = t1, ft_mult = w, ft_res = t2, ft_af = af })+  = IfaceFunTy af (toIfaceTypeX fr w) (toIfaceTypeX fr t1) (toIfaceTypeX fr t2)+toIfaceTypeX fr (CastTy ty co)  = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co)+toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co)++toIfaceTypeX fr (TyConApp tc tys)+    -- tuples+  | Just sort <- tyConTuple_maybe tc+  , n_tys == arity+  = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)++  | Just dc <- isPromotedDataCon_maybe tc+  , isBoxedTupleDataCon dc+  , n_tys == 2*arity+  = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))++  | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]+  , (k1:k2:_) <- tys+  = let info = mkIfaceTyConInfo NotPromoted sort+        sort | k1 `eqType` k2 = IfaceEqualityTyCon+             | otherwise      = IfaceNormalTyCon+    in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)++    -- other applications+  | otherwise+  = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys)+  where+    arity = tyConArity tc+    n_tys = length tys++toIfaceTyVar :: TyVar -> IfLclName+toIfaceTyVar = mkIfLclName . occNameFS . getOccName++toIfaceCoVar :: CoVar -> IfLclName+toIfaceCoVar = mkIfLclName . occNameFS . getOccName++----------------+toIfaceTyCon :: TyCon -> IfaceTyCon+toIfaceTyCon tc+  = IfaceTyCon tc_name info+  where+    tc_name = tyConName tc+    info    = mkIfaceTyConInfo promoted sort+    promoted | isDataKindsPromotedDataCon tc = IsPromoted+             | otherwise            = NotPromoted++    tupleSort :: TyCon -> Maybe IfaceTyConSort+    tupleSort tc' =+        case tyConTuple_maybe tc' of+          Just UnboxedTuple -> let arity = tyConArity tc' `div` 2+                               in Just $ IfaceTupleTyCon arity UnboxedTuple+          Just sort         -> let arity = tyConArity tc'+                               in Just $ IfaceTupleTyCon arity sort+          Nothing           -> Nothing++    sort+      | Just tsort <- tupleSort tc           = tsort++      | Just dcon <- isPromotedDataCon_maybe tc+      , let tc' = dataConTyCon dcon+      , Just tsort <- tupleSort tc'          = tsort++      | isUnboxedSumTyCon tc+      , Just cons <- tyConDataCons_maybe tc  = IfaceSumTyCon (length cons)++      | otherwise                            = IfaceNormalTyCon+++toIfaceTyCon_name :: Name -> IfaceTyCon+toIfaceTyCon_name n = IfaceTyCon n info+  where info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon+  -- Used for the "rough-match" tycon stuff,+  -- where pretty-printing is not an issue++toIfaceTyLit :: TyLit -> IfaceTyLit+toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x)+toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x++----------------+toIfaceCoercion :: Coercion -> IfaceCoercion+toIfaceCoercion = toIfaceCoercionX emptyVarSet++toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion+-- (toIfaceCoercionX free ty)+--    translates the tyvars in 'free' as IfaceFreeTyVars+toIfaceCoercionX fr co+  = go co+  where+    go_mco MRefl     = IfaceMRefl+    go_mco (MCo co)  = IfaceMCo $ go co++    go (Refl ty)            = IfaceReflCo (toIfaceTypeX fr ty)+    go (GRefl r ty mco)     = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco)+    go (CoVarCo cv)+      -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type+      | cv `elemVarSet` fr = IfaceFreeCoVar cv+      | otherwise          = IfaceCoVarCo (toIfaceCoVar cv)+    go (HoleCo h)          = IfaceHoleCo  (coHoleCoVar h)++    go (AppCo co1 co2)     = IfaceAppCo  (go co1) (go co2)+    go (SymCo co)          = IfaceSymCo (go co)+    go (TransCo co1 co2)   = IfaceTransCo (go co1) (go co2)+    go (SelCo d co)        = IfaceSelCo d (go co)+    go (LRCo lr co)        = IfaceLRCo lr (go co)+    go (InstCo co arg)     = IfaceInstCo (go co) (go arg)+    go (KindCo c)          = IfaceKindCo (go c)+    go (SubCo co)          = IfaceSubCo (go co)+    go (AxiomCo ax cs)     = IfaceAxiomCo (toIfaceAxiomRule ax) (map go cs)+    go (UnivCo { uco_prov = p, uco_role = r, uco_lty = t1, uco_rty = t2, uco_deps = deps })+        = IfaceUnivCo p r (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) (map go deps)++    go co@(TyConAppCo r tc cos)+      =  assertPpr (isNothing (tyConAppFunCo_maybe r tc cos)) (ppr co) $+         IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)++    go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 })+      = IfaceFunCo r (go w) (go co1) (go co2)++    go (ForAllCo tv visL visR k co)+      = IfaceForAllCo (toIfaceBndr tv)+                      visL+                      visR+                      (toIfaceCoercionX fr' k)+                      (toIfaceCoercionX fr' co)+                          where+                            fr' = fr `delVarSet` tv++toIfaceAxiomRule :: CoAxiomRule -> IfaceAxiomRule+toIfaceAxiomRule (BuiltInFamRew  bif) = IfaceAR_X (mkIfLclName (bifrw_name bif))+toIfaceAxiomRule (BuiltInFamInj bif)  = IfaceAR_X (mkIfLclName (bifinj_name bif))+toIfaceAxiomRule (BranchedAxiom ax i) = IfaceAR_B (coAxiomName ax) i+toIfaceAxiomRule (UnbranchedAxiom ax) = IfaceAR_U (coAxiomName ax)++toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs+toIfaceTcArgs = toIfaceTcArgsX emptyVarSet++toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs+toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args++toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs+toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args++toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs+-- See Note [Suppressing invisible arguments] in GHC.Iface.Type+-- We produce a result list of args describing visibility+-- The awkward case is+--    T :: forall k. * -> k+-- And consider+--    T (forall j. blah) * blib+-- Is 'blib' visible?  It depends on the visibility flag on j,+-- so we have to substitute for k.  Annoying!+toIfaceAppArgsX fr kind ty_args+  | null ty_args+  = IA_Nil+  | otherwise+  = go (mkEmptySubst in_scope) kind ty_args+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++    go _   _                   []     = IA_Nil+    go env ty                  ts+      | Just ty' <- coreView ty+      = go env ty' ts+    go env (ForAllTy (Bndr tv vis) res) (t:ts)+      = IA_Arg t' vis ts'+      where+        t'  = toIfaceTypeX fr t+        ts' = go (extendTCvSubst env tv t) res ts++    go env (FunTy { ft_af = af, ft_res = res }) (t:ts)+      = assert (isVisibleFunArg af)+        IA_Arg (toIfaceTypeX fr t) Required (go env res ts)++    go env ty ts@(t1:ts1)+      | not (isEmptyTCvSubst env)+      = go (zapSubst env) (substTy env ty) ts+        -- See Note [Care with kind instantiation] in GHC.Core.Type++      | otherwise+      = -- There's a kind error in the type we are trying to print+        -- e.g. kind = k, ty_args = [Int]+        -- This is probably a compiler bug, so we print a trace and+        -- carry on as if it were FunTy.  Without the test for+        -- isEmptyTCvSubst we'd get an infinite loop (#15473)+        warnPprTrace True "toIfaceAppArgsX" (ppr kind $$ ppr ty_args) $+        IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)++tidyToIfaceType :: TidyEnv -> Type -> IfaceType+tidyToIfaceType env ty = toIfaceType (tidyType env ty)++tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs+tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)++tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext+tidyToIfaceContext env theta = map (tidyToIfaceType env) theta++{-+************************************************************************+*                                                                      *+        Conversion of pattern synonyms+*                                                                      *+************************************************************************+-}++patSynToIfaceDecl :: PatSyn -> IfaceDecl+patSynToIfaceDecl ps+  = IfacePatSyn { ifName          = getName $ ps+                , ifPatMatcher    = to_if_pr (patSynMatcher ps)+                , ifPatBuilder    = fmap to_if_pr (patSynBuilder ps)+                , ifPatIsInfix    = patSynIsInfix ps+                , ifPatUnivBndrs  = map toIfaceForAllBndr univ_bndrs'+                , ifPatExBndrs    = map toIfaceForAllBndr ex_bndrs'+                , ifPatProvCtxt   = tidyToIfaceContext env2 prov_theta+                , ifPatReqCtxt    = tidyToIfaceContext env2 req_theta+                , ifPatArgs       = map (tidyToIfaceType env2 . scaledThing) args+                , ifPatTy         = tidyToIfaceType env2 rhs_ty+                , ifFieldLabels   = (patSynFieldLabels ps)+                }+  where+    (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps+    univ_bndrs = patSynUnivTyVarBinders ps+    ex_bndrs   = patSynExTyVarBinders ps+    (env1, univ_bndrs') = tidyForAllTyBinders emptyTidyEnv univ_bndrs+    (env2, ex_bndrs')   = tidyForAllTyBinders env1 ex_bndrs+    to_if_pr (name, _type, needs_dummy) = (name, needs_dummy)++{-+************************************************************************+*                                                                      *+        Conversion of other things+*                                                                      *+************************************************************************+-}++toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang+toIfaceBang _    HsLazy              = IfNoBang+toIfaceBang _   (HsUnpack Nothing)   = IfUnpack+toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))+toIfaceBang _   (HsStrict _)         = IfStrict++toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang+toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang++toIfaceLetBndr :: Id -> IfaceLetBndr+toIfaceLetBndr id  = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))+                               (toIfaceType (idType id))+                               (toIfaceIdInfo (idInfo id))+                               (idJoinPointHood id)+  -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr+  -- has left on the Id.  See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax++toIfaceTopBndr :: Id -> IfaceTopBndrInfo+toIfaceTopBndr id+  = if isExternalName name+      then IfGblTopBndr name+      else IfLclTopBndr (mkIfLclName (occNameFS (getOccName id))) (toIfaceType (idType id))+                        (toIfaceIdInfo (idInfo id)) (toIfaceIdDetails (idDetails id))+  where+    name = getName id++toIfaceIdDetails :: IdDetails -> IfaceIdDetails+toIfaceIdDetails VanillaId                      = IfVanillaId+toIfaceIdDetails (WorkerLikeId dmds)            = IfWorkerLikeId dmds+toIfaceIdDetails (DFunId {})                    = IfDFunId+toIfaceIdDetails (RecSelId { sel_naughty = n+                           , sel_tycon = tc+                           , sel_fieldLabel = fl }) =+  let (iface, first_con) = case tc of+                RecSelData ty_con    -> ( Left (toIfaceTyCon ty_con), dataConName $ head $ tyConDataCons ty_con)+                RecSelPatSyn pat_syn -> ( Right (patSynToIfaceDecl pat_syn), patSynName pat_syn)+  in IfRecSelId iface first_con n fl++  -- The remaining cases are all "implicit Ids" which don't+  -- appear in interface files at all+toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other)+                         IfVanillaId   -- Unexpected; the other++toIfaceIdInfo :: IdInfo -> IfaceIdInfo+toIfaceIdInfo id_info+  = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,+               inline_hsinfo,  unfold_hsinfo]+               -- NB: strictness and arity must appear in the list before unfolding+               -- See GHC.IfaceToCore.tcUnfolding+  where+    ------------  Arity  --------------+    arity_info = arityInfo id_info+    arity_hsinfo | arity_info == 0 = Nothing+                 | otherwise       = Just (HsArity arity_info)++    ------------ Caf Info --------------+    caf_info   = cafInfo id_info+    caf_hsinfo = case caf_info of+                   NoCafRefs -> Just HsNoCafRefs+                   _other    -> Nothing++    ------------  Strictness  --------------+        -- No point in explicitly exporting TopSig+    sig_info = dmdSigInfo id_info+    strict_hsinfo | not (isNopSig sig_info) = Just (HsDmdSig sig_info)+                  | otherwise               = Nothing++    ------------  CPR --------------+    cpr_info = cprSigInfo id_info+    cpr_hsinfo | cpr_info /= topCprSig = Just (HsCprSig cpr_info)+               | otherwise             = Nothing+    ------------  Unfolding  --------------+    unfold_hsinfo = toIfUnfolding loop_breaker (realUnfoldingInfo id_info)+    loop_breaker  = isStrongLoopBreaker (occInfo id_info)++    ------------  Inline prag  --------------+    inline_prag = inlinePragInfo id_info+    inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing+                  | otherwise = Just (HsInline inline_prag)++--------------------------+toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem+toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs+                                , uf_src = src+                                , uf_cache = cache+                                , uf_guidance = guidance })+  = Just $ HsUnfold lb $+    IfCoreUnfold src cache (toIfGuidance src guidance) (toIfaceExpr rhs)+        -- Yes, even if guidance is UnfNever, expose the unfolding+        -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would+        -- have stuck in NoUnfolding.  For supercompilation we want+        -- to see that unfolding!++toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })+  = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))+      -- No need to serialise the data constructor;+      -- we can recover it from the type of the dfun++toIfUnfolding _ (OtherCon {}) = Nothing+  -- The binding site of an Id doesn't have OtherCon, except perhaps+  -- where we have called trimUnfolding; and that evald'ness info is+  -- not needed by importing modules++toIfUnfolding _ BootUnfolding = Nothing+  -- Can't happen; we only have BootUnfolding for imported binders++toIfUnfolding _ NoUnfolding = Nothing++toIfGuidance :: UnfoldingSource -> UnfoldingGuidance -> IfGuidance+toIfGuidance src guidance+  | UnfWhen arity unsat_ok boring_ok <- guidance+  , isStableSource src = IfWhen arity unsat_ok boring_ok+  | otherwise          = IfNoGuidance++toIfaceBooleanFormula :: BF.BooleanFormula GhcRn -> IfaceBooleanFormula+toIfaceBooleanFormula = go+  where+    go (BF.Var nm   ) = IfVar    $ mkIfLclName . getOccFS . unLoc $  nm+    go (BF.And bfs  ) = IfAnd    $ map (go . unLoc) bfs+    go (BF.Or bfs   ) = IfOr     $ map (go . unLoc) bfs+    go (BF.Parens bf) = IfParens $     (go . unLoc) bf++{-+************************************************************************+*                                                                      *+        Conversion of expressions+*                                                                      *+************************************************************************+-}++toIfaceExpr :: CoreExpr -> IfaceExpr+toIfaceExpr (Var v)         = toIfaceVar v+toIfaceExpr (Lit (LitRubbish tc r)) = IfaceLitRubbish tc (toIfaceType r)+toIfaceExpr (Lit l)         = IfaceLit l+toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)+toIfaceExpr (Coercion co)   = IfaceCo   (toIfaceCoercion co)+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b)+toIfaceExpr (App f a)       = toIfaceApp f [a]+toIfaceExpr (Case s x ty as)+  | null as                 = IfaceECase (toIfaceExpr s) (toIfaceType ty)+  | otherwise               = IfaceCase (toIfaceExpr s) (mkIfLclName (getOccFS x)) (map toIfaceAlt as)+toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)+toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)+toIfaceExpr (Tick t e)      = IfaceTick (toIfaceTickish t) (toIfaceExpr e)++toIfaceOneShot :: Id -> IfaceOneShot+toIfaceOneShot id | isId id+                  , OneShotLam <- oneShotInfo (idInfo id)+                  = IfaceOneShot+                  | otherwise+                  = IfaceNoOneShot++---------------------+toIfaceTickish :: CoreTickish -> IfaceTickish+toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push+toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix+toIfaceTickish (SourceNote src (LexicalFastString names)) =+  IfaceSource src names+toIfaceTickish (Breakpoint _ ix fv) =+  IfaceBreakpoint ix (toIfaceVar <$> fv)++---------------------+toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr+toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r)+toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]++toIfaceTopBind :: Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo+toIfaceTopBind b =+  case b of+    NonRec b r -> uncurry IfaceNonRec (do_one (b, r))+    Rec prs -> IfaceRec (map do_one prs)+  where+        do_one (b, rhs) =+          let top_bndr = toIfaceTopBndr b+              rhs' = case top_bndr of+                      -- Use the existing unfolding for a global binder if we store that anyway.+                      -- See Note [Interface File with Core: Sharing RHSs]+                      IfGblTopBndr {} -> if already_has_unfolding b then IfUseUnfoldingRhs else IfRhs (toIfaceExpr rhs)+                      -- Local binders will have had unfoldings trimmed so have+                      -- to serialise the whole RHS.+                      IfLclTopBndr {} -> IfRhs (toIfaceExpr rhs)+          in (top_bndr, rhs')++        -- The sharing behaviour is currently disabled due to #22807, and relies on+        -- finished #20056 to be re-enabled.+        disabledDueTo22807 = True++        already_has_unfolding b = not disabledDueTo22807+                                && -- The identifier has an unfolding, which we are going to serialise anyway+                                hasCoreUnfolding (realIdUnfolding b)+                                -- But not a stable unfolding, we want the optimised unfoldings.+                                && not (isStableUnfolding (realIdUnfolding b))++---------------------+toIfaceAlt :: CoreAlt -> IfaceAlt+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)++---------------------+toIfaceCon :: AltCon -> IfaceConAlt+toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)+toIfaceCon (LitAlt l)   = assertPpr (not (isLitRubbish l)) (ppr l) $+                          -- assert: see Note [Rubbish literals] wrinkle (b)+                          IfaceLitAlt l+toIfaceCon DEFAULT      = IfaceDefaultAlt++---------------------+toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr+toIfaceApp (App f a) as = toIfaceApp f (a:as)+toIfaceApp (Var v) as+  = case isDataConWorkId_maybe v of+        -- We convert the *worker* for tuples into IfaceTuples+        Just dc |  saturated+                ,  Just tup_sort <- tyConTuple_maybe tc+                -> IfaceTuple tup_sort tup_args+          where+            val_args  = dropWhile isTypeArg as+            saturated = val_args `lengthIs` idArity v+            tup_args  = map toIfaceExpr val_args+            tc        = dataConTyCon dc++        _ -> mkIfaceApps (toIfaceVar v) as++toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as++mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr+mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as++---------------------+toIfaceVar :: Id -> IfaceExpr+toIfaceVar v+    | isBootUnfolding (idUnfolding v)+    = -- See Note [Inlining and hs-boot files]+      IfaceApp (IfaceApp (IfaceExt noinline_id)+                         (IfaceType (toIfaceType ty)))+               (IfaceExt name) -- don't use mkIfaceApps, or infinite loop++    | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))+                                      -- Foreign calls have special syntax++    | isExternalName name             = IfaceExt name+    | otherwise                       = IfaceLcl (mkIfLclName (occNameFS $ nameOccName name))+  where+    name = idName v+    ty   = idType v+    noinline_id | isConstraintKind (typeKind ty) = noinlineConstraintIdName+                | otherwise                      = noinlineIdName++++---------------------+toIfaceLFInfo :: Name -> LambdaFormInfo -> IfaceLFInfo+toIfaceLFInfo nm lfi = case lfi of+    LFReEntrant top_lvl arity no_fvs _arg_descr ->+      -- Exported LFReEntrant closures are top level, and top-level closures+      -- don't have free variables+      assertPpr (isTopLevel top_lvl) (ppr nm) $+      assertPpr no_fvs (ppr nm) $+      IfLFReEntrant arity+    LFThunk top_lvl no_fvs updatable sfi mb_fun ->+      -- Exported LFThunk closures are top level (which don't have free+      -- variables) and non-standard (see cgTopRhsClosure)+      assertPpr (isTopLevel top_lvl) (ppr nm) $+      assertPpr no_fvs (ppr nm) $+      assertPpr (sfi == NonStandardThunk) (ppr nm) $+      IfLFThunk updatable mb_fun+    LFCon dc ->+      IfLFCon (dataConName dc)+    LFUnknown mb_fun ->+      IfLFUnknown mb_fun+    LFUnlifted ->+      IfLFUnlifted+    LFLetNoEscape ->+      panic "toIfaceLFInfo: LFLetNoEscape"+++{- Note [Inlining and hs-boot files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example (#10083, #12789):++    ---------- RSR.hs-boot ------------+    module RSR where+      data RSR+      eqRSR :: RSR -> RSR -> Bool++    ---------- SR.hs ------------+    module SR where+      import {-# SOURCE #-} RSR+      data SR = MkSR RSR+      eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2++    ---------- RSR.hs ------------+    module RSR where+      import SR+      data RSR = MkRSR SR -- deriving( Eq )+      eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2)+      foo x y = not (eqRSR x y)++When compiling RSR we get this code++    RSR.eqRSR :: RSR -> RSR -> Bool+    RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) ->+                case ds1 of _ { RSR.MkRSR s1 ->+                case ds2 of _ { RSR.MkRSR s2 ->+                SR.eqSR s1 s2 }}++    RSR.foo :: RSR -> RSR -> Bool+    RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y)++Now, when optimising foo:+    Inline eqRSR (small, non-rec)+    Inline eqSR  (small, non-rec)+but the result of inlining eqSR from SR is another call to eqRSR, so+everything repeats.  Neither eqSR nor eqRSR are (apparently) loop+breakers.++Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR+with `noinline eqRSR`, so that eqRSR doesn't get inlined.  This means+that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly+as would have been the case if `foo` had been defined in SR.hs (and+marked as a loop-breaker).++But how do we arrange for this to happen?  There are two ingredients:++    1. When we serialize out unfoldings to IfaceExprs (toIfaceVar),+    for every variable reference we see if we are referring to an+    'Id' that came from an hs-boot file.  If so, we add a `noinline`+    to the reference.  See Note [noinlineId magic]+    in GHC.Types.Id.Make++    2. But how do we know if a reference came from an hs-boot file+    or not?  We could record this directly in the 'IdInfo', but+    actually we deduce this by looking at the unfolding: 'Id's+    that come from boot files are given a special unfolding+    (upon typechecking) 'BootUnfolding' which say that there is+    no unfolding, and the reason is because the 'Id' came from+    a boot file.++Here is a solution that doesn't work: when compiling RSR,+add a NOINLINE pragma to every function exported by the boot-file+for RSR (if it exists).  Doing so makes the bootstrapped GHC itself+slower by 8% overall (on #9872a-d, and T1969: the reason+is that these NOINLINE'd functions now can't be profitably inlined+outside of the hs-boot loop.++Note [Interface File with Core: Sharing RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++IMPORTANT: This optimisation is currently disabled due to #22807, it can be+           re-enabled once #22056 is implemented.++In order to avoid duplicating definitions for bindings which already have unfoldings+we do some minor headstands to avoid serialising the RHS of a definition if it has+*any* unfolding.++* Only global things have unfoldings, because local things have had their unfoldings stripped.+* For any global thing which has an unstable unfolding, we just use that.++In order to implement this sharing:++* When creating the interface, check the criteria above and don't serialise the RHS+  if such a case.++* When reading an interface, look at the realIdUnfolding, and then the+  maybeUnfoldingTemplate.  See `tc_iface_binding` for where this happens.++There are two main reasons why the mi_extra_decls field exists rather than shoe-horning+all the core bindings++1. mi_extra_decls retains the recursive group structure of the original program which+   is very convenient as otherwise we would have to do the analysis again when loading+   the program.+2. There are additional local top-level bindings which don't make it into mi_decls. It's+   best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash.++-}
+ GHC/CoreToIface.hs-boot view
@@ -0,0 +1,18 @@+module GHC.CoreToIface where++import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion )+import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr+                                    , IfaceCoercion, IfaceTyLit, IfaceAppArgs )+import GHC.Types.Var ( VarBndr, TyCoVar )+import GHC.Types.Var.Env ( TidyEnv )+import GHC.Core.TyCon ( TyCon )+import GHC.Types.Var.Set( VarSet )++-- For GHC.Core.TyCo.Rep+toIfaceTypeX :: VarSet -> Type -> IfaceType+toIfaceTyLit :: TyLit -> IfaceTyLit+toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag]+toIfaceTyCon :: TyCon -> IfaceTyCon+toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs+toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion+tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs
+ GHC/CoreToStg.hs view
@@ -0,0 +1,900 @@+{-# 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+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.Make+import GHC.Stg.Utils (allowTopLevelConApp)++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 )+import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )+import GHC.Types.Literal+import GHC.Types.ForeignCall+import GHC.Types.IPE++import GHC.Unit.Module+import GHC.Platform        ( Platform )+import GHC.Platform.Ways+import GHC.Builtin.PrimOps++import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Panic++import Control.Monad (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.++-- 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.”)++-- Note [Saturation of data constructors in STG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We guarantee that `StgConApp` is an exactly-saturated application of a data+-- constructor worker.+--+-- * If the data constructor is /under/-saturated we just fall through to build+--   a `StgApp`.  Remember, data constructor workers have a regular top-level definition+--   (injected by GHC.CoreToStg.Prep.mkDataConWorkers) so we can partially apply+--   that function.+--+-- * If the data constructor is /over/-saturated, which can happen (see #23865) we again+--   fall through to `StgApp`.  That will fail horribly at runtime (by applying data+--   constructor to an argument) but it should be in dead code, and at least the compiler+--   itself won't crash.  (We could inject an error-thunk instead.)+++-- --------------------------------------------------------------+-- 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 <- coreToMkStgRhs bndr rhs++       ; let (stg_rhs, ccs') =+               mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))+                           (coreToStg_AutoSccsOnIndividualCafs 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 coreToMkStgRhs.++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 [] [] (idType v)+coreToStgExpr (Coercion _)+  -- See Note [Coercion tokens]+  = coreToStgApp coercionTokenId [] [] (idType coercionTokenId)++coreToStgExpr expr@(App _ _)+  = case app_head of+      Var f -> coreToStgApp f args ticks res_ty -- Regular application+      Lit l | isLitRubbish l  -- Discard arguments if head is LitRubbish+                              -- Recompute representation, because in+                              -- '(RUBBISH[rep] x) :: (T :: TYPE rep2)'+                              -- rep might not be equal to rep2+            -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep res_ty)++      _     -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)+    where+      res_ty                  = exprType expr+      (app_head, args, ticks) = myCollectArgs expr res_ty++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 bndr _ alts)+  | null alts+  -- 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 scrut++  | Just rhs <- isUnsafeEqualityCase scrut bndr alts+  -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+  = coreToStgExpr rhs++  | otherwise+  = 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+             -> [StgTickish]  -- From the application nodes+             -> Type          -- Type of the whole application+             -> CtsM StgExpr+coreToStgApp f core_args app_ticks res_ty+  = do { how_bound             <- lookupVarCts f+       ; (stg_args, arg_ticks) <- coreToStgArgs core_args+       ; let app = mkStgApp f how_bound core_args stg_args res_ty+             all_ticks =  app_ticks ++ arg_ticks++       -- Forcing these fixes a leak in the code generator,+       -- noticed while profiling for #4367+       ; app `seq` return (foldr add_tick app all_ticks)}+  where+    add_tick !t !e = StgTick t e++mkStgApp :: Id -> HowBound -> [CoreArg] -> [StgArg] -> Type -> StgExpr+mkStgApp f how_bound core_args stg_args res_ty+  = case idDetails f of+      DataConWorkId dc+        | exactly_saturated  -- See Note [Saturation of data constructors in STG]+        -> if isUnboxedSumDataCon dc then+              StgConApp dc NoNumber stg_args (sumPrimReps core_args)+           else+              StgConApp dc NoNumber stg_args []++      -- 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 stg_args) $+                          StgOpApp (StgPrimOp op) stg_args res_ty++      -- A call to some primitive Cmm function.+      FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)+                                PrimCallConv _))+                       -> assert exactly_saturated $+                          StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) stg_args res_ty++      -- A regular foreign call.+      FCallId call     -> assert exactly_saturated $+                          StgOpApp (StgFCallOp call (idType f)) stg_args res_ty++      TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args)++      _other           -> StgApp f stg_args+  where+    -- 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+    n_val_args = length stg_args  -- StgArgs are all value arguments+    exactly_saturated  = f_arity == n_val_args+++-- Given Core arguments to an unboxed sum datacon, return the 'PrimRep's+-- of every alternative. For example, in (#_|#) @LiftedRep @IntRep @Int @Int# 0+-- the arguments are [Type LiftedRep, Type IntRep, Type Int, Type Int#, 0]+-- and we return the list [[LiftedRep], [IntRep]].+-- See Note [Representations in StgConApp] in GHC.Stg.Unarise.+sumPrimReps :: [CoreArg] -> [[PrimRep]]+sumPrimReps (Type ty : args) | isRuntimeRepKindedTy ty+  = runtimeRepPrimRep (text "sumPrimReps") ty : sumPrimReps args+sumPrimReps _ = []+-- ---------------------------------------------------------------------------+-- Argument lists+-- This is the guy that turns applications into A-normal form+-- ---------------------------------------------------------------------------++getStgArgFromTrivialArg :: HasDebugCallStack => CoreArg -> StgArg+-- A (non-erased) trivial CoreArg corresponds to an atomic StgArg.+-- CoreArgs may not immediately look trivial, e.g., `case e of {}` or+-- `case unsafeequalityProof of UnsafeRefl -> e` might intervene.+-- Good thing we can just call `trivial_expr_fold` here.+getStgArgFromTrivialArg e = trivial_expr_fold StgVarArg StgLitArg panic panic e+  where+    panic = pprPanic "getStgArgFromTrivialArg" (ppr e)++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 (arg : args) = do         -- Non-type argument+    (stg_args, ticks) <- coreToStgArgs args+    -- We know that `arg` must be trivial, but it may contain Ticks.+    -- Example from test case `decodeMyStack`:+    --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])+    -- Note that unfortunately the Tick is not at the top.+    -- So we'll traverse the expression twice:+    --   * Once with `stripTicksT` (which collects *all* ticks from the expression)+    --   * and another time with `getStgArgFromTrivialArg`.+    -- Since the argument is trivial, the only place the Tick can occur is+    -- somehow wrapping a variable (give or take type args, as above).+    platform <- getPlatform+    let arg_ty = exprType arg+        ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)+        arg' = getStgArgFromTrivialArg arg+        arg_rep = typePrimRep arg_ty+        stg_arg_rep = stgArgRep arg'+        bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)++    massertPpr (length ticks' <= 1) (text "More than one Tick in trivial arg:" <+> ppr arg)+    warnPprTraceM bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg)++    return (arg' : stg_args, ticks' ++ ticks)++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 <- coreToMkStgRhs bndr rhs+    return (mkStgRhs bndr new_rhs)++-- Convert the RHS of a binding from Core to STG. This is a wrapper around+-- coreToStgExpr that can handle value lambdas.+coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs+coreToMkStgRhs bndr expr = do+  let (args, body) = myCollectBinders expr+  let args'        = filterStgBinders args+  extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do+    body' <- coreToStgExpr body+    let mk_rhs = MkStgRhs+          { rhs_args = args'+          , rhs_expr = body'+          , rhs_type = exprType body+          , rhs_is_join = isJoinId bndr+          }+    pure mk_rhs++-- ---------------------------------------------------------------------------+-- 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++-- 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.+-- INVARIANT: If the app head is trivial, return the atomic Var/Lit that was+-- wrapped in casts, empty case, ticks, etc.+-- So keep in sync with 'exprIsTrivial'.+myCollectArgs :: HasDebugCallStack+              => CoreExpr -> Type -> (CoreExpr, [CoreArg], [StgTickish])+myCollectArgs expr res_ty+  = go expr [] []+  where+    go h@(Var f) as ts+      | isUnaryClassId f, (the_arg:as') <- dropWhile isTypeArg as+      = go the_arg as' ts+        -- See (UCM1) in Note [Unary class magic] in GHC.Core.TyCon+        -- isUnaryClassId includes both the class op and the data-con++      | otherwise+      = (h, as, ts)++    go (App f a)  as ts = go f (a:as) ts+    go (Cast e _) as ts = go e 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]+                          -- ticks can appear in type apps+                          go e as (coreToStgTick res_ty t : ts)++    go (Case e b _ alts) as ts  -- Just like in exprIsTrivial!+                                -- Otherwise we fall over in case we encounter+                                -- `(case f a of {}) b` in the future.+       | null alts+       = assertPpr (null as) (ppr e $$ ppr as $$ ppr expr) $+                   go e [] ts -- NB: Empty case discards arguments+       | Just rhs <- isUnsafeEqualityCase e b alts+       = go rhs as ts         -- Discards unsafeCoerce in App heads++    go (Lam b e) as ts+       | isTyVar b+       = go e (drop 1 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+  }
+ GHC/CoreToStg/AddImplicitBinds.hs view
@@ -0,0 +1,151 @@+{-+(c) The University of Glasgow, 1994-2006++Add implicit bindings+-}++module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where++import GHC.Prelude++import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) )++import GHC.Unit( ModLocation(..) )++import GHC.Core+import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId )+import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe )+import GHC.Core.Class( classAllSelIds )++import GHC.Types.Name+import GHC.Types.Tickish( GenTickish( SourceNote ) )+import GHC.Types.Id( dataConWrapUnfolding_maybe )+import GHC.Types.Id.Make( mkDictSelRhs )+import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )++import GHC.Utils.Outputable+import GHC.Data.FastString+++{- *********************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+********************************************************************* -}++{- Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`addImplicitBinds` injects the so-called "implicit bindings" generated by+the TyCons of the module. Specifically:++ * Data constructor wrappers+ * Data constructor workers: see Note [Data constructor workers]+ * Class op selectors: we want curriedn versions of these too++Note that /record selector/ are injected much earlier, at the beginning+of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils.++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.++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.+-}+++addImplicitBinds :: CorePrepPgmConfig -> ModLocation+                 -> [TyCon] -> CoreProgram -> IO CoreProgram+addImplicitBinds pgm_cfg mod_loc tycons binds+  = return (implicit_binds ++ binds)+  where+    gen_debug_info = cpPgm_generateDebugInfo pgm_cfg+    implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons+++mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy+mkImplicitBinds gen_debug_info mod_loc tycon+  = classop_binds ++ datacon_binds+  where+    datacon_binds+      | isBoxedDataTyCon tycon+      = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon)+      | otherwise+      = []+      -- The 'otherwise' includes family TyCons of course, but also (less obviously)+      --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make+      --  * type data: we don't want any code for type-only stuff (#24620)++    classop_binds+      | Just cls <- tyConClass_maybe tycon+      = [ NonRec op (mkDictSelRhs cls val_index)+        | (op, val_index) <- classAllSelIds cls `zip` [0..] ]+     | otherwise+     = []++dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind]+dataConBinds gen_debug_info mod_loc data_con+  = wrapper_bind ++ worker_bind+  where+    work_id = dataConWorkId data_con+    wrap_id = dataConWrapId data_con+    worker_bind  = [NonRec work_id (add_tick (Var work_id))]+      -- worker_bind: the ice is thin here, but it works:+      --              CorePrep will eta-expand it+    wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of+                     Nothing  -> []+                     Just rhs -> [NonRec wrap_id rhs]+    add_tick = tick_it gen_debug_info mod_loc (getName data_con)++tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr+-- If we want to generate debug info, we put a source note on the+-- worker. This is useful, especially for heap profiling.+tick_it generate_debug_info mod_loc 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 $+                 LexicalFastString $ mkFastString $+                 renderWithContext defaultSDocContext $ ppr name+    span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++++
+ GHC/CoreToStg/Prep.hs view
@@ -0,0 +1,2858 @@+{-# LANGUAGE ViewPatterns #-}++{-+(c) The University of Glasgow, 1994-2006+++Core pass to saturate constructors and PrimOps+-}++module GHC.CoreToStg.Prep+   ( CorePrepConfig (..)+   , CorePrepPgmConfig (..)+   , corePrepPgm+   , corePrepExpr+   )+where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Flags++import GHC.Unit++import GHC.Builtin.Names+import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim++import GHC.Core.Utils+import GHC.Core.Opt.Arity+import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )+import GHC.Core+import GHC.Core.Subst+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.Data.Maybe+import GHC.Data.OrdList+import GHC.Data.FastString+import GHC.Data.Graph.UnVar++import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Utils.Monad  ( mapAccumLM )+import GHC.Utils.Logger++import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( realWorldPrimId )+import GHC.Types.Basic+import GHC.Types.Name   ( OccName, NamedThing(..), isInternalName )+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.Unique.Supply++import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import Data.ByteString.Builder.Prim++import Control.Monad+import Data.List (intercalate)++{-+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.  ANF-isation results in additional bindings that can obscure values.+    We float these out; see Note [Floating in CorePrep].++6.  Clone all local Ids.  See Note [Cloning in CorePrep]++7.  Give each dynamic CCall occurrence a fresh unique; this is+    rather like the cloning step above.++8. Convert bignum literals into their core representation.++9. 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.++10. 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].++11. 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 [CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the syntax of the Core produced by CorePrep:++    Trivial expressions+       arg ::= lit     |  var+            |  arg ty  |  /\a. arg+            |  co      |  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.++Note [Cloning in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In CorePrep we+* Always clone non-CoVar Ids, so each has a unique Unique+* Sometimes clone CoVars and TyVars++We always clone non-CoVarIds, for three reasons++1. Things associated with labels in the final code must be truly unique in+   order to avoid labels being shadowed in the final output.++2. 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.++3. 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.++Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need+that (they are erased), and doing so would be tiresome because then we'd need+to substitute in types and coercions.  But sometimes need to: see+Note [Cloning CoVars and TyVars]++Note [Cloning CoVars and TyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally we don't need to clone TyVars and CoVars, but there is one occasion+when we do (see #24463).  When we have+    case unsafeEqualityProof ... of UnsafeRefl g -> ...+we try to float it, using UnsafeEqualityCase.+Why?  See (U3) in Note [Implementing unsafeCoerce]++Alas, floating it widens the scope of `g`, and that led to catastrophe in+#24463, when two identically-named g's shadowed.++Solution: clone `g`; see `cpCloneCoVarBndr`.++BUT once we clone `g` we must apply the cloning substitution to all types+and coercions.  But that in turn means that, given a binder like+   /\ (a :: kind |> g). blah+we must substitute in a's kind, and hence need to substitute for `a`+itself in `blah`.++So our plan is:+  * Maintain a full Subst in `cpe_subst`++  * Clone a CoVar when we we meet an `isUnsafeEqualityCase`;+    otherwise TyVar/CoVar binders are never cloned.++  * So generally the TCvSubst is empty++  * Apply the substitution to type and coercion arguments in Core; but+    happily `substTy` has a no-op short-cut for an empty TCvSubst, so this+    is usually very cheap.++  * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution;+    in that case just do nothing+-}++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 -> CoreProgram+            -> IO CoreProgram+corePrepPgm logger cp_cfg pgm_cfg+            this_mod binds =+    withTiming logger+               (text "CorePrep"<+>brackets (ppr this_mod))+               (\a -> a `seqList` ()) $ do+    let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg++    us <- mkSplitUniqSupply 's'+    let+        floats = initUs_ us $+                 corePrepTopBinds initialCorePrepEnv binds+        binds_out = deFloatTop floats++    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 `zipFloats` floatss)++{- *********************************************************************+*                                                                      *+                The main code+*                                                                      *+********************************************************************* -}++{- Note [Floating in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ANFisation risks producing a lot of nested lets that obscures values:+  let v = (:) (f 14) [] in e+  ==> { ANF in CorePrep }+  let v = let sat = f 14 in (:) sat [] in e+Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that+allocates a thunk for `sat` and then allocates the cons cell.+Hence we carry around a bunch of floated bindings with us so that we again+expose the values:+  let v = let sat = f 14 in (:) sat [] in e+  ==> { Float sat }+  let sat = f 14 in+  let v = (:) sat [] in e+(We will not do this transformation if `v` does not become a value afterwards;+see Note [wantFloatLocal].)+If `v` is bound at the top-level, we might even float `sat` to top-level;+see Note [Floating out of top level bindings].+For nested let bindings, we have to keep in mind Note [Core letrec invariant]+and may exploit strict contexts; see Note [wantFloatLocal].++There are 3 main categories of floats, encoded in the `FloatingBind` type:++  * `Float`: A floated binding, as `sat` above.+    These come in different flavours as described by their `FloatInfo` and+    `BindInfo`, which captures how far the binding can be floated and whether or+    not we want to case-bind. See Note [BindInfo and FloatInfo].+  * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings;+    see (U3) of Note [Implementing unsafeCoerce].+    It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable`+    (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to+    bind the unsafe coercion field of the Refl constructor.+  * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep].++It is quite essential that CorePrep *does not* rearrange the order in which+evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers+the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does+not attempt to reorder the telescope of Floats or float out out of non-floated+binding sites (such as Case alts) in the first place; for that it would have to+do some kind of data dependency analysis.++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 [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+-}++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+             lev = typeLevity (idType bndr)+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive+                                   dmd lev 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+                     = snocFloat floats new_float++             (new_float, _bndr2) = mkNonRecFloat env lev 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 Lifted env')+                           bndrs1 rhss++       ; let (zipManyFloats -> floats, rhss1) = unzip stuff+             -- Glom all floats into the Rec, *except* FloatStrings; see+             -- see Note [ANF-ising literal string arguments], Wrinkle (FS1)+             is_lit (Float (NonRec _ rhs) CaseBound TopLvlFloatable) = exprIsTickedString rhs+             is_lit _                                                = False+             (string_floats, top) = partitionOL is_lit (fs_binds floats)+                 -- Strings will *always* be in `top_floats` (we made sure of+                 -- that in `snocOL`), so that's the only field we need to+                 -- partition.+             floats'   = floats { fs_binds = top }+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (getFloats floats')+       -- use env below, so that we reset cpe_rec_ids+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),+                 snocFloat (emptyFloats { fs_binds = string_floats })+                           (Float (Rec all_pairs) LetBound TopLvlFloatable),+                 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 (Float bind bound _) prs2+      | bound /= CaseBound+      || all (not . isUnliftedType . idType) (bindersOf bind)+           -- The latter check is hit in -O0 (i.e., flavours quick, devel2)+           -- for dictionary args which haven't been floated out yet, #24102.+           -- They are preferably CaseBound, but since they are lifted we may+           -- just as well put them in the Rec, in contrast to lifted bindings.+      = case bind of+          NonRec x e -> (x,e) : prs2+          Rec prs1 -> prs1 ++ prs2+    add_float f _ = pprPanic "cpeBind" (ppr f)+++---------------+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity+        -> CorePrepEnv -> OutId -> CoreExpr+        -> UniqSM (Floats, CpeRhs)+-- Used for all bindings+-- The binder is already cloned, hence an OutId+cpePair top_lvl is_rec dmd lev env0 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+       ; let dec = want_float_from_rhs floats1 rhs1+       ; (floats2, rhs2) <- executeFloatDecision env dec 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 env (idType bndr)+                        ; let (float, v') = mkNonRecFloat env Lifted v rhs2+                        ; return ( snocFloat floats2 float+                                 , cpeEtaExpand arity (Var v')) })++        -- Wrap floating ticks+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3++       ; return (floats4, rhs4) }+  where+    env = pushBinderContext bndr env0++    arity = idArity bndr        -- We must match this arity++    want_float_from_rhs floats rhs+      | isTopLevel top_lvl = wantFloatTop floats+      | otherwise          = wantFloatLocal is_rec dmd lev floats rhs++{- 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 join_arity = case idJoinPointHood bndr of+                 JoinPoint join_arity -> join_arity+                 _ -> panic "cpeJoinPair"+             (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 lit)+  | LitNumber LitNumBigNat i <- lit+    = cpeBigNatLit env i+  | otherwise = 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 `appFloats` 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 (FloatTick tickish `consFloat` floats, body) }+  | otherwise+  = do { body <- cpeBodyNF env expr+       ; return (emptyFloats, mkTick tickish' body) }+  where+    tickish' | Breakpoint ext bid fvs <- tickish+             -- See also 'substTickish'+             = Breakpoint ext bid (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') }++cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _])+  -- See (U3) in Note [Implementing unsafeCoerce]+  -- We need make the Case float, otherwise we get+  --   let x = case ... of UnsafeRefl co ->+  --           let y = expr in+  --           K y+  --   in f x+  -- instead of+  --   case ... of UnsafeRefl co ->+  --   let y = expr in+  --   let x = K y+  --   in f x+  -- Note that `x` is a value here. This is visible in the GHCi debugger tests+  -- (such as `print003`).+  | Just rhs <- isUnsafeEqualityCase scrut bndr alts+  = do { (floats_scrut, scrut) <- cpeBody env scrut++       ; (env, bndr')  <- cpCloneBndr env bndr+       ; (env, covar') <- cpCloneCoVarBndr env covar+                          -- Important: here we clone the CoVar+                          -- See Note [Cloning CoVars and TyVars]++         -- Up until here this should do exactly the same as the regular code+         -- path of `cpeRhsE Case{}`.+       ; (floats_rhs, rhs) <- cpeBody env rhs+         -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might+         -- become a value+       ; let case_float = UnsafeEqualityCase scrut bndr' con [covar']+         -- NB: It is OK to "evaluate" the proof eagerly.+         --     Usually there's the danger that we float the unsafeCoerce out of+         --     a branching Case alt. Not so here, because the regular code path+         --     for `cpeRhsE Case{}` will not float out of alts.+             floats = snocFloat floats_scrut case_float `appFloats` floats_rhs+       ; return (floats, rhs) }++cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs])+  -- See item (SEQ4) of Note [seq# magic]. We want to match+  --   case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s']+  -- and simplify to rhs[s]. Triggers in T15226.+  | isUnboxedTupleDataCon dc+  , (Var f,[_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut+  , f `hasKey` seqHashKey+  , exprOkToDiscard arg+      -- ok-to-discard, because we want to discard the evaluation of `arg`.+      -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as+      -- `quotInt# 1# 0#`, but not ThrowsException primops.+      -- See Note [Classifying primop effects]+      -- and Note [Transformations affected by primop effects] for why this is+      -- the correct choice.+  , Var token_in' <- lookupCorePrepEnv env token_in+  , isDeadBinder res, isDeadBinder bndr+      -- Check that bndr and res are dead+      -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier+      -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info]+      -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a+      -- variable, and in that case the zapping doesn't happen; see that Note.+  = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs++cpeRhsE env (Case scrut bndr ty alts)+  = do { (floats, scrut') <- cpeBody env scrut+       ; (env', bndr2) <- cpCloneBndr env bndr+       ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding+       ; let alts'+               | cp_catchNonexhaustiveCases $ cpe_config env+                 -- Suppose the alternatives do not cover all the data constructors of the type.+                 -- That may be fine: perhaps an earlier case has dealt with the missing cases.+                 -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag+                 -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases+                 -- (This alternative will only be taken if there is a bug in GHC.)+               , not (altsAreExhaustive alts)+               = addDefault alts (Just err)+               | otherwise = alts+               where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"+       ; alts'' <- mapM (sat_alt env') alts'++       ; case alts'' of+           [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]+             | let float = mkCaseFloat bndr3 scrut'+             -> return (snocFloat floats float, rhs)+           _ -> return (floats, Case scrut' bndr3 (cpSubstTy env 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 env rhs+       ; return (floats1 `appFloats` floats2, body) }++--------+rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)+-- Remove top level lambdas by let-binding++rhsToBody env (Tick t expr)+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations+  = do { (floats, expr') <- rhsToBody env expr+       ; return (floats, mkTick t expr') }++rhsToBody env (Cast e co)+        -- You can get things like+        --      case e of { p -> coerce t (\s -> ...) }+  = do { (floats, e') <- rhsToBody env e+       ; return (floats, Cast e' co) }++rhsToBody env 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 env (exprType rhs)+       ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable+       ; return (unitFloat float, Var fn) }+  where+    (bndrs,_) = collectBinders expr++rhsToBody _env 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 = AIApp  CoreArg -- NB: Not a CpeApp yet+             | AICast Coercion+             | AITick CoreTickish++instance Outputable ArgInfo where+  ppr (AIApp arg) = text "app" <+> ppr arg+  ppr (AICast co) = text "cast" <+> ppr co+  ppr (AITick 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 (instead of CpeApp) 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 (AIApp arg : as)+        go (Cast fun co)      as+            = go fun (AICast 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 (AITick 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) (AIApp Type{} : AIApp 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) (AIApp _runtimeRep@Type{} : AIApp _type@Type{} : AIApp 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 (AIApp 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 (AIApp (Var realWorldPrimId) : rest)+             -- TODO: What about casts?+        where+          has_value_arg [] = False+          has_value_arg (AIApp arg:_rest)+            | not (isTyCoArg arg) = True+          has_value_arg (_:rest) = has_value_arg rest++    -- See Note [seq# magic]. This is the step for CorePrep+    cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty@Type{}, AIApp thing, AIApp token]+        | f `hasKey` seqHashKey+        -- seq# thing token+        --    ==>   case token of s   { __DEFAULT ->+        --          case thing of res { __DEFAULT -> (# token, res#) } },+        -- allocating CaseBound Floats for token and thing as needed+        = do { (floats1, token) <- cpeArg env topDmd token+             ; (floats2, thing) <- cpeBody env thing+             ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty+             ; let tup = mkCoreUnboxedTuple [token, Var case_bndr]+             ; let float = mkCaseFloat case_bndr thing+             ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }++    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+            AICast {} -> go infos n+            AITick 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+            AIApp 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                     -- INVARIANT: These floats don't bind anything that is in the CpeApp!+                                      -- Just stuff floated out from the head of the application.+        -> [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); substitution not applied+        -> CpeApp    -- Substitution already applied+        -> 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++      AIApp (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++      AIApp (Coercion co)+        -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth+        where+           co' = cpSubstCo env co++      AIApp 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 env ss1 arg+        rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)++      AICast 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]+      AITick 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' (snocFloat 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 Core program like,++    data Foo = Foo Addr#+    foo = Foo "turtle"#++String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence+they are non-atomic in STG.+With -O1, FloatOut is likely to have floated most of these strings to top-level,+not least to give CSE a chance to deduplicate strings early (before the+linker, that is).+(Notable exceptions seem to be applications of 'unpackAppendCString#'.)+But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to++    s = "turtle"#+    foo = Foo s++(String literals are the only kind of binding allowed at top-level and hence+their `FloatInfo` is `TopLvlFloatable`.)++This appears to lead to bad code if the arg is under a lambda, because CorePrep+doesn't float out of RHSs, e.g., (T23270)++    foo x = ... patError "turtle"# ...+==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ...++This looks bad because it evals an HNF on every call.+But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm:++  [section ""cstring" . cB4_str" {+       cB4_str:+           I8[] "turtle"+   }+  ...+  _sAG::I64 = cB4_str;+  R2 = _sAG::I64;+  Sp = Sp + 8;+  call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8;++Wrinkles:++(FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway;+      otherwise we'd try to bind a string literal in a letrec, violating+      Note [Core letrec invariant]. Since we know that literals don't have+      free variables, we float further.+      Arguably, we could just as well relax the letrec invariant for+      string literals, or anthing that is a value (lifted or not).+      This is tracked in #24036.+-}++-- 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+             lev    = typeLevity arg_ty+             dec    = wantFloatLocal NonRecursive dmd lev floats1 arg1+       ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1+                -- Else case: arg1 might have lambdas, and we can't+                --            put them inside a wrapBinds++       -- Now ANF-ise any non-trivial argument+       -- NB: "non-trivial" includes string literals;+       -- see Note [ANF-ising literal string arguments]+       ; if exprIsTrivial arg2+         then return (floats2, arg2)+         else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty+                       -- See Note [Pin demand info on floats]+                 ; let arity = cpeArgArity env dec floats1 arg2+                       arg3  = cpeEtaExpand arity arg2+                       -- See Note [Eta expansion of arguments in CorePrep]+                 ; let (arg_float, v') = mkNonRecFloat env lev v arg3+                 ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2)+                 ; return (snocFloat floats2 arg_float, varToCoreExpr v') }+       }++cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity+-- ^ See Note [Eta expansion of arguments in CorePrep]+-- Returning 0 means "no eta-expansion"; see cpeEtaExpand+cpeArgArity env float_decision floats1 arg+  | FloatNone <- float_decision+         -- If we did not float+  , not (isEmptyFloats floats1)+         -- ... but there was something to float+  , fs_info floats1 `floatsAtLeastAsFarAs` LazyContextFloatable+         -- ... and we could have floated it out of a lazy arg+  = 0    -- ... then short-cut, because floats1 is likely expensive!+         -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]++  | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2+  , not (eta_would_wreck_join arg)+            -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]+  = case exprEtaExpandArity ao arg of+      Nothing -> 0+      Just at -> arityTypeArity at++  | otherwise+  = exprArity arg -- this is cheap enough for -O0++eta_would_wreck_join :: CoreExpr -> Bool+-- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in+-- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]+eta_would_wreck_join (Let bs e)        = isJoinBind bs || eta_would_wreck_join e+eta_would_wreck_join (Lam _ e)         = eta_would_wreck_join e+eta_would_wreck_join (Cast e _)        = eta_would_wreck_join e+eta_would_wreck_join (Tick _ e)        = eta_would_wreck_join e+eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts)+eta_would_wreck_join _                 = False++maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs+maybeSaturate fn expr n_args unsat_ticks+  | hasNoBinding fn        -- There's no binding+    -- See Note [Eta expansion of hasNoBinding things in CorePrep]+  = 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 (idJoinPointHood 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 $ (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..++{- 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 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.++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++Note [Eta expansion of arguments in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to++  let t = g x+  in f t++We really don't want that `t` to be a thunk! That just wastes runtime, updating+a thunk with a PAP etc. The code generator could in principle allocate a PAP,+but in fact it does not know how to do that -- it's easier just to eta-expand:++  let t = \y. g x y+  in f t++To what arity should we eta-expand the argument? `cpeArg` uses two strategies,+governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O):++  1. Cheap, with -O0: just use `exprArity`.+  2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`,+     same function the Simplifier uses to eta expand RHSs and lambda bodies.++The only reason for using (1) rather than (2) is to keep compile times down.+Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and+T5321*. However, Plan (2) catches cases that (1) misses.+For example (#23083, assuming -fno-pedantic-bottoms):++  let t = case z of __DEFAULT -> g x+  in f t++to++  let t = \y -> case z of __DEFAULT -> g x y+  in f t++Note that there is a missed opportunity in eta expanding `t` earlier, in the+Simplifier: It would allow us to inline `g`, potentially enabling further+simplification. But then we could have inlined `g` into the PAP to begin with,+and that is discussed in #23150; hence we needn't worry about that in CorePrep.++There is a nasty Wrinkle:++(EA1) When eta expanding an argument headed by a join point, we might get+      "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts+      it.  This crap means the output does not conform to the syntax in+      Note [CorePrep invariants], which then makes later passes crash (#25033).+      Consider++        f (join j x = rhs in ...(j 1)...(j 2)...)++      where the argument has arity 1. We might be tempted to eta expand, to++        f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y)++      Why hasn't the App to `y` been pushed into the join point? That's exactly+      the crap of Note [Eta expansion for join points], so we have to put up+      with it here.+      In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid+      `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App+      case of `coreToStgExpr`.++      Hence, in `eta_would_wreck_join`, we check for the cases where an+      intervening join point binding in the tail context of the argument would+      make eta-expansion break Note [CorePrep invariants], in which+      case we abstain from eta expansion.++      This scenario occurs rarely; hence it's OK to generate sub-optimal code.+      The alternative would be to fix Note [Eta expansion for join points], but+      that's quite challenging due to unfoldings of (recursive) join points.++      `eta_would_wreck_join` sees if there are any join points, like `j` above+      that would be messed up.   It must look inside lambdas (#25033); consider+             f (\x. join j y = ... in ...(j 1)...(j 3)...)+      We can't eta expand that `\x` any more than we could if the join was at+      the top.  (And when there's a lambda, we don't have a thunk anyway.)++(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like+           let <binds> in rhs+      where <binds> is non-empty and can't be floated out of a lazy context (see+      `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0+      forthwith.  Without this short-cut we will call exprEtaExpandArity on the+      `arg`, and <binds> might be enormous. exprEtaExpandArity be very expensive+      on this: it uses arityType, and may look at <binds>.++      On the other hand, if float_decision = FloatAll, there will be no+      let-bindings around 'arg'; they will have floated out.  So+      exprEtaExpandArity is cheap.++      This can make a huge difference on deeply nested expressions like+         f (f (f (f (f  ...))))+      #24471 is a good example, where Prep took 25% of compile time!+-}++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 one-shot thunks.+For example,+  f (g x)+where `f` uses its argument at most once, creates a Float for `y = g x` and we+should better pin appropriate demand info on `y`.++Note [Flatten case-binds]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have the following call, where f is strict:+   f (case x of DEFAULT -> blah)+(For the moment, ignore the fact that the Simplifier will have floated that+`case` out because `f` is strict.)+In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`++    Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl++with the call `f a`.  When we wrap that `Float` we will get++   case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a }++which is a bit silly. Actually the rest of the back end can cope with nested+cases like this, but it is harder to read and we'd prefer the more direct:++   case x of y { DEFAULT ->+   case blah of a { DEFAULT -> f a }}++This is easy to avoid: turn that++   case x of DEFAULT -> blah++into a FloatingBind of its own.  This is easily done in the Case+equation for `cpsRhsE`.  Then our example will generate /two/ floats:++    Float (y = x)    CaseBound str-ctx+    Float (a = blah) CaseBound top-lvl++and we'll end up with nested cases.++Of course, the Simplifier never leaves us with an argument like this, but we+/can/ see++  data T a = T !a+  ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs++and the above footwork in cpsRhsE avoids generating a nested case.+++Note [Pin evaluatedness on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an+`evaldUnfolding` if `e` is a value.++To see why, consider a call to a CBV function, such as a DataCon worker with+*strict* fields, in an argument context, such as++  data Box a = Box !a+  ... f (Box e) ...++where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`.+After ANFisation, we want to get the very nice code++  case x +# 1# of x' ->+  let sat = I# x' in+  let sat2 = Box sat in+  f sat2++Note that Case (2) of Note [wantFloatLocal] is in effect. That is,++  * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f+  * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound.+  * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can+    be let-bound.++Hence no thunk needs to be allocated! However, in order to recognise+`Box sat` as a value, it is crucial that the newly created `sat` has an+`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`.+and we would get the far worse code++  let sat2 =+    case x +# 1# of x' ->+    case I# x' of sat' ->+    Box sat in+  f sat2++A live example of this is T24730, inspired by $walexGetByte.++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'.+     This includes DFuns `$fEqList a`, for example.+     (Could identify more in the future; see reference to !1866 below.)++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.++Very Nasty Wrinkle++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.+See Note [NON-BOTTOM-DICTS invariant] in GHC.Core.++But 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.++It is also similar to Note [Do not strictify a DFun's parameter dictionaries],+where marking recursive DFuns (of undecidable *instances*) strict in dictionary+*parameters* leads to quite the same change in termination as above.++Note [BindInfo and FloatInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `BindInfo` of a `Float` describes whether it will be case-bound or+let-bound:++  * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec.+  * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`.+                 (So always NonRec.)+                 Some case-bound things (string literals, lifted bindings)+                 can float to top-level (but not all), hence it is similar+                 to, but not the same as `StrictContextFloatable :: FloatInfo`+                 described below.++This info is used in `wrapBinds` to pick the corresponding binding form.++We want to case-bind iff the binding is (non-recursive, and) either++  * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or+  * unlifted, or+  * strictly used++The `FloatInfo` of a `Float` describes how far it can float without+(a) violating Core invariants and (b) changing semantics.++  * Any binding is at least `StrictContextFloatable`, meaning we may float it+    out of a strict context such as `f <>` where `f` is strict.+    We may never float out of a Case alternative `case e of p -> <>`, though,+    even if we made sure that `p` does not capture any variables of the float,+    because that risks sequencing guarantees of Note [seq# magic].++  * A binding is `LazyContextFloatable` if we may float it out of a lazy context+    such as `let x = <> in Just x`.+    Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval+                    such as `case divInt# x y of r -> { __DEFAULT -> I# r }`.+                    Here, we may not foat out the strict `r = divInt# x y`.++  * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can+    be bound at the top level.+    Counterexample: A strict or unlifted binding (ok-for-spec-eval or not)+                    such as `case x +# y of r -> { __DEFAULT -> I# r }`.++This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`.+Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with+the the following enum (check `mkNonRecFloat` for whether this is up to date):++   LetBoundTopLvlFloatable          (lifted or boxed values)+  CaseBoundTopLvlFloatable          (strings, ok-for-spec-eval and lifted)+  CaseBoundLazyContextFloatable     (ok-for-spec-eval and unlifted)+  CaseBoundStrictContextFloatable   (not ok-for-spec-eval and unlifted)++Although there is redundancy in the current encoding, SG thinks it is cleaner+conceptually.++See also Note [Floats and FloatDecision] for how we maintain whole groups of+floats and how far they go.++Note [Controlling Speculative Evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Most of the time, speculative evaluation in the coreprep phase has a positive+effect on performance, however we have found that some forms of speculative+evaluation can lead to large performance regressions. See #25284.++Therefore we have some flags to control which types of speculative evaluation+are done:++  -fspec-eval+     Globally enable/disable speculative evaluation ( -fno-spec-eval also turns+     off all other speculative evaluation). On by default for all+     optimization levels. Turning on this flag by itself should never cause+     a performance regression. Please open a ticket if you find any.++  -fspec-eval-dictfun+     Enable speculative evaluation for dictionary functions. Off by default+     since it can cause an increase in allocations (#24284). We have no+     examples that show a large performance improvement when turning on this+     flag. Please open a ticket if you find any.++Also see the optimization section in the User's Guide for the description of+these flags and when to use them.++Note [Floats and FloatDecision]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have a special datatype `Floats` for modelling a telescope of `FloatingBind`+and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs`+(see Note [BindInfo and FloatInfo] for the ordering).+There are several operations for creating and combining `Floats` that maintain+scoping and the cached `FloatInfo`.++When deciding whether we want to float out a `Floats` out of a binding context+such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level),+we consult the cached `FloatInfo` of the `Floats`:++  * If we want to float to the top-level (`x = <>; ...`), we check whether+    we may float-at-least-as-far-as `TopLvlFloatable`, in which case we+    respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`.+  * If we want to float locally (let or app), then the floating decision is+    described in Note [wantFloatLocal].++`executeFloatDecision` is then used to act on the particular `FloatDecision`.+-}++-- See Note [BindInfo and FloatInfo]+data BindInfo+  = CaseBound -- ^ A strict binding+  | LetBound  -- ^ A lazy or value binding+  deriving Eq++-- See Note [BindInfo and FloatInfo]+data FloatInfo+  = TopLvlFloatable+  -- ^ Anything that can be bound at top-level, such as arbitrary lifted+  -- bindings or anything that responds True to `exprIsHNF`, such as literals or+  -- saturated DataCon apps where unlifted or strict args are values.++  | LazyContextFloatable+  -- ^ Anything that can be floated out of a lazy context.+  -- In addition to any 'TopLvlFloatable' things, this includes (unlifted)+  -- bindings that are ok-for-spec that we intend to case-bind.++  | StrictContextFloatable+  -- ^ Anything that can be floated out of a strict evaluation context.+  -- That is possible for all bindings; this is the Top element of 'FloatInfo'.++  deriving Eq++instance Outputable BindInfo where+  ppr CaseBound = text "Case"+  ppr LetBound  = text "Let"++instance Outputable FloatInfo where+  ppr TopLvlFloatable = text "top-lvl"+  ppr LazyContextFloatable = text "lzy-ctx"+  ppr StrictContextFloatable = text "str-ctx"++-- See Note [Floating in CorePrep]+-- and Note [BindInfo and FloatInfo]+data FloatingBind+  = Float !CoreBind !BindInfo !FloatInfo    -- Never a join-point binding+  | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]+  | FloatTick CoreTickish++-- See Note [Floats and FloatDecision]+data Floats+  = Floats+  { fs_info  :: !FloatInfo+  , fs_binds :: !(OrdList FloatingBind)+  }++instance Outputable FloatingBind where+  ppr (Float b bi fi) = ppr bi <+> ppr fi <+> ppr b+  ppr (FloatTick t) = ppr t+  ppr (UnsafeEqualityCase scrut b k bs) = text "case" <+> ppr scrut+                                <+> text "of"<+> ppr b <> text "@"+                                <> case bs of+                                   [] -> ppr k+                                   _  -> parens (ppr k <+> ppr bs)++instance Outputable Floats where+  ppr (Floats info binds) = text "Floats" <> brackets (ppr info) <> braces (ppr binds)++lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo+lubFloatInfo StrictContextFloatable _                      = StrictContextFloatable+lubFloatInfo _                      StrictContextFloatable = StrictContextFloatable+lubFloatInfo LazyContextFloatable   _                      = LazyContextFloatable+lubFloatInfo _                      LazyContextFloatable   = LazyContextFloatable+lubFloatInfo TopLvlFloatable        TopLvlFloatable        = TopLvlFloatable++floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool+-- See Note [Floats and FloatDecision]+floatsAtLeastAsFarAs l r = l `lubFloatInfo` r == r++emptyFloats :: Floats+emptyFloats = Floats TopLvlFloatable nilOL++isEmptyFloats :: Floats -> Bool+isEmptyFloats (Floats _ b) = isNilOL b++getFloats :: Floats -> OrdList FloatingBind+getFloats = fs_binds++unitFloat :: FloatingBind -> Floats+unitFloat = snocFloat emptyFloats++floatInfo :: FloatingBind -> FloatInfo+floatInfo (Float _ _ info)     = info+floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep]+floatInfo FloatTick{}          = TopLvlFloatable      -- We filter these out in cpePair,+                                                      -- see Note [Floating Ticks in CorePrep]++-- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any+-- binding of the 'Floats'.+snocFloat :: Floats -> FloatingBind -> Floats+snocFloat floats fb =+  Floats { fs_info  = lubFloatInfo (fs_info floats) (floatInfo fb)+         , fs_binds = fs_binds floats `snocOL` fb }++-- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over+-- `b`.+consFloat :: FloatingBind -> Floats -> Floats+consFloat fb floats =+  Floats { fs_info  = lubFloatInfo (fs_info floats) (floatInfo fb)+         , fs_binds = fb `consOL`  fs_binds floats }++-- | Append two telescopes, nesting the right inside the left.+appFloats :: Floats -> Floats -> Floats+appFloats outer inner =+  Floats { fs_info  = lubFloatInfo (fs_info outer) (fs_info inner)+         , fs_binds = fs_binds outer `appOL` fs_binds inner }++-- | Zip up two `Floats`, none of which scope over the other+zipFloats :: Floats -> Floats -> Floats+-- We may certainly just nest one telescope in the other, so appFloats is a+-- valid implementation strategy.+zipFloats = appFloats++-- | `zipFloats` a bunch of independent telescopes.+zipManyFloats :: [Floats] -> Floats+zipManyFloats = foldr zipFloats emptyFloats++data FloatInfoArgs+  = FIA+  { fia_levity :: Levity+  , fia_demand :: Demand+  , fia_is_hnf :: Bool+  , fia_is_triv :: Bool+  , fia_is_string :: Bool+  , fia_is_dc_worker :: Bool+  , fia_ok_for_spec :: Bool+  }++defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs+defFloatInfoArgs bndr rhs+  = FIA+  { fia_levity = typeLevity (idType bndr)+  , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd+  , fia_is_hnf = exprIsHNF rhs+  , fia_is_triv = exprIsTrivial rhs+  , fia_is_string = exprIsTickedString rhs+  , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False+  , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval+  }++decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo)+decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,+                    fia_is_triv=is_triv, fia_is_string=is_string,+                    fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec}+  | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable)+      -- is_lifted: We currently don't allow unlifted values at the+      --            top-level or inside letrecs+      --            (but SG thinks that in principle, we should)+      -- is_triv:   Should not turn `case x of x' ->` into `let x' = x`+      --            when x is a HNF (cf. fun3 of T24264)+  | is_dc_worker          = (LetBound, TopLvlFloatable)+      -- We need this special case for nullary unlifted DataCon+      -- workers/wrappers (top-level bindings) until #17521 is fixed+  | is_string             = (CaseBound, TopLvlFloatable)+      -- String literals are unboxed (so must be case-bound) and float to+      -- the top-level+  | ok_for_spec           = (CaseBound, case lev of Unlifted -> LazyContextFloatable+                                                    Lifted   -> TopLvlFloatable)+      -- See Note [Speculative evaluation]+      -- Ok-for-spec-eval things will be case-bound, lifted or not.+      -- But when it's lifted we are ok with floating it to top-level+      -- (where it is actually bound lazily).+  | Unlifted <- lev       = (CaseBound, StrictContextFloatable)+  | isStrUsedDmd dmd      = (CaseBound, StrictContextFloatable)+      -- These will never be floated out of a lazy RHS context+  | Lifted   <- lev       = (LetBound, TopLvlFloatable)+      -- And these float freely but can't be speculated, hence LetBound++mkCaseFloat :: Id -> CpeRhs -> FloatingBind+mkCaseFloat bndr scrut+  = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info)+    --                             -- <+> ppr is_lifted <+> ppr is_strict+    --                             -- <+> ppr ok_for_spec <+> ppr evald+    --                           $$ ppr scrut) $+    Float (NonRec bndr scrut) bound info+  where+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr scrut)+      { fia_demand       = evalDmd+          -- Strict demand, so that we do not let-bind unless it's a value+      , fia_is_dc_worker = False+          -- DataCon worker *bindings* are never case-bound+      , fia_ok_for_spec  = False+          -- We do not currently float around case bindings.+          -- (ok-for-spec case bindings are unlikely anyway.)+      }++mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id)+mkNonRecFloat env lev bndr rhs+  = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)+    --                             <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted"+    --                             <+> if ok_for_spec then text "ok-for-spec" else empty+    --                             <+> if evald then text "evald" else empty+    --                           $$ ppr rhs) $+    (Float (NonRec bndr' rhs) bound info, bndr')+  where+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr rhs)+      { fia_levity = lev+      , fia_is_hnf = is_hnf+      , fia_ok_for_spec = ok_for_spec+      }++    is_hnf      = exprIsHNF rhs+    cfg         = cpe_config env++    ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs+    -- See Note [Controlling Speculative Evaluation]+    call_ok_for_spec x+      | is_rec_call x                           = False+      | not (cp_specEval cfg)                   = False+      | not (cp_specEvalDFun cfg) && isDFunId x = False+      | otherwise                               = True+    is_rec_call = (`elemUnVarSet` cpe_rec_ids env)++    -- See Note [Pin evaluatedness on floats]+    bndr' | is_hnf    = bndr `setIdUnfolding` evaldUnfolding+          | otherwise = bndr++-- | Wrap floats around an expression+wrapBinds :: Floats -> CpeBody -> CpeBody+wrapBinds floats body+  = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $+    foldrOL mk_bind body (getFloats floats)+  where+    -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here+    mk_bind f@(Float bind CaseBound _) body+      | NonRec bndr rhs <- bind+      = mkDefaultCase rhs bndr body+      | otherwise+      = pprPanic "wrapBinds" (ppr f)+    mk_bind (Float bind _ _) body+      = Let bind body+    mk_bind (UnsafeEqualityCase scrut b con bs) body+      = mkSingleAltCase scrut b con bs body+    mk_bind (FloatTick tickish) body+      = mkTick tickish body++-- | Put floats at top-level+deFloatTop :: Floats -> [CoreBind]+-- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks!+deFloatTop floats+  = foldrOL get [] (getFloats floats)+  where+    get (Float b _ TopLvlFloatable) bs+      = get_bind b : bs+    get b _  = pprPanic "deFloatTop" (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]++---------------------------------------------------------------------------++{- Note [wantFloatLocal]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x = let y = e1 in e2+  in e+Similarly for `(\x. e) (let y = e1 in e2)`.+Do we want to float `y` out of `x`?+(This is discussed in detail in the paper+"Let-floating: moving bindings to give faster programs".)++`wantFloatLocal` is concerned with answering this question.+It considers the Demand on `x`, whether or not `e2` is unlifted and the+`FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value,+strict, or ok-for-spec).++We float out if ...+  1. ... the binding context is strict anyway, so either `x` is used strictly+     or has unlifted type.+     Doing so is trivially sound and won`t increase allocations, so we+     return `FloatAll`.+     This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict:+       f (g (h 13))+       ==> { ANF }+       case (case h 13 of r -> g r) of r2 -> f r2+       ==> { Float }+       case h 13 of r -> case g r of r2 -> f r2+     The latter is easier to read and grows less stack.+  2. ... `e2` becomes a value in doing so, in which case we won't need to+     allocate a thunk for `x`/the arg that closes over the FVs of `e1`.+     In general, this is only sound if `y=e1` is `LazyContextFloatable`.+     (See Note [BindInfo and FloatInfo].)+     Nothing is won if `x` doesn't become a value+     (i.e., `let x = let sat = f 14 in g sat in e`),+     so we return `FloatNone` if there is any float that is+     `StrictContextFloatable`, and return `FloatAll` otherwise.++To elaborate on (2), consider the case when the floated binding is+`e1 = divInt# a b`, e.g., not `LazyContextFloatable`:+  let x = I# (a `divInt#` b)+  in e+this ANFises to+  let x = case a `divInt#` b of r { __DEFAULT -> I# r }+  in e+If `x` is used lazily, we may not float `r` further out.+A float binding `x +# y` is OK, though, and so every ok-for-spec-eval+binding is `LazyContextFloatable`.++Wrinkles:++ (W1) When the outer binding is a letrec, i.e.,+        letrec x = case a +# b of r { __DEFAULT -> f y r }+               y = [x]+        in e+      we don't want to float `LazyContextFloatable` bindings such as `r` either+      and require `TopLvlFloatable` instead.+      The reason is that we don't track FV of FloatBindings, so we would need+      to park them in the letrec,+        letrec r = a +# b -- NB: r`s RHS might scope over x and y+               x = f y r+               y = [x]+        in e+      and now we have violated Note [Core letrec invariant].+      So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless+      all floats are `TopLvlFloatable`.+-}++data FloatDecision+  = FloatNone+  | FloatAll++instance Outputable FloatDecision where+  ppr FloatNone = text "none"+  ppr FloatAll  = text "all"++executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)+executeFloatDecision env dec floats rhs+  = case dec of+      FloatAll                 -> return (floats, rhs)+      FloatNone+        | isEmptyFloats floats -> return (emptyFloats, rhs)+        | otherwise            -> do { (floats', body) <- rhsToBody env rhs+                                     ; return (emptyFloats, wrapBinds floats $+                                                            wrapBinds floats' body) }+            -- FloatNone case: `rhs` might have lambdas, and we can't+            -- put them inside a wrapBinds, which expects a `CpeBody`.++wantFloatTop :: Floats -> FloatDecision+wantFloatTop fs+  | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll+  | otherwise                                         = FloatNone++wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision+-- See Note [wantFloatLocal]+wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs+  |  isEmptyFloats floats -- Well yeah...+  || isStrUsedDmd rhs_dmd -- Case (1) of Note [wantFloatLocal]+  || rhs_lev == Unlifted  -- dito+  || (fs_info floats `floatsAtLeastAsFarAs` max_float_info && exprIsHNF rhs)+                          -- Case (2) of Note [wantFloatLocal]+  = FloatAll++  | otherwise+  = FloatNone+  where+    max_float_info | isRec is_rec = TopLvlFloatable+                   | otherwise    = LazyContextFloatable+                    -- See Note [wantFloatLocal], Wrinkle (W1)+                    -- for '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 [CorePrepEnv: cpe_subst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,+for these reasons:++1. To support cloning of local Ids so that they are+   all unique (see Note [Cloning in CorePrep])++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] (#12076)++   Note that, if (y::forall a. a->a), we could get+      x = lazy @(forall a.a) y @Bool+   so 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_subst` must map to CoreExprs, not Ids, which+   oc course it does++4. The TyCoVar part of the substitution is used only for+   Note [Cloning CoVars and TyVars]+-}++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_platform                :: Platform++  , cp_arityOpts               :: !(Maybe ArityOpts)+  -- ^ Configuration for arity analysis ('exprEtaExpandArity').+  -- See Note [Eta expansion of arguments in CorePrep]+  -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead+  , cp_specEval                :: !Bool+  -- ^ Whether to perform speculative evaluation+  -- See Note [Controlling Speculative Evaluation]+  , cp_specEvalDFun            :: !Bool+  -- ^ Whether to perform speculative evaluation on DFuns+  }++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_subst :: Subst  -- ^ See Note [CorePrepEnv: cpe_subst]++        , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]++        , cpe_context :: [OccName] -- ^ See Note [Binder context]+    }++mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv+mkInitialCorePrepEnv cfg = CPE+      { cpe_config        = cfg+      , cpe_subst         = emptySubst+      , cpe_rec_ids       = emptyUnVarSet+      , cpe_context       = []+      }++extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv+extendCorePrepEnv cpe@(CPE { cpe_subst = subst }) id id'+    = cpe { cpe_subst = subst2 }+    where+      subst1 = extendSubstInScope subst id'+      subst2 = extendIdSubst subst1 id (Var id')++extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv+extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs+    = cpe { cpe_subst = subst2 }+    where+      subst1 = extendSubstInScopeList subst (map snd prs)+      subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs]++extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv+extendCorePrepEnvExpr cpe id expr+    = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }++lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr+lookupCorePrepEnv cpe id+  = case lookupIdSubst_maybe (cpe_subst cpe) id of+       Just e -> e+       Nothing -> Var id+    -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds;+    -- and Tidy has made top-level externally-visible Ids into GblIds++enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv+enterRecGroupRHSs env grp+  = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }++cpSubstTy :: CorePrepEnv -> Type -> Type+cpSubstTy (CPE { cpe_subst = subst }) ty = substTy subst ty+          -- substTy has a short-cut if the TCvSubst is empty++cpSubstCo :: CorePrepEnv -> Coercion -> Coercion+cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co+          -- substCo has a short-cut if the TCvSubst is empty++-- | See Note [Binder context]+pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv+pushBinderContext ident env+  | lengthAtLeast (cpe_context env) 2+  = env+  | otherwise+  = env { cpe_context = getOccName ident : cpe_context env}++------------------------------------------------------------------------------+-- Cloning binders+-- ---------------------------------------------------------------------------++cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs++cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+-- Clone the CoVar+-- See Note [Cloning CoVars and TyVars]+cpCloneCoVarBndr env@(CPE { cpe_subst = subst }) covar+  = assertPpr (isCoVar covar) (ppr covar) $+    do { uniq <- getUniqueM+       ; let covar1 = setVarUnique covar uniq+             covar2 = updateVarType (substTy subst) covar1+             subst1 = extendTCvSubstWithClone subst covar covar2+       ; return (env { cpe_subst = subst1 }, covar2) }++cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+-- See Note [Cloning in CorePrep]+cpCloneBndr env@(CPE { cpe_subst = subst }) bndr+  | isTyCoVar bndr  -- See Note [Cloning CoVars and TyVars]+  = if isEmptyTCvSubst subst    -- The common case+    then return (env { cpe_subst = extendSubstInScope subst bndr }, bndr)+    else -- No need to clone the Unique; but we must apply the substitution+         let bndr1  = updateVarType (substTy subst) bndr+             subst1 = extendTCvSubstWithClone subst bndr bndr1+         in return (env { cpe_subst = subst1 }, bndr1)++  | otherwise  -- A non-CoVar Id+  = do { bndr1 <- clone_it bndr+       ; let bndr2 = updateIdTypeAndMult (substTy subst) bndr1++       -- 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++             bndr3 = bndr2 `setIdUnfolding`      unfolding'+                           `setIdSpecialisation` emptyRuleInfo++       ; return (extendCorePrepEnv env bndr bndr3, bndr3) }+  where+    clone_it bndr+      | isLocalId bndr+      = do { uniq <- getUniqueM+           ; return (setVarUnique bndr 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 :: CorePrepEnv ->  Type -> UniqSM Id+newVar env ty+ -- See Note [Binder context]+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty+   where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat"++{- Note [Binder context]+   ~~~~~~~~~~~~~~~~~~~~~+   To ensure that the compiled program (specifically symbol names)+   remains understandable to the user we maintain a context+   of binders that we are currently under. This allows us to give+   identifiers conjured during CorePrep more contextually-meaningful+   names. This is done in `newVar`.+ -}++------------------------------------------------------------------------------+-- 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 expr+  | (floats1, ticks1) <- fold_fun go floats+  = (floats1, foldrOL mkTick expr ticks1)+  where fold_fun f floats =+           let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats)+           in (floats { fs_binds = binds }, ticks)+        -- 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 (flt_binds, ticks) (FloatTick t)+          = assert (tickishPlace t == PlaceNonLam)+            (flt_binds, if any (flip tickishContains t) ticks+                        then ticks else ticks `snocOL` t)+        go (flt_binds, ticks) f@UnsafeEqualityCase{}+          -- unsafe equality case will be erased; don't wrap anything!+          = (flt_binds `snocOL` f, ticks)+        go (flt_binds, ticks) f@Float{}+          = (flt_binds `snocOL` foldrOL wrap f ticks, ticks)++        wrap t (Float bind bound info) = Float (wrapBind t bind) bound info+        wrap _ f                 = pprPanic "Unexpected FloatingBind" (ppr f)+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)++------------------------------------------------------------------------------+-- Numeric literals+-- ---------------------------------------------------------------------------++-- | Converts Bignum literals into their final CoreExpr+cpeBigNatLit+   :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)+cpeBigNatLit env i = assert (i >= 0) $ do+  let+    platform = cp_platform (cpe_config env)++    -- Per the documentation in GHC.Internal.Bignum.BigNat, a BigNat# is:+    --   "Represented as an array of limbs (Word#) stored in+    --   little-endian order (Word# themselves use machine order)."+    --+    --   "Invariant (canonical representation): higher Word# is non-zero."+    -- So we need to break up the integer into target-word-sized chunks,+    -- and encode each of them using the target's byte-order.+    encodeBigNat+      :: forall a. Num a => FixedPrim a -> BS.ByteString+    encodeBigNat encodeWord+      = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i))+      -- (quadratic complexity due to repeated shifts... ok for now)+      where+        f 0 = Nothing+        f x = let low  = fromInteger x :: a+                  high = x `shiftR` bits+              in Just (low, high)+        bits = platformWordSizeInBits platform++    words :: BS.ByteString+    words = case (platformWordSize platform, platformByteOrder platform) of+      (PW4, LittleEndian) -> encodeBigNat word32LE+      (PW4, BigEndian   ) -> encodeBigNat word32BE+      (PW8, LittleEndian) -> encodeBigNat word64LE+      (PW8, BigEndian   ) -> encodeBigNat word64BE++  -- Ideally we would just generate a ByteArray# literal here:+  --   pure (emptyFloats, Lit (LitByteArray words))+  -- But sadly we don't have those yet, even in Core. (See also #17747.)+  -- So instead we generate:+  --   * An `Addr#` literal that contains the contents of the+  --      `ByteArray#` we want to create.  This gets its own float.+  --   * A call to `newByteArray#` with the appropriate size+  --   * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`+  --   * A call to `unsafeFreezeByteArray#` to make the types match+  litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy+  -- returned from newByteArray#:+  deadNewByteArrayTupleId+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+         mkTupleTy Unboxed [ realWorldStatePrimTy+                           , realWorldMutableByteArrayPrimTy+                           ]+  stateTokenFromNewByteArrayId+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  mutableByteArrayId+    <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy+  -- returned from copyAddrToByteArray#:+  stateTokenFromCopyId+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  -- returned from unsafeFreezeByteArray#:+  deadFreezeTupleId+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+         mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]+  stateTokenFromFreezeId+    <- (`setIdOccInfo` IAmDead) <$>+         mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy++  let+    litAddrRhs = Lit (LitString words)+      -- not "mkLitString"; that does UTF-8 encoding, which we don't want here+    (litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs++    contentsLength = mkIntLit platform (toInteger (BS.length words))++    newByteArrayCall =+      Var (primOpId NewByteArrayOp_Char)+        `App` Type realWorldTy+        `App` contentsLength+        `App` Var realWorldPrimId++    copyContentsCall =+      Var (primOpId CopyAddrToByteArrayOp)+        `App` Type realWorldTy+        `App` Var litAddrId'+        `App` Var mutableByteArrayId+        `App` mkIntLit platform 0+        `App` contentsLength+        `App` Var stateTokenFromNewByteArrayId++    unsafeFreezeCall =+      Var (primOpId UnsafeFreezeByteArrayOp)+        `App` Type realWorldTy+        `App` Var mutableByteArrayId+        `App` Var stateTokenFromCopyId++    unboxed2tuple_altcon :: AltCon+    unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2)++    finalRhs =+      Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy+        [ Alt unboxed2tuple_altcon+              [stateTokenFromNewByteArrayId, mutableByteArrayId]+              copyContentsCase+        ]++    copyContentsCase =+      Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy+        [ Alt DEFAULT [] unsafeFreezeCase+        ]++    unsafeFreezeCase =+      Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy+        [ Alt unboxed2tuple_altcon+              [stateTokenFromFreezeId, byteArrayId]+              (Var byteArrayId)+        ]++  pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)
+ GHC/Data/Bag.hs view
@@ -0,0 +1,373 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Bag: an unordered collection with duplicates+-}++{-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-}++module GHC.Data.Bag (+        Bag, -- abstract type++        emptyBag, unitBag, unionBags, unionManyBags,+        mapBag, pprBag,+        elemBag, lengthBag,+        filterBag, partitionBag, partitionBagWith,+        concatBag, catBagMaybes, foldBag_flip,+        isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,+        listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL,+        concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag,+        mapBagM, mapBagM_, lookupBag,+        flatMapBagM, flatMapBagPairM,+        mapAndUnzipBagM, mapAccumBagLM,+        anyBagM, filterBagM+    ) where++import GHC.Prelude++import GHC.Exts ( IsList(..) )+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Monad+import Control.Monad+import Data.Data+import Data.Maybe( mapMaybe )+import Data.List ( partition, mapAccumL )+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup ( (<>) )+import Control.Applicative( Alternative( (<|>) ) )+import Control.DeepSeq++infixr 3 `consBag`+infixl 3 `snocBag`++data Bag a+  = EmptyBag+  | UnitBag a+  | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty+  | ListBag (NonEmpty a)+  deriving (Foldable, Functor, Traversable)++instance NFData a => NFData (Bag a) where+  rnf EmptyBag = ()+  rnf (UnitBag a) = rnf a+  rnf (TwoBags a b) = rnf a `seq` rnf b+  rnf (ListBag a) = rnf a++emptyBag :: Bag a+emptyBag = EmptyBag++unitBag :: a -> Bag a+unitBag  = UnitBag++lengthBag :: Bag a -> Int+lengthBag EmptyBag        = 0+lengthBag (UnitBag {})    = 1+lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2+lengthBag (ListBag xs)    = length xs++elemBag :: Eq a => a -> Bag a -> Bool+elemBag _ EmptyBag        = False+elemBag x (UnitBag y)     = x == y+elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2+elemBag x (ListBag ys)    = any (x ==) ys++unionManyBags :: [Bag a] -> Bag a+unionManyBags xs = foldr unionBags EmptyBag xs++-- This one is a bit stricter! The bag will get completely evaluated.++unionBags :: Bag a -> Bag a -> Bag a+unionBags EmptyBag b = b+unionBags b EmptyBag = b+unionBags b1 b2      = TwoBags b1 b2++consBag :: a -> Bag a -> Bag a+snocBag :: Bag a -> a -> Bag a++consBag elt bag = (unitBag elt) `unionBags` bag+snocBag bag elt = bag `unionBags` (unitBag elt)++isEmptyBag :: Bag a -> Bool+isEmptyBag EmptyBag = True+isEmptyBag _ = False++isSingletonBag :: Bag a -> Bool+isSingletonBag EmptyBag      = False+isSingletonBag (UnitBag _)   = True+isSingletonBag (TwoBags _ _) = False          -- Neither is empty+isSingletonBag (ListBag (_:|xs)) = null xs++filterBag :: (a -> Bool) -> Bag a -> Bag a+filterBag _    EmptyBag = EmptyBag+filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag+filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2+    where sat1 = filterBag pred b1+          sat2 = filterBag pred b2+filterBag pred (ListBag vs)    = listToBag (filter pred (toList vs))++filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a)+filterBagM _    EmptyBag = return EmptyBag+filterBagM pred b@(UnitBag val) = do+  flag <- pred val+  if flag then return b+          else return EmptyBag+filterBagM pred (TwoBags b1 b2) = do+  sat1 <- filterBagM pred b1+  sat2 <- filterBagM pred b2+  return (sat1 `unionBags` sat2)+filterBagM pred (ListBag vs) = do+  sat <- filterM pred (toList vs)+  return (listToBag sat)+{-# INLINEABLE filterBagM #-}++lookupBag :: Eq a => a -> Bag (a,b) -> Maybe b+lookupBag _ EmptyBag        = Nothing+lookupBag k (UnitBag kv)    = lookup_one k kv+lookupBag k (TwoBags b1 b2) = lookupBag k b1 <|> lookupBag k b2+lookupBag k (ListBag xs)    = foldr ((<|>) . lookup_one k) Nothing xs+{-# INLINEABLE lookupBag #-}++lookup_one :: Eq a => a -> (a,b) -> Maybe b+lookup_one k (k',v) | k==k'     = Just v+                    | otherwise = Nothing++allBag :: (a -> Bool) -> Bag a -> Bool+allBag _ EmptyBag        = True+allBag p (UnitBag v)     = p v+allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2+allBag p (ListBag xs)    = all p xs++anyBag :: (a -> Bool) -> Bag a -> Bool+anyBag _ EmptyBag        = False+anyBag p (UnitBag v)     = p v+anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2+anyBag p (ListBag xs)    = any p xs++anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool+anyBagM _ EmptyBag        = return False+anyBagM p (UnitBag v)     = p v+anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1+                               if flag then return True+                                       else anyBagM p b2+anyBagM p (ListBag xs)    = anyM p xs+{-# INLINEABLE anyBagM #-}++concatBag :: Bag (Bag a) -> Bag a+concatBag = foldr unionBags emptyBag++catBagMaybes :: Bag (Maybe a) -> Bag a+catBagMaybes bs = foldr add emptyBag bs+  where+    add Nothing rs = rs+    add (Just x) rs = x `consBag` rs++partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predicate -},+                                         Bag a {- Don't -})+partitionBag _    EmptyBag = (EmptyBag, EmptyBag)+partitionBag pred b@(UnitBag val)+    = if pred val then (b, EmptyBag) else (EmptyBag, b)+partitionBag pred (TwoBags b1 b2)+    = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)+  where (sat1, fail1) = partitionBag pred b1+        (sat2, fail2) = partitionBag pred b2+partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)+  where (sats, fails) = partition pred (toList vs)+++partitionBagWith :: (a -> Either b c) -> Bag a+                    -> (Bag b {- Left  -},+                        Bag c {- Right -})+partitionBagWith _    EmptyBag = (EmptyBag, EmptyBag)+partitionBagWith pred (UnitBag val)+    = case pred val of+         Left a  -> (UnitBag a, EmptyBag)+         Right b -> (EmptyBag, UnitBag b)+partitionBagWith pred (TwoBags b1 b2)+    = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)+  where (sat1, fail1) = partitionBagWith pred b1+        (sat2, fail2) = partitionBagWith pred b2+partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails)+  where (sats, fails) = partitionWith pred (toList vs)++foldBag_flip :: (a -> b -> b) -> Bag a -> b -> b+-- Just foldr with flipped arguments,+-- so it can be chained more nicely+foldBag_flip k bag z = foldr k z bag++mapBag :: (a -> b) -> Bag a -> Bag b+mapBag = fmap++concatMapBag :: (a -> Bag b) -> Bag a -> Bag b+concatMapBag _ EmptyBag        = EmptyBag+concatMapBag f (UnitBag x)     = f x+concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2)+concatMapBag f (ListBag xs)    = foldr (unionBags . f) emptyBag xs++concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c)+concatMapBagPair _ EmptyBag        = (EmptyBag, EmptyBag)+concatMapBagPair f (UnitBag x)     = f x+concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2)+  where+    (r1, s1) = concatMapBagPair f b1+    (r2, s2) = concatMapBagPair f b2+concatMapBagPair f (ListBag xs)    = foldr go (emptyBag, emptyBag) xs+  where+    go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2)+      where+        (r1, r2) = f a++mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b+mapMaybeBag _ EmptyBag        = EmptyBag+mapMaybeBag f (UnitBag x)     = case f x of+                                  Nothing -> EmptyBag+                                  Just y  -> UnitBag y+mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2)+mapMaybeBag f (ListBag xs)    = listToBag $ mapMaybe f (toList xs)++mapMaybeBagM :: Monad m => (a -> m (Maybe b)) -> Bag a -> m (Bag b)+mapMaybeBagM _ EmptyBag        = return EmptyBag+mapMaybeBagM f (UnitBag x)     = do r <- f x+                                    return $ case r of+                                      Nothing -> EmptyBag+                                      Just y  -> UnitBag y+mapMaybeBagM f (TwoBags b1 b2) = do r1 <- mapMaybeBagM f b1+                                    r2 <- mapMaybeBagM f b2+                                    return $ unionBags r1 r2+mapMaybeBagM f (ListBag xs)    = listToBag <$> mapMaybeM f (toList xs)++mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b)+mapBagM _ EmptyBag        = return EmptyBag+mapBagM f (UnitBag x)     = do r <- f x+                               return (UnitBag r)+mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1+                               r2 <- mapBagM f b2+                               return (TwoBags r1 r2)+mapBagM f (ListBag    xs) = do rs <- mapM f xs+                               return (ListBag rs)+{-# INLINEABLE mapBagM #-}++mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m ()+mapBagM_ _ EmptyBag        = return ()+mapBagM_ f (UnitBag x)     = f x >> return ()+mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2+mapBagM_ f (ListBag    xs) = mapM_ f xs+{-# INLINEABLE mapBagM_ #-}++flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b)+flatMapBagM _ EmptyBag        = return EmptyBag+flatMapBagM f (UnitBag x)     = f x+flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1+                                   r2 <- flatMapBagM f b2+                                   return (r1 `unionBags` r2)+flatMapBagM f (ListBag    xs) = foldrM k EmptyBag xs+  where+    k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) }+{-# INLINEABLE flatMapBagM #-}++flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c)+flatMapBagPairM _ EmptyBag        = return (EmptyBag, EmptyBag)+flatMapBagPairM f (UnitBag x)     = f x+flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1+                                       (r2,s2) <- flatMapBagPairM f b2+                                       return (r1 `unionBags` r2, s1 `unionBags` s2)+flatMapBagPairM f (ListBag    xs) = foldrM k (EmptyBag, EmptyBag) xs+  where+    k x (r2,s2) = do { (r1,s1) <- f x+                     ; return (r1 `unionBags` r2, s1 `unionBags` s2) }+{-# INLINEABLE flatMapBagPairM #-}++mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)+mapAndUnzipBagM _ EmptyBag        = return (EmptyBag, EmptyBag)+mapAndUnzipBagM f (UnitBag x)     = do (r,s) <- f x+                                       return (UnitBag r, UnitBag s)+mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1+                                       (r2,s2) <- mapAndUnzipBagM f b2+                                       return (TwoBags r1 r2, TwoBags s1 s2)+mapAndUnzipBagM f (ListBag xs)    = do ts <- mapM f xs+                                       let (rs,ss) = NE.unzip ts+                                       return (ListBag rs, ListBag ss)+{-# INLINEABLE mapAndUnzipBagM #-}++mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function+            -> acc                    -- ^ initial state+            -> Bag x                  -- ^ inputs+            -> (acc, Bag y)           -- ^ final state, outputs+mapAccumBagL _ s EmptyBag        = (s, EmptyBag)+mapAccumBagL f s (UnitBag x)     = let (s1, x1) = f s x in (s1, UnitBag x1)+mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s  b1+                                       (s2, b2') = mapAccumBagL f s1 b2+                                   in (s2, TwoBags b1' b2')+mapAccumBagL f s (ListBag xs)    = let (s', xs') = mapAccumL f s xs+                                   in (s', ListBag xs')++mapAccumBagLM :: Monad m+            => (acc -> x -> m (acc, y)) -- ^ combining function+            -> acc                      -- ^ initial state+            -> Bag x                    -- ^ inputs+            -> m (acc, Bag y)           -- ^ final state, outputs+mapAccumBagLM _ s EmptyBag        = return (s, EmptyBag)+mapAccumBagLM f s (UnitBag x)     = do { (s1, x1) <- f s x; return (s1, UnitBag x1) }+mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s  b1+                                       ; (s2, b2') <- mapAccumBagLM f s1 b2+                                       ; return (s2, TwoBags b1' b2') }+mapAccumBagLM f s (ListBag xs)    = do { (s', xs') <- mapAccumLM f s xs+                                       ; return (s', ListBag xs') }+{-# INLINEABLE mapAccumBagLM #-}++listToBag :: [a] -> Bag a+listToBag [] = EmptyBag+listToBag [x] = UnitBag x+listToBag (x:xs) = ListBag (x:|xs)++nonEmptyToBag :: NonEmpty a -> Bag a+nonEmptyToBag (x :| []) = UnitBag x+nonEmptyToBag xs = ListBag xs++bagToList :: Bag a -> [a]+bagToList b = foldr (:) [] b++unzipBag :: Bag (a, b) -> (Bag a, Bag b)+unzipBag EmptyBag = (EmptyBag, EmptyBag)+unzipBag (UnitBag (a, b)) = (UnitBag a, UnitBag b)+unzipBag (TwoBags xs1 xs2) = (TwoBags as1 as2, TwoBags bs1 bs2)+  where+    (as1, bs1) = unzipBag xs1+    (as2, bs2) = unzipBag xs2+unzipBag (ListBag xs) = (ListBag as, ListBag bs)+  where+    (as, bs) = NE.unzip xs++headMaybe :: Bag a -> Maybe a+headMaybe EmptyBag = Nothing+headMaybe (UnitBag v) = Just v+headMaybe (TwoBags b1 _) = headMaybe b1+headMaybe (ListBag (v:|_)) = Just v++instance (Outputable a) => Outputable (Bag a) where+    ppr = pprBag++pprBag :: Outputable a => Bag a -> SDoc+pprBag bag = braces (pprWithCommas ppr (bagToList bag))++instance Data a => Data (Bag a) where+  gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly+  toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "Bag"+  dataCast1 x  = gcast1 x++instance IsList (Bag a) where+  type Item (Bag a) = a+  fromList = listToBag+  toList   = bagToList++instance Semigroup (Bag a) where+  (<>) = unionBags++instance Monoid (Bag a) where+  mempty = emptyBag
+ GHC/Data/Bitmap.hs view
@@ -0,0 +1,101 @@+--+-- (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
+ GHC/Data/Bool.hs view
@@ -0,0 +1,25 @@+module GHC.Data.Bool+  ( OverridingBool(..)+  , overrideWith+  )+where++import GHC.Prelude.Basic++data OverridingBool+  = Auto+  | Never+  | Always+  deriving+    ( Show+    , Read    -- ^ @since 9.4.1+    , Eq      -- ^ @since 9.4.1+    , Ord     -- ^ @since 9.4.1+    , Enum    -- ^ @since 9.4.1+    , Bounded -- ^ @since 9.4.1+    )++overrideWith :: Bool -> OverridingBool -> Bool+overrideWith b Auto   = b+overrideWith _ Never  = False+overrideWith _ Always = True
+ GHC/Data/BooleanFormula.hs view
@@ -0,0 +1,240 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}++--------------------------------------------------------------------------------+-- | Boolean formulas without quantifiers and without negation.+-- Such a formula consists of variables, conjunctions (and), and disjunctions (or).+--+-- This module is used to represent minimal complete definitions for classes.+--+module GHC.Data.BooleanFormula (+        module Language.Haskell.Syntax.BooleanFormula,+        isFalse, isTrue,+        bfMap, bfTraverse,+        eval, simplify, isUnsatisfied,+        implies, impliesAtom,+        pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal+  ) where++import Data.List ( intersperse )+import Data.List.NonEmpty ( NonEmpty (..), init, last )++import GHC.Prelude hiding ( init, last )+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.SrcLoc (unLoc)+import GHC.Utils.Outputable+import GHC.Parser.Annotation ( SrcSpanAnnL )+import GHC.Hs.Extension (GhcPass (..), OutputableBndrId)+import Language.Haskell.Syntax.Extension (Anno, LIdP, IdP)+import Language.Haskell.Syntax.BooleanFormula+++----------------------------------------------------------------------+-- Boolean formula type and smart constructors+----------------------------------------------------------------------++type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL++-- if we had Functor/Traversable (LbooleanFormula p) we could use that+-- as a constraint and we wouldn't need to specialize to just GhcPass p,+-- but becuase LBooleanFormula is a type synonym such a constraint is+-- impossible.++-- BooleanFormula can't be an instance of functor because it can't lift+-- arbitrary functions `a -> b`, only functions of type `LIdP a -> LIdP b`+-- ditto for Traversable.+bfMap :: (LIdP (GhcPass p) -> LIdP (GhcPass p'))+      -> BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p')+bfMap f = go+  where+    go (Var    a  ) = Var     $ f a+    go (And    bfs) = And     $ map (fmap go) bfs+    go (Or     bfs) = Or      $ map (fmap go) bfs+    go (Parens bf ) = Parens  $ fmap go bf++bfTraverse  :: Applicative f+            => (LIdP (GhcPass p) -> f (LIdP (GhcPass p')))+            -> BooleanFormula (GhcPass p)+            -> f (BooleanFormula (GhcPass p'))+bfTraverse f = go+  where+    go (Var    a  ) = Var    <$> f a+    go (And    bfs) = And    <$> traverse @[] (traverse go) bfs+    go (Or     bfs) = Or     <$> traverse @[] (traverse go) bfs+    go (Parens bf ) = Parens <$> traverse go bf++++{-+Note [Simplification of BooleanFormulas]+~~~~~~~~~~~~~~~~~~~~~~+The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular,+ 1. Collapsing nested ands and ors, so+     `(mkAnd [x, And [y,z]]`+    is represented as+     `And [x,y,z]`+    Implemented by `fromAnd`/`fromOr`+ 2. Collapsing trivial ands and ors, so+     `mkAnd [x]` becomes just `x`.+    Implemented by mkAnd' / mkOr'+ 3. Conjunction with false, disjunction with true is simplified, i.e.+     `mkAnd [mkFalse,x]` becomes `mkFalse`.+ 4. Common subexpression elimination:+     `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`.++This simplification is not exhaustive, in the sense that it will not produce+the smallest possible equivalent expression. For example,+`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently+is not. A general simplifier would need to use something like BDDs.++The reason behind the (crude) simplifier is to make for more user friendly+error messages. E.g. for the code+  > class Foo a where+  >     {-# MINIMAL bar, (foo, baq | foo, quux) #-}+  > instance Foo Int where+  >     bar = ...+  >     baz = ...+  >     quux = ...+We don't show a ridiculous error message like+    Implement () and (either (`foo' and ()) or (`foo' and ()))+-}++----------------------------------------------------------------------+-- Evaluation and simplification+----------------------------------------------------------------------++isFalse :: BooleanFormula (GhcPass p) -> Bool+isFalse (Or []) = True+isFalse _ = False++isTrue :: BooleanFormula (GhcPass p) -> Bool+isTrue (And []) = True+isTrue _ = False++eval :: (LIdP (GhcPass p) -> Bool) -> BooleanFormula (GhcPass p) -> Bool+eval f (Var x)  = f x+eval f (And xs) = all (eval f . unLoc) xs+eval f (Or xs)  = any (eval f . unLoc) xs+eval f (Parens x) = eval f (unLoc x)++-- Simplify a boolean formula.+-- The argument function should give the truth of the atoms, or Nothing if undecided.+simplify :: forall p. Eq (LIdP (GhcPass p))+          => (LIdP (GhcPass p) ->  Maybe Bool)+          -> BooleanFormula (GhcPass p)+          -> BooleanFormula (GhcPass p)+simplify f (Var a) = case f a of+  Nothing -> Var a+  Just b  -> mkBool b+simplify f (And xs) = mkAnd (map (fmap (simplify f)) xs)+simplify f (Or xs)  = mkOr  (map (fmap (simplify f)) xs)+simplify f (Parens x) = simplify f (unLoc x)++-- Test if a boolean formula is satisfied when the given values are assigned to the atoms+-- if it is, returns Nothing+-- if it is not, return (Just remainder)+isUnsatisfied :: Eq (LIdP (GhcPass p))+              => (LIdP (GhcPass p) -> Bool)+              -> BooleanFormula (GhcPass p)+              -> Maybe (BooleanFormula (GhcPass p))+isUnsatisfied f bf+    | isTrue bf' = Nothing+    | otherwise  = Just bf'+  where+  f' x = if f x then Just True else Nothing+  bf' = simplify f' bf++-- prop_simplify:+--   eval f x == True   <==>  isTrue  (simplify (Just . f) x)+--   eval f x == False  <==>  isFalse (simplify (Just . f) x)++-- If the boolean formula holds, does that mean that the given atom is always true?+impliesAtom :: Eq (IdP (GhcPass p)) => BooleanFormula (GhcPass p) -> LIdP (GhcPass p) -> Bool+Var x  `impliesAtom` y = (unLoc x) == (unLoc y)+And xs `impliesAtom` y = any (\x -> unLoc x `impliesAtom` y) xs+           -- we have all of xs, so one of them implying y is enough+Or  xs `impliesAtom` y = all (\x -> unLoc x `impliesAtom` y) xs+Parens x `impliesAtom` y = unLoc x `impliesAtom` y++implies :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool+implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])+  where+    go :: Uniquable (IdP (GhcPass p)) => Clause (GhcPass p) -> Clause (GhcPass p) -> Bool+    go l@Clause{ clauseExprs = hyp:hyps } r =+        case hyp of+            Var x | memberClauseAtoms (unLoc x) r -> True+                  | otherwise -> go (extendClauseAtoms l (unLoc x)) { clauseExprs = hyps } r+            Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps }     r+            And hyps'  -> go l { clauseExprs = map unLoc hyps' ++ hyps } r+            Or hyps'   -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps'+    go l r@Clause{ clauseExprs = con:cons } =+        case con of+            Var x | memberClauseAtoms (unLoc x) l -> True+                  | otherwise -> go l (extendClauseAtoms r (unLoc x)) { clauseExprs = cons }+            Parens con' -> go l r { clauseExprs = unLoc con':cons }+            And cons'   -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons'+            Or cons'    -> go l r { clauseExprs = map unLoc cons' ++ cons }+    go _ _ = False++-- A small sequent calculus proof engine.+data Clause p = Clause {+        clauseAtoms :: UniqSet (IdP p),+        clauseExprs :: [BooleanFormula p]+    }+extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p+extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x }++memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool+memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c++----------------------------------------------------------------------+-- Pretty printing+----------------------------------------------------------------------++-- Pretty print a BooleanFormula,+-- using the arguments as pretty printers for Var, And and Or respectively+pprBooleanFormula'  :: (Rational -> LIdP (GhcPass p) -> SDoc)+                    -> (Rational -> [SDoc] -> SDoc)+                    -> (Rational -> [SDoc] -> SDoc)+                    -> Rational -> BooleanFormula (GhcPass p) -> SDoc+pprBooleanFormula' pprVar pprAnd pprOr = go+  where+  go p (Var x)  = pprVar p x+  go p (And []) = cparen (p > 0) empty+  go p (And xs) = pprAnd p (map (go 3 . unLoc) xs)+  go _ (Or  []) = keyword $ text "FALSE"+  go p (Or  xs) = pprOr p (map (go 2 . unLoc) xs)+  go p (Parens x) = go p (unLoc x)++-- Pretty print in source syntax, "a | b | c,d,e"+pprBooleanFormula :: (Rational -> LIdP (GhcPass p) -> SDoc)+                  -> Rational -> BooleanFormula (GhcPass p) -> SDoc+pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr+  where+  pprAnd p = cparen (p > 3) . fsep . punctuate comma+  pprOr  p = cparen (p > 2) . fsep . intersperse vbar++-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?+pprBooleanFormulaNice :: Outputable (LIdP (GhcPass p)) => BooleanFormula (GhcPass p) -> SDoc+pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0+  where+  pprVar _ = quotes . ppr+  pprAnd p = cparen (p > 1) . pprAnd'+  pprAnd' [] = empty+  pprAnd' [x,y] = x <+> text "and" <+> y+  pprAnd' (x:xs) = fsep (punctuate comma (init (x:|xs))) <> text ", and" <+> last (x:|xs)+  pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs)++instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where+  ppr = pprBooleanFormulaNormal++pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc+pprBooleanFormulaNormal = go+  where+    go (Var x)    = pprPrefixOcc (unLoc x)+    go (And xs)   = fsep $ punctuate comma (map (go . unLoc) xs)+    go (Or [])    = keyword $ text "FALSE"+    go (Or xs)    = fsep $ intersperse vbar (map (go . unLoc) xs)+    go (Parens x) = parens (go $ unLoc x)
+ GHC/Data/EnumSet.hs view
@@ -0,0 +1,69 @@+-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum'+-- things.+module GHC.Data.EnumSet+    ( EnumSet+    , member+    , insert+    , delete+    , toList+    , fromList+    , empty+    , difference+    ) where++import GHC.Prelude+import GHC.Utils.Binary+import Control.DeepSeq++import qualified Data.IntSet as IntSet++newtype EnumSet a = EnumSet IntSet.IntSet+  deriving (Semigroup, Monoid, NFData)++member :: Enum a => a -> EnumSet a -> Bool+member x (EnumSet s) = IntSet.member (fromEnum x) s++insert :: Enum a => a -> EnumSet a -> EnumSet a+insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s++delete :: Enum a => a -> EnumSet a -> EnumSet a+delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s++toList :: Enum a => EnumSet a -> [a]+toList (EnumSet s) = map toEnum $ IntSet.toList s++fromList :: Enum a => [a] -> EnumSet a+fromList = EnumSet . IntSet.fromList . map fromEnum++empty :: EnumSet a+empty = EnumSet IntSet.empty++difference :: EnumSet a -> EnumSet a -> EnumSet a+difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b)++-- | Represents the 'EnumSet' as a bit set.+--+-- Assumes that all elements are non-negative.+--+-- This is only efficient for values that are sufficiently small,+-- for example in the lower hundreds.+instance Binary (EnumSet a) where+  put_ bh = put_ bh . enumSetToBitArray+  get bh = bitArrayToEnumSet <$> get bh++-- TODO: Using 'Natural' instead of 'Integer' should be slightly more efficient+-- but we don't currently have a 'Binary' instance for 'Natural'.+type BitArray = Integer++enumSetToBitArray :: EnumSet a -> BitArray+enumSetToBitArray (EnumSet int_set) =+    IntSet.foldl' setBit 0 int_set++bitArrayToEnumSet :: BitArray -> EnumSet a+bitArrayToEnumSet ba = EnumSet (go (popCount ba) 0 IntSet.empty)+  where+    go 0 _ !int_set = int_set+    go n i !int_set =+      if ba `testBit` i+        then go (pred n) (succ i) (IntSet.insert i int_set)+        else go n        (succ i) int_set
+ GHC/Data/FastMutInt.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}+{-# OPTIONS_GHC -O2 #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected+--+-- (c) The University of Glasgow 2002-2006+--+-- Unboxed mutable Ints++module GHC.Data.FastMutInt(+        FastMutInt, newFastMutInt,+        readFastMutInt, writeFastMutInt,+        atomicFetchAddFastMut+  ) where++import GHC.Prelude.Basic++import GHC.Base++data FastMutInt = FastMutInt !(MutableByteArray# RealWorld)++newFastMutInt :: Int -> IO FastMutInt+newFastMutInt n = do+    x <- create+    writeFastMutInt x n+    return x+  where+    !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3+    create = IO $ \s ->+      case newByteArray# size s of+        (# s, arr #) -> (# s, FastMutInt arr #)++readFastMutInt :: FastMutInt -> IO Int+readFastMutInt (FastMutInt arr) = IO $ \s ->+  case readIntArray# arr 0# s of+    (# s, i #) -> (# s, I# i #)++writeFastMutInt :: FastMutInt -> Int -> IO ()+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->+  case writeIntArray# arr 0# i s of+    s -> (# s, () #)++atomicFetchAddFastMut :: FastMutInt -> Int -> IO Int+atomicFetchAddFastMut (FastMutInt arr) (I# i) = IO $ \s ->+  case fetchAddIntArray# arr 0# i s of+    (# s, n #) -> (# s, I# n #)
+ GHC/Data/FastString.hs view
@@ -0,0 +1,716 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+#if MIN_VERSION_GLASGOW_HASKELL(9,8,0,0)+{-# OPTIONS_GHC -fno-unoptimized-core-for-interpreter #-}+#endif+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected+--+-- Also important, if you load this module into GHCi then the data representation of+-- FastString has to match that of the host compiler due to the shared FastString+-- table. Otherwise you will get segfaults when the table is consulted and the fields+-- from the FastString are in an incorrect order.++-- |+-- There are two principal string types used internally by GHC:+--+-- ['FastString']+--+--   * A compact, hash-consed, representation of character strings.+--   * Generated by 'fsLit'.+--   * You can get a 'GHC.Types.Unique.Unique' from them.+--   * Equality test is O(1) (it uses the Unique).+--   * Comparison is O(1) or O(n):+--       * O(n) but deterministic with lexical comparison (`lexicalCompareFS`)+--       * O(1) but non-deterministic with Unique comparison (`uniqCompareFS`)+--   * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'.+--+-- ['PtrString']+--+--   * Pointer and size of a Latin-1 encoded string.+--   * Practically no operations.+--   * Outputting them is fast.+--   * Generated by 'mkPtrString#'.+--   * Length of string literals (mkPtrString# "abc"#) is computed statically+--   * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ptext'+--   * Requires manual memory management.+--     Improper use may lead to memory leaks or dangling pointers.+--   * It assumes Latin-1 as the encoding, therefore it cannot represent+--     arbitrary Unicode strings.+--+-- Use 'PtrString' unless you want the facilities of 'FastString'.+module GHC.Data.FastString+       (+        -- * ByteString+        bytesFS,+        fastStringToByteString,+        mkFastStringByteString,+        fastZStringToByteString,+        unsafeMkByteString,++        -- * ShortByteString+        fastStringToShortByteString,+        mkFastStringShortByteString,++        -- * ShortText+        fastStringToShortText,++        -- * FastZString+        FastZString,+        hPutFZS,+        zString,+        zStringTakeN,+        lengthFZS,++        -- * FastStrings+        FastString(..),     -- not abstract, for now.+        NonDetFastString (..),+        LexicalFastString (..),++        -- ** Construction+        fsLit,+        mkFastString,+        mkFastStringBytes,+        mkFastStringByteList,+        mkFastString#,++        -- ** Deconstruction+        unpackFS,           -- :: FastString -> String+        unconsFS,           -- :: FastString -> Maybe (Char, FastString)++        -- ** Encoding+        zEncodeFS,++        -- ** Operations+        uniqueOfFS,+        lengthFS,+        nullFS,+        appendFS,+        concatFS,+        consFS,+        nilFS,+        lexicalCompareFS,+        uniqCompareFS,++        -- ** Outputting+        hPutFS,++        -- ** Internal+        getFastStringTable,+        getFastStringZEncCounter,++        -- * PtrStrings+        PtrString (..),++        -- ** Construction+        mkPtrString#,++        -- ** Deconstruction+        unpackPtrString,+        unpackPtrStringTakeN,++        -- ** Operations+        lengthPS+       ) where++import GHC.Prelude.Basic as Prelude++import GHC.Utils.Encoding+import GHC.Utils.IO.Unsafe+import GHC.Utils.Panic.Plain+import GHC.Utils.Misc+import GHC.Data.FastMutInt++import Control.Concurrent.MVar+import Control.DeepSeq+import Control.Monad+import Data.ByteString (ByteString)+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString          as BS+import qualified Data.ByteString.Char8    as BSC+import qualified Data.ByteString.Unsafe   as BS+import qualified Data.ByteString.Short    as SBS+import GHC.Data.ShortText (ShortText(..))+import Foreign.C+import System.IO+import Data.Data+import Data.IORef+import Data.Semigroup as Semi++import Foreign++import GHC.Conc.Sync    (sharedCAF)++import GHC.Exts+import GHC.IO++-- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString'+bytesFS, fastStringToByteString :: FastString -> ByteString+{-# INLINE[1] bytesFS #-}+bytesFS f = SBS.fromShort $ fs_sbs f++{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-}+fastStringToByteString = bytesFS++fastStringToShortByteString :: FastString -> ShortByteString+fastStringToShortByteString = fs_sbs++fastStringToShortText :: FastString -> ShortText+fastStringToShortText = ShortText . fs_sbs++fastZStringToByteString :: FastZString -> ByteString+fastZStringToByteString (FastZString bs) = bs++-- This will drop information if any character > '\xFF'+unsafeMkByteString :: String -> ByteString+unsafeMkByteString = BSC.pack++hashFastString :: FastString -> Int+hashFastString fs = hashStr $ fs_sbs fs++-- -----------------------------------------------------------------------------++newtype FastZString = FastZString ByteString+  deriving NFData++hPutFZS :: Handle -> FastZString -> IO ()+hPutFZS handle (FastZString bs) = BS.hPut handle bs++zString :: FastZString -> String+zString (FastZString bs) =+    inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen++-- | @zStringTakeN n = 'take' n . 'zString'@+-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),+-- where \(l\) is the length of the 'FastZString'.+zStringTakeN :: Int -> FastZString -> String+zStringTakeN n (FastZString bs) =+    inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(cp, len) ->+        peekCAStringLen (cp, min n len)++lengthFZS :: FastZString -> Int+lengthFZS (FastZString bs) = BS.length bs++mkFastZStringString :: String -> FastZString+mkFastZStringString str = FastZString (BSC.pack str)++-- -----------------------------------------------------------------------------++{-| A 'FastString' is a Modified UTF-8 encoded string together with a unique ID.+All 'FastString's are stored in a global hashtable to support fast O(1)+comparison.++It is also associated with a lazy reference to the Z-encoding+of this string which is used by the compiler internally.+-}+data FastString = FastString {+      uniq    :: {-# UNPACK #-} !Int, -- unique id+      n_chars :: {-# UNPACK #-} !Int, -- number of chars+      fs_sbs  :: {-# UNPACK #-} !ShortByteString,+      fs_zenc :: FastZString+      -- ^ Lazily computed Z-encoding of this string. See Note [Z-Encoding] in+      -- GHC.Utils.Encoding.+      --+      -- Since 'FastString's are globally memoized this is computed at most+      -- once for any given string.+  }++instance Eq FastString where+  f1 == f2  =  uniq f1 == uniq f2++-- We don't provide any "Ord FastString" instance to force you to think about+-- which ordering you want:+--    * lexical:   deterministic,     O(n). Cf lexicalCompareFS and LexicalFastString.+--    * by unique: non-deterministic, O(1). Cf uniqCompareFS    and NonDetFastString.++instance IsString FastString where+    fromString = fsLit++instance Semi.Semigroup FastString where+    (<>) = appendFS++instance Monoid FastString where+    mempty = nilFS+    mappend = (Semi.<>)+    mconcat = concatFS++instance Show FastString where+   show fs = show (unpackFS fs)++instance Data FastString where+  -- don't traverse?+  toConstr _   = abstractConstr "FastString"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "FastString"++instance NFData FastString where+  rnf fs = seq fs ()++-- | Compare FastString lexically+--+-- If you don't care about the lexical ordering, use `uniqCompareFS` instead.+lexicalCompareFS :: FastString -> FastString -> Ordering+lexicalCompareFS fs1 fs2 =+  if uniq fs1 == uniq fs2 then EQ else+  utf8CompareShortByteString (fs_sbs fs1) (fs_sbs fs2)+  -- perform a lexical comparison taking into account the Modified UTF-8+  -- encoding we use (cf #18562)++-- | Compare FastString by their Unique (not lexically).+--+-- Much cheaper than `lexicalCompareFS` but non-deterministic!+uniqCompareFS :: FastString -> FastString -> Ordering+uniqCompareFS fs1 fs2 = compare (uniq fs1) (uniq fs2)++-- | Non-deterministic FastString+--+-- This is a simple FastString wrapper with an Ord instance using+-- `uniqCompareFS` (i.e. which compares FastStrings on their Uniques). Hence it+-- is not deterministic from one run to the other.+newtype NonDetFastString+   = NonDetFastString FastString+   deriving newtype (Eq, Show)+   deriving stock Data++instance Ord NonDetFastString where+   compare (NonDetFastString fs1) (NonDetFastString fs2) = uniqCompareFS fs1 fs2++-- | Lexical FastString+--+-- This is a simple FastString wrapper with an Ord instance using+-- `lexicalCompareFS` (i.e. which compares FastStrings on their String+-- representation). Hence it is deterministic from one run to the other.+newtype LexicalFastString+   = LexicalFastString { getLexicalFastString :: FastString }+   deriving newtype (Eq, Show)+   deriving stock Data++instance Ord LexicalFastString where+   compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2++instance NFData LexicalFastString where+  rnf (LexicalFastString f) = rnf f++-- -----------------------------------------------------------------------------+-- Construction++{-+Internally, the compiler will maintain a fast string symbol table, providing+sharing and fast comparison. Creation of new @FastString@s then covertly does a+lookup, re-using the @FastString@ if there was a hit.++The design of the FastString hash table allows for lockless concurrent reads+and updates to multiple buckets with low synchronization overhead.++See Note [Updating the FastString table] on how it's updated.+-}+data FastStringTable = FastStringTable+  {-# UNPACK #-} !FastMutInt+  -- ^ The unique ID counter shared with all buckets+  --+  -- We unpack the 'FastMutInt' counter as it is always consumed strictly.+  {-# NOUNPACK #-} !FastMutInt+  -- ^ Number of computed z-encodings for all buckets.+  --+  -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk+  -- in 'mkFastStringWith' and needs to be boxed any way.+  -- If this is unpacked, then we box this single 'FastMutInt' once for each+  -- allocated FastString.+  (Array# (IORef FastStringTableSegment)) -- ^  concurrent segments++data FastStringTableSegment = FastStringTableSegment+  {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment+  {-# UNPACK #-} !FastMutInt -- the number of elements+  (MutableArray# RealWorld [FastString]) -- buckets in this segment++{-+Following parameters are determined based on:++* Benchmark based on testsuite/tests/utils/should_run/T14854.hs+* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@:+  on 2018-10-24, we have 13920 entries.+-}+segmentBits, numSegments, segmentMask, initialNumBuckets :: Int+segmentBits = 8+numSegments = 256   -- bit segmentBits+segmentMask = 0xff  -- bit segmentBits - 1+initialNumBuckets = 64++hashToSegment# :: Int# -> Int#+hashToSegment# hash# = hash# `andI#` segmentMask#+  where+    !(I# segmentMask#) = segmentMask++hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int#+hashToIndex# buckets# hash# =+  (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size#+  where+    !(I# segmentBits#) = segmentBits+    size# = sizeofMutableArray# buckets#++maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment+maybeResizeSegment segmentRef = do+  segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef+  let oldSize# = sizeofMutableArray# old#+      newSize# = oldSize# *# 2#+  (I# n#) <- readFastMutInt counter+  if isTrue# (n# <# newSize#) -- maximum load of 1+  then return segment+  else do+    resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# ->+      case newArray# newSize# [] s1# of+        (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #)+    forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do+      fsList <- IO $ readArray# old# i#+      forM_ fsList $ \fs -> do+        let -- Shall we store in hash value in FastString instead?+            !(I# hash#) = hashFastString fs+            idx# = hashToIndex# new# hash#+        IO $ \s1# ->+          case readArray# new# idx# s1# of+            (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of+              s3# -> (# s3#, () #)+    writeIORef segmentRef resizedSegment+    return resizedSegment++{-# NOINLINE stringTable #-}+stringTable :: FastStringTable+stringTable = unsafePerformIO $ do+  let !(I# numSegments#) = numSegments+      !(I# initialNumBuckets#) = initialNumBuckets+      loop a# i# s1#+        | isTrue# (i# ==# numSegments#) = s1#+        | otherwise = case newMVar () `unIO` s1# of+            (# s2#, lock #) -> case newFastMutInt 0 `unIO` s2# of+              (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of+                (# s4#, buckets# #) -> case newIORef+                    (FastStringTableSegment lock counter buckets#) `unIO` s4# of+                  (# s5#, segment #) -> case writeArray# a# i# segment s5# of+                    s6# -> loop a# (i# +# 1#) s6#+  uid <- newFastMutInt 603979776 -- ord '$' * 0x01000000+  n_zencs <- newFastMutInt 0+  tab <- IO $ \s1# ->+    case newArray# numSegments# (panic "string_table") s1# of+      (# s2#, arr# #) -> case loop arr# 0# s2# of+        s3# -> case unsafeFreezeArray# arr# s3# of+          (# s4#, segments# #) ->+            (# s4#, FastStringTable uid n_zencs segments# #)++  -- use the support wired into the RTS to share this CAF among all images of+  -- libHSghc+  sharedCAF tab getOrSetLibHSghcFastStringTable++-- from the 9.3 RTS; the previous RTS before might not have this symbol.  The+-- right way to do this however would be to define some HAVE_FAST_STRING_TABLE+-- or similar rather than use (odd parity) development versions.+foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"+  getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a)++{-++We include the FastString table in the `sharedCAF` mechanism because we'd like+FastStrings created by a Core plugin to have the same uniques as corresponding+strings created by the host compiler itself.  For example, this allows plugins+to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or+even re-invoke the parser.++In particular, the following little sanity test was failing in a plugin+prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not+be looked up /by the plugin/.++   let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT"+   putMsgS $ showSDoc dflags $ ppr $+     lookupGRE (mg_rdr_env guts) (LookupRdrName rdrName AllRelevantGREs)++`mkTcOcc` involves the lookup (or creation) of a FastString.  Since the+plugin's FastString.string_table is empty, constructing the RdrName also+allocates new uniques for the FastStrings "GHC.NT.Type" and "NT".  These+uniques are almost certainly unequal to the ones that the host compiler+originally assigned to those FastStrings.  Thus the lookup fails since the+domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's+unique.++Maintaining synchronization of the two instances of this global is rather+difficult because of the uses of `unsafePerformIO` in this module.  Not+synchronizing them risks breaking the rather major invariant that two+FastStrings with the same unique have the same string. Thus we use the+lower-level `sharedCAF` mechanism that relies on Globals.c.++-}++mkFastString# :: Addr# -> FastString+{-# INLINE mkFastString# #-}+mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)+  where ptr = Ptr a#++{- Note [Updating the FastString table]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use a concurrent hashtable which contains multiple segments, each hash value+always maps to the same segment. Read is lock-free, write to the a segment+should acquire a lock for that segment to avoid race condition, writes to+different segments are independent.++The procedure goes like this:++1. Find out which segment to operate on based on the hash value+2. Read the relevant bucket and perform a look up of the string.+3. If it exists, return it.+4. Otherwise grab a unique ID, create a new FastString and atomically attempt+   to update the relevant segment with this FastString:++   * Resize the segment by doubling the number of buckets when the number of+     FastStrings in this segment grows beyond the threshold.+   * Double check that the string is not in the bucket. Another thread may have+     inserted it while we were creating our string.+   * Return the existing FastString if it exists. The one we preemptively+     created will get GCed.+   * Otherwise, insert and return the string we created.+-}++mkFastStringWith+    :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString+mkFastStringWith mk_fs sbs = do+  FastStringTableSegment lock _ buckets# <- readIORef segmentRef+  let idx# = hashToIndex# buckets# hash#+  bucket <- IO $ readArray# buckets# idx#+  case bucket_match bucket sbs of+    Just found -> return found+    Nothing -> do+      -- The withMVar below is not dupable. It can lead to deadlock if it is+      -- only run partially and putMVar is not called after takeMVar.+      noDuplicate+      n <- get_uid+      new_fs <- mk_fs n n_zencs+      withMVar lock $ \_ -> insert new_fs+  where+    !(FastStringTable uid n_zencs segments#) = stringTable+    get_uid = atomicFetchAddFastMut uid 1++    !(I# hash#) = hashStr sbs+    (# segmentRef #) = indexArray# segments# (hashToSegment# hash#)+    insert fs = do+      FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef+      let idx# = hashToIndex# buckets# hash#+      bucket <- IO $ readArray# buckets# idx#+      case bucket_match bucket sbs of+        -- The FastString was added by another thread after previous read and+        -- before we acquired the write lock.+        Just found -> return found+        Nothing -> do+          IO $ \s1# ->+            case writeArray# buckets# idx# (fs : bucket) s1# of+              s2# -> (# s2#, () #)+          _ <- atomicFetchAddFastMut counter 1+          return fs++bucket_match :: [FastString] -> ShortByteString -> Maybe FastString+bucket_match fs sbs = go fs+  where go [] = Nothing+        go (fs@(FastString {fs_sbs=fs_sbs}) : ls)+          | fs_sbs == sbs = Just fs+          | otherwise     = go ls+-- bucket_match used to inline before changes to instance Eq ShortByteString+-- in bytestring-0.12, which made it slightly larger than inlining threshold.+-- Non-inlining causes a small, but measurable performance regression, so let's force it.+{-# INLINE bucket_match #-}++mkFastStringBytes :: Ptr Word8 -> Int -> FastString+mkFastStringBytes !ptr !len =+    -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is+    -- idempotent.+    unsafeDupablePerformIO $ do+        sbs <- newSBSFromPtr ptr len+        mkFastStringWith (mkNewFastStringShortByteString sbs) sbs++newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString+newSBSFromPtr (Ptr src#) (I# len#) =+  IO $ \s ->+    case newByteArray# len# s of { (# s, dst# #) ->+    case copyAddrToByteArray# src# dst# 0# len# s of { s ->+    case unsafeFreezeByteArray# dst# s of { (# s, ba# #) ->+    (# s, SBS.SBS ba# #) }}}++-- | Create a 'FastString' by copying an existing 'ByteString'+mkFastStringByteString :: ByteString -> FastString+mkFastStringByteString bs =+  let sbs = SBS.toShort bs in+  inlinePerformIO $+      mkFastStringWith (mkNewFastStringShortByteString sbs) sbs++-- | Create a 'FastString' from an existing 'ShortByteString' without+-- copying.+mkFastStringShortByteString :: ShortByteString -> FastString+mkFastStringShortByteString sbs =+  inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs++-- | Creates a UTF-8 encoded 'FastString' from a 'String'+mkFastString :: String -> FastString+{-# NOINLINE[1] mkFastString #-}+mkFastString str =+  inlinePerformIO $ do+    let !sbs = utf8EncodeShortByteString str+    mkFastStringWith (mkNewFastStringShortByteString sbs) sbs++-- The following rule is used to avoid polluting the non-reclaimable FastString+-- table with transient strings when we only want their encoding.+{-# RULES+"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-}++-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@+mkFastStringByteList :: [Word8] -> FastString+mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str)++-- | Creates a (lazy) Z-encoded 'FastString' from a 'ShortByteString' and+-- account the number of forced z-strings into the passed 'FastMutInt'.+mkZFastString :: FastMutInt -> ShortByteString -> FastZString+mkZFastString n_zencs sbs = unsafePerformIO $ do+  _ <- atomicFetchAddFastMut n_zencs 1+  return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs))++mkNewFastStringShortByteString :: ShortByteString -> Int+                               -> FastMutInt -> IO FastString+mkNewFastStringShortByteString sbs uid n_zencs = do+  let zstr = mkZFastString n_zencs sbs+      chars = utf8CountCharsShortByteString sbs+  return (FastString uid chars sbs zstr)++hashStr  :: ShortByteString -> Int+ -- produce a hash value between 0 & m (inclusive)+hashStr sbs@(SBS.SBS ba#) = loop 0# 0#+   where+    !(I# len#) = SBS.length sbs+    loop h n =+      if isTrue# (n ==# len#) then+        I# h+      else+        let+          -- DO NOT move this let binding! indexCharOffAddr# reads from the+          -- pointer so we need to evaluate this based on the length check+          -- above. Not doing this right caused #17909.+          !c = int8ToInt# (indexInt8Array# ba# n)+          !h2 = (h *# 16777619#) `xorI#` c+        in+          loop h2 (n +# 1#)++-- -----------------------------------------------------------------------------+-- Operations++-- | Returns the length of the 'FastString' in characters+lengthFS :: FastString -> Int+lengthFS fs = n_chars fs++-- | Returns @True@ if the 'FastString' is empty+nullFS :: FastString -> Bool+nullFS fs = SBS.null $ fs_sbs fs++-- | Lazily unpacks and decodes the FastString+unpackFS :: FastString -> String+unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs++-- | Returns a Z-encoded version of a 'FastString'.  This might be the+-- original, if it was already Z-encoded.  The first time this+-- function is applied to a particular 'FastString', the results are+-- memoized.+--+zEncodeFS :: FastString -> FastZString+zEncodeFS fs = fs_zenc fs++appendFS :: FastString -> FastString -> FastString+appendFS fs1 fs2 = mkFastStringShortByteString+                 $ (Semi.<>) (fs_sbs fs1) (fs_sbs fs2)++concatFS :: [FastString] -> FastString+concatFS = mkFastStringShortByteString . mconcat . map fs_sbs++consFS :: Char -> FastString -> FastString+consFS c fs = mkFastString (c : unpackFS fs)++unconsFS :: FastString -> Maybe (Char, FastString)+unconsFS fs =+  case unpackFS fs of+    []          -> Nothing+    (chr : str) -> Just (chr, mkFastString str)++uniqueOfFS :: FastString -> Int+uniqueOfFS fs = uniq fs++nilFS :: FastString+nilFS = mkFastString ""++-- -----------------------------------------------------------------------------+-- Stats++getFastStringTable :: IO [[[FastString]]]+getFastStringTable =+  forM [0 .. numSegments - 1] $ \(I# i#) -> do+    let (# segmentRef #) = indexArray# segments# i#+    FastStringTableSegment _ _ buckets# <- readIORef segmentRef+    let bucketSize = I# (sizeofMutableArray# buckets#)+    forM [0 .. bucketSize - 1] $ \(I# j#) ->+      IO $ readArray# buckets# j#+  where+    !(FastStringTable _ _ segments#) = stringTable++getFastStringZEncCounter :: IO Int+getFastStringZEncCounter = readFastMutInt n_zencs+  where+    !(FastStringTable _ n_zencs _) = stringTable++-- -----------------------------------------------------------------------------+-- Outputting 'FastString's++-- |Outputs a 'FastString' with /no decoding at all/, that is, you+-- get the actual bytes in the 'FastString' written to the 'Handle'.+hPutFS :: Handle -> FastString -> IO ()+hPutFS handle fs = BS.hPut handle $ bytesFS fs++-- ToDo: we'll probably want an hPutFSLocal, or something, to output+-- in the current locale's encoding (for error messages and suchlike).++-- -----------------------------------------------------------------------------+-- PtrStrings, here for convenience only.++-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars.+data PtrString = PtrString !(Ptr Word8) !Int++-- | Wrap an unboxed address into a 'PtrString'.+mkPtrString# :: Addr# -> PtrString+{-# INLINE mkPtrString# #-}+mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#))++-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding.+-- This does not free the memory associated with 'PtrString'.+unpackPtrString :: PtrString -> String+unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n#++-- | @unpackPtrStringTakeN n = 'take' n . 'unpackPtrString'@+-- but is performed in \(O(\min(n,l))\) rather than \(O(l)\),+-- where \(l\) is the length of the 'PtrString'.+unpackPtrStringTakeN :: Int -> PtrString -> String+unpackPtrStringTakeN n (PtrString (Ptr p#) len) =+  case min n len of+    I# n# -> unpackNBytes# p# n#++-- | Return the length of a 'PtrString'+lengthPS :: PtrString -> Int+lengthPS (PtrString _ n) = n++-- -----------------------------------------------------------------------------+-- under the carpet+++ptrStrLength :: Ptr Word8 -> Int+{-# INLINE ptrStrLength #-}+ptrStrLength (Ptr a) = I# (cstringLength# a)++{-# NOINLINE fsLit #-}+fsLit :: String -> FastString+fsLit x = mkFastString x++{-# RULES "fslit"+    forall x . fsLit (unpackCString# x) = mkFastString# x #-}
+ GHC/Data/FastString/Env.hs view
@@ -0,0 +1,113 @@+{-+%+% (c) The University of Glasgow 2006+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+%+-}++-- | FastStringEnv: FastString environments+module GHC.Data.FastString.Env (+        -- * FastString environments (maps)+        FastStringEnv,++        -- ** Manipulating these environments+        mkFsEnv,+        emptyFsEnv, unitFsEnv,+        extendFsEnv_C, extendFsEnv_Acc, extendFsEnv,+        extendFsEnvList, extendFsEnvList_C,+        filterFsEnv,+        plusFsEnv, plusFsEnv_C, alterFsEnv,+        lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv,+        elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv,+        nonDetFoldFsEnv,++        -- * Deterministic FastString environments (maps)+        DFastStringEnv,++        -- ** Manipulating these environments+        mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv+    ) where++import GHC.Prelude++import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Data.Maybe+import GHC.Data.FastString+++-- | A non-deterministic set of FastStrings.+-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why it's not+-- deterministic and why it matters. Use DFastStringEnv if the set eventually+-- gets converted into a list or folded over in a way where the order+-- changes the generated code.+type FastStringEnv a = UniqFM FastString a  -- Domain is FastString++emptyFsEnv         :: FastStringEnv a+mkFsEnv            :: [(FastString,a)] -> FastStringEnv a+alterFsEnv         :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a+extendFsEnv_C      :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a+extendFsEnv_Acc    :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b+extendFsEnv        :: FastStringEnv a -> FastString -> a -> FastStringEnv a+plusFsEnv          :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a+plusFsEnv_C        :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a+extendFsEnvList    :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a+extendFsEnvList_C  :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a+delFromFsEnv       :: FastStringEnv a -> FastString -> FastStringEnv a+delListFromFsEnv   :: FastStringEnv a -> [FastString] -> FastStringEnv a+elemFsEnv          :: FastString -> FastStringEnv a -> Bool+unitFsEnv          :: FastString -> a -> FastStringEnv a+lookupFsEnv        :: FastStringEnv a -> FastString -> Maybe a+lookupFsEnv_NF     :: FastStringEnv a -> FastString -> a+filterFsEnv        :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt+mapFsEnv           :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2+mapMaybeFsEnv      :: (elt1 -> Maybe elt2) -> FastStringEnv elt1 -> FastStringEnv elt2++emptyFsEnv                = emptyUFM+unitFsEnv x y             = unitUFM x y+extendFsEnv x y z         = addToUFM x y z+extendFsEnvList x l       = addListToUFM x l+lookupFsEnv x y           = lookupUFM x y+alterFsEnv                = alterUFM+mkFsEnv     l             = listToUFM l+elemFsEnv x y             = elemUFM x y+plusFsEnv x y             = plusUFM x y+plusFsEnv_C f x y         = plusUFM_C f x y+extendFsEnv_C f x y z     = addToUFM_C f x y z+mapFsEnv f x              = mapUFM f x+extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b+extendFsEnvList_C x y z   = addListToUFM_C x y z+delFromFsEnv x y          = delFromUFM x y+delListFromFsEnv x y      = delListFromUFM x y+filterFsEnv x y           = filterUFM x y+mapMaybeFsEnv f x         = mapMaybeUFM f x++lookupFsEnv_NF env n = expectJust (lookupFsEnv env n)++strictMapFsEnv :: (a -> b) -> FastStringEnv a -> FastStringEnv b+strictMapFsEnv = strictMapUFM++-- | Fold over a 'FastStringEnv'.+--+-- Non-deterministic, unless the folding function is commutative+-- (i.e. @a1 `f` ( a2 `f` b ) == a2 `f` ( a1 `f` b )@ for all @a1@, @a2@, @b@).+nonDetFoldFsEnv :: (a -> b -> b) -> b -> FastStringEnv a -> b+nonDetFoldFsEnv = nonDetFoldUFM++-- Deterministic FastStringEnv+-- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for explanation why we need+-- DFastStringEnv.++type DFastStringEnv a = UniqDFM FastString a  -- Domain is FastString++emptyDFsEnv :: DFastStringEnv a+emptyDFsEnv = emptyUDFM++dFsEnvElts :: DFastStringEnv a -> [a]+dFsEnvElts = eltsUDFM++mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a+mkDFsEnv l = listToUDFM l++lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a+lookupDFsEnv = lookupUDFM
+ GHC/Data/FiniteMap.hs view
@@ -0,0 +1,31 @@+-- Some extra functions to extend Data.Map++module GHC.Data.FiniteMap (+        insertList,+        insertListWith,+        deleteList,+        foldRight, foldRightWithKey+    ) where++import GHC.Prelude++import Data.Map (Map)+import qualified Data.Map as Map++insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt+insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs++insertListWith :: Ord key+               => (elt -> elt -> elt)+               -> [(key,elt)]+               -> Map key elt+               -> Map key elt+insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs++deleteList :: Ord key => [key] -> Map key elt -> Map key elt+deleteList ks m = foldl' (flip Map.delete) m ks++foldRight        :: (elt -> a -> a) -> a -> Map key elt -> a+foldRight        = Map.foldr+foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a+foldRightWithKey = Map.foldrWithKey
+ GHC/Data/FlatBag.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE UnboxedTuples #-}+module GHC.Data.FlatBag+  ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)+  , emptyFlatBag+  , unitFlatBag+  , sizeFlatBag+  , elemsFlatBag+  , mappendFlatBag+  -- * Construction+  , fromList+  , fromSmallArray+  ) where++import GHC.Prelude++import Control.DeepSeq++import GHC.Data.SmallArray++-- | Store elements in a flattened representation.+--+-- A 'FlatBag' is a data structure that stores an ordered list of elements+-- in a flat structure, avoiding the overhead of a linked list.+-- Use this data structure, if the code requires the following properties:+--+-- * Elements are stored in a long-lived object, and benefit from a flattened+--   representation.+-- * The 'FlatBag' will be traversed but not extended or filtered.+-- * The number of elements should be known.+-- * Sharing of the empty case improves memory behaviour.+--+-- A 'FlagBag' aims to have as little overhead as possible to store its elements.+-- To achieve that, it distinguishes between the empty case, singleton, tuple+-- and general case.+-- Thus, we only pay for the additional three words of an 'Array' if we have at least+-- three elements.+data FlatBag a+  = EmptyFlatBag+  | UnitFlatBag !a+  | TupleFlatBag !a !a+  | FlatBag {-# UNPACK #-} !(SmallArray a)++instance Functor FlatBag where+  fmap _ EmptyFlatBag = EmptyFlatBag+  fmap f (UnitFlatBag a) = UnitFlatBag $ f a+  fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b)+  fmap f (FlatBag e) = FlatBag $ mapSmallArray f e++instance Foldable FlatBag where+  foldMap _ EmptyFlatBag = mempty+  foldMap f (UnitFlatBag a) = f a+  foldMap f (TupleFlatBag a b) = f a `mappend` f b+  foldMap f (FlatBag arr) = foldMapSmallArray f arr++  length = fromIntegral . sizeFlatBag++instance Traversable FlatBag where+  traverse _ EmptyFlatBag = pure EmptyFlatBag+  traverse f (UnitFlatBag a) = UnitFlatBag <$> f a+  traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b+  traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl)++instance NFData a => NFData (FlatBag a) where+  rnf EmptyFlatBag = ()+  rnf (UnitFlatBag a) = rnf a+  rnf (TupleFlatBag a b) = rnf a `seq` rnf b+  rnf (FlatBag arr) = rnfSmallArray arr++-- | Create an empty 'FlatBag'.+--+-- The empty 'FlatBag' is shared over all instances.+emptyFlatBag :: FlatBag a+emptyFlatBag = EmptyFlatBag++-- | Create a singleton 'FlatBag'.+unitFlatBag :: a -> FlatBag a+unitFlatBag = UnitFlatBag++-- | Calculate the size of+sizeFlatBag :: FlatBag a -> Word+sizeFlatBag EmptyFlatBag = 0+sizeFlatBag UnitFlatBag{} = 1+sizeFlatBag TupleFlatBag{} = 2+sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr++-- | Get all elements that are stored in the 'FlatBag'.+elemsFlatBag :: FlatBag a -> [a]+elemsFlatBag EmptyFlatBag = []+elemsFlatBag (UnitFlatBag a) = [a]+elemsFlatBag (TupleFlatBag a b) = [a, b]+elemsFlatBag (FlatBag arr) =+  [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]]++-- | Combine two 'FlatBag's.+--+-- The new 'FlatBag' contains all elements from both 'FlatBag's.+--+-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused.+mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a+mappendFlatBag EmptyFlatBag b = b+mappendFlatBag a EmptyFlatBag = a+mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b+mappendFlatBag a b =+  fromList (sizeFlatBag a + sizeFlatBag b)+           (elemsFlatBag a ++ elemsFlatBag b)++-- | Store the list in a flattened memory representation, avoiding the memory overhead+-- of a linked list.+--+-- The size 'n' needs to be smaller or equal to the length of the list.+-- If it is smaller than the length of the list, overflowing elements are+-- discarded. It is undefined behaviour to set 'n' to be bigger than the+-- length of the list.+fromList :: Word -> [a] -> FlatBag a+fromList n elts =+  case elts of+    [] -> EmptyFlatBag+    [a] -> UnitFlatBag a+    [a, b] -> TupleFlatBag a b+    xs ->+      FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs))++-- | Convert a 'SizedSeq' into its flattened representation.+-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification+-- is necessary.+fromSmallArray :: SmallArray a -> FlatBag a+fromSmallArray s = case sizeofSmallArray s of+                      0 -> EmptyFlatBag+                      1 -> UnitFlatBag (indexSmallArray s 0)+                      2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)+                      _ -> FlatBag s+
+ GHC/Data/Graph/Base.hs view
@@ -0,0 +1,107 @@++-- | 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 }
+ GHC/Data/Graph/Collapse.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Data.Graph.Collapse+  ( PureSupernode(..)+  , Supernode(..)+  , collapseInductiveGraph+  , VizCollapseMonad(..)+  , NullCollapseViz(..)+  , runNullCollapse+  , MonadUniqDSM(..)+  )+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.DSM+import GHC.Utils.Panic hiding (assert)+++{-|+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 (MonadUniqDSM 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 :: UniqDSM a }+  deriving (Functor, Applicative, Monad, MonadGetUnique)++instance MonadUniqDSM NullCollapseViz where+  liftUniqDSM = NullCollapseViz++instance (Graph gr, Supernode s NullCollapseViz) =>+    VizCollapseMonad NullCollapseViz gr s where+  consumeByInGraph _ _ _ = return ()+  splitGraphAt _ _ = return ()+  finalGraph _ = return ()++runNullCollapse :: NullCollapseViz a -> UniqDSM 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 responsibility 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 (MonadGetUnique 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"
+ GHC/Data/Graph/Color.hs view
@@ -0,0 +1,382 @@+-- | 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+
+ GHC/Data/Graph/Directed.hs view
@@ -0,0 +1,487 @@+-- (c) The University of Glasgow 2006+++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}++module GHC.Data.Graph.Directed (+        Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,+        graphFromVerticesAndAdjacency, emptyGraph,++        SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,+        stronglyConnCompG,+        topologicalSortG,+        verticesG, edgesG, hasVertexG,+        reachablesG,+        transposeG, outgoingG,+        emptyG,++        findCycle,++        -- For backwards compatibility with the simpler version of Digraph+        stronglyConnCompFromEdgedVerticesOrd,+        stronglyConnCompFromEdgedVerticesOrdR,+        stronglyConnCompFromEdgedVerticesUniq,+        stronglyConnCompFromEdgedVerticesUniqR,++        -- Simple way to classify edges+        EdgeType(..), classifyEdges+        ) where++------------------------------------------------------------------------------+-- A version of the graph algorithms described in:+--+-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''+--   by David King and John Launchbury+--+-- Also included is some additional code for printing tree structures ...+--+-- If you ever find yourself in need of algorithms for classifying edges,+-- or finding connected/biconnected components, consult the history; Sigbjorn+-- Finne contributed some implementations in 1997, although we've since+-- removed them since they were not used anywhere in GHC.+------------------------------------------------------------------------------++import GHC.Prelude++import GHC.Utils.Misc ( sortWith, count )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.Maybe ( expectJust )++-- std interfaces+import Data.Maybe+import Data.Array+import Data.List ( sort )+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Data.Graph as G+import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation+import GHC.Types.Unique+import GHC.Types.Unique.FM++-- The graph internals are defined in the .Internal module so they can be+-- imported by GHC.Data.Graph.Directed.Reachability while still allowing this+-- module to export it abstractly.+import GHC.Data.Graph.Directed.Internal++{-+************************************************************************+*                                                                      *+*      Graphs and Graph Construction+*                                                                      *+************************************************************************++Note [Nodes, keys, vertices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ * A 'node' is a big blob of client-stuff++ * Each 'node' has a unique (client) 'key', but the latter+        is in Ord and has fast comparison++ * Digraph then maps each 'key' to a Vertex (Int) which is+        arranged densely in 0.n+-}++{-| Representation for nodes of the Graph.++ * The @payload@ is user data, just carried around in this module++ * The @key@ is the node identifier.+   Key has an Ord instance for performance reasons.++ * The @[key]@ are the dependencies of the node;+   it's ok to have extra keys in the dependencies that+   are not the key of any Node in the graph+-}+data Node key payload = DigraphNode {+      node_payload :: payload, -- ^ User data+      node_key :: key, -- ^ User defined node id+      node_dependencies :: [key] -- ^ Dependencies/successors of the node+  } deriving Functor+++instance (Outputable a, Outputable b) => Outputable (Node a b) where+  ppr (DigraphNode a b c) = ppr (a, b, c)++emptyGraph :: Graph a+emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)++-- See Note [Deterministic SCC]+graphFromEdgedVertices+        :: ReduceFn key payload+        -> [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVertices _reduceFn []            = emptyGraph+graphFromEdgedVertices reduceFn edged_vertices =+  Graph graph vertex_fn (key_vertex . key_extractor)+  where key_extractor = node_key+        (bounds, vertex_fn, key_vertex, numbered_nodes) =+          reduceFn edged_vertices key_extractor+        graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)+                             | (v, (node_dependencies -> ks)) <- numbered_nodes]+                -- We normalize outgoing edges by sorting on node order, so+                -- that the result doesn't depend on the order of the edges++-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+graphFromEdgedVerticesOrd+        :: Ord key+        => [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd++-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+graphFromEdgedVerticesUniq+        :: Uniquable key+        => [Node key payload]           -- The graph; its ok for the+                                        -- out-list to contain keys which aren't+                                        -- a vertex key, they are ignored+        -> Graph (Node key payload)+graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq++type ReduceFn key payload =+  [Node key payload] -> (Node key payload -> key) ->+    (Bounds, Vertex -> Node key payload+    , key -> Maybe Vertex, [(Vertex, Node key payload)])++{-+Note [reduceNodesIntoVertices implementations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+reduceNodesIntoVertices is parameterized by the container type.+This is to accommodate key types that don't have an Ord instance+and hence preclude the use of Data.Map. An example of such type+would be Unique, there's no way to implement Ord Unique+deterministically.++For such types, there's a version with a Uniquable constraint.+This leaves us with two versions of every function that depends on+reduceNodesIntoVertices, one with Ord constraint and the other with+Uniquable constraint.+For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.++The Uniq version should be a tiny bit more efficient since it uses+Data.IntMap internally.+-}+reduceNodesIntoVertices+  :: ([(key, Vertex)] -> m)+  -> (key -> m -> Maybe Vertex)+  -> ReduceFn key payload+reduceNodesIntoVertices fromList lookup nodes key_extractor =+  (bounds, (!) vertex_map, key_vertex, numbered_nodes)+  where+    max_v           = length nodes - 1+    bounds          = (0, max_v) :: (Vertex, Vertex)++    -- Keep the order intact to make the result depend on input order+    -- instead of key order+    numbered_nodes  = zip [0..] nodes+    vertex_map      = array bounds numbered_nodes++    key_map = fromList+      [ (key_extractor node, v) | (v, node) <- numbered_nodes ]+    key_vertex k = lookup k key_map++-- See Note [reduceNodesIntoVertices implementations]+reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload+reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup++-- See Note [reduceNodesIntoVertices implementations]+reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload+reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)++{-+************************************************************************+*                                                                      *+*      SCC+*                                                                      *+************************************************************************+-}++type WorkItem key payload+  = (Node key payload,  -- Tip of the path+     [payload])         -- Rest of the path;+                        --  [a,b,c] means c depends on b, b depends on a++-- | Find a reasonably short cycle a->b->c->a, in a graph+-- The graph might not necessarily be strongly connected.+findCycle :: forall payload key. Ord key+          => [Node key payload]     -- The nodes.  The dependencies can+                                    -- contain extra keys, which are ignored+          -> Maybe [payload]        -- A cycle, starting with node+                                    -- so each depends on the next+findCycle graph+  = goRoots plausible_roots+  where+    env :: Map.Map key (Node key payload)+    env = Map.fromList [ (node_key node, node) | node <- graph ]++    goRoots [] = Nothing+    goRoots (root:xs) =+        case go Set.empty (new_work root_deps []) [] of+          Nothing -> goRoots xs+          Just res -> Just res+      where+        DigraphNode root_payload root_key root_deps = root+        -- 'go' implements Dijkstra's algorithm, more or less+        go :: Set.Set key   -- Visited+           -> [WorkItem key payload]        -- Work list, items length n+           -> [WorkItem key payload]        -- Work list, items length n+1+           -> Maybe [payload]               -- Returned cycle+           -- Invariant: in a call (go visited ps qs),+           --            visited = union (map tail (ps ++ qs))++        go _       [] [] = Nothing  -- No cycles+        go visited [] qs = go visited qs []+        go visited (((DigraphNode payload key deps), path) : ps) qs+           | key == root_key           = Just (root_payload : reverse path)+           | key `Set.member` visited  = go visited ps qs+           | key `Map.notMember` env   = go visited ps qs+           | otherwise                 = go (Set.insert key visited)+                                            ps (new_qs ++ qs)+           where+             new_qs = new_work deps (payload : path)+++    -- Find the nodes with fewest dependencies among the SCC modules+    -- This is just a heuristic to find some plausible root module+    plausible_roots :: [Node key payload]+    plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node))+                                            | node <- graph ])+++    new_work :: [key] -> [payload] -> [WorkItem key payload]+    new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]++{-+************************************************************************+*                                                                      *+*      Strongly Connected Component wrappers for Graph+*                                                                      *+************************************************************************++Note: the components are returned topologically sorted: later components+depend on earlier ones, but not vice versa i.e. later components only have+edges going from them to earlier ones.+-}++{-+Note [Deterministic SCC]+~~~~~~~~~~~~~~~~~~~~~~~~+stronglyConnCompFromEdgedVerticesUniq,+stronglyConnCompFromEdgedVerticesUniqR,+stronglyConnCompFromEdgedVerticesOrd and+stronglyConnCompFromEdgedVerticesOrdR+provide a following guarantee:+Given a deterministically ordered list of nodes it returns a deterministically+ordered list of strongly connected components, where the list of vertices+in an SCC is also deterministically ordered.+Note that the order of edges doesn't need to be deterministic for this to work.+We use the order of nodes to normalize the order of edges.+-}++stronglyConnCompG :: Graph node -> [SCC node]+stronglyConnCompG graph = decodeSccs graph $ scc (gr_int_graph graph)++decodeSccs :: Graph node -> [SCC Vertex] -> [SCC node]+decodeSccs Graph { gr_vertex_to_node = vertex_fn }+  = map (fmap vertex_fn)++-- The following two versions are provided for backwards compatibility:+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesOrd+        :: Ord key+        => [Node key payload]+        -> [SCC payload]+stronglyConnCompFromEdgedVerticesOrd+  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR++-- The following two versions are provided for backwards compatibility:+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesUniq+        :: Uniquable key+        => [Node key payload]+        -> [SCC payload]+stronglyConnCompFromEdgedVerticesUniq+  = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR++-- The "R" interface is used when you expect to apply SCC to+-- (some of) the result of SCC, so you don't want to lose the dependency info+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesOrdR+        :: Ord key+        => [Node key payload]+        -> [SCC (Node key payload)]+stronglyConnCompFromEdgedVerticesOrdR =+  stronglyConnCompG . graphFromEdgedVerticesOrd++-- The "R" interface is used when you expect to apply SCC to+-- (some of) the result of SCC, so you don't want to lose the dependency info+-- See Note [Deterministic SCC]+-- See Note [reduceNodesIntoVertices implementations]+stronglyConnCompFromEdgedVerticesUniqR+        :: Uniquable key+        => [Node key payload]+        -> [SCC (Node key payload)]+stronglyConnCompFromEdgedVerticesUniqR =+  stronglyConnCompG . graphFromEdgedVerticesUniq++{-+************************************************************************+*                                                                      *+*      Misc wrappers for Graph+*                                                                      *+************************************************************************+-}++topologicalSortG :: Graph node -> [node]+topologicalSortG graph = map (gr_vertex_to_node graph) result+  where result = {-# SCC "Digraph.topSort" #-} G.topSort (gr_int_graph graph)++outgoingG :: Graph node -> node -> [node]+outgoingG graph from = map (gr_vertex_to_node graph) result+  where from_vertex = expectJust (gr_node_to_vertex graph from)+        result = gr_int_graph graph ! from_vertex++-- | Given a list of roots, return all reachable nodes in topological order.+-- Implemented using a depth-first traversal.+reachablesG :: Graph node -> [node] -> [node]+reachablesG graph froms = map (gr_vertex_to_node graph) result+  where result = {-# SCC "Digraph.reachable" #-}+                 reachable (gr_int_graph graph) vs+        vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]++hasVertexG :: Graph node -> node -> Bool+hasVertexG graph node = isJust $ gr_node_to_vertex graph node++transposeG :: Graph node -> Graph node+transposeG graph = Graph (G.transposeG (gr_int_graph graph))+                         (gr_vertex_to_node graph)+                         (gr_node_to_vertex graph)++emptyG :: Graph node -> Bool+emptyG g = graphEmpty (gr_int_graph g)++graphEmpty :: G.Graph -> Bool+graphEmpty g = lo > hi+  where (lo, hi) = bounds g+++{-+************************************************************************+*                                                                      *+*                         Classify Edge Types+*                                                                      *+************************************************************************+-}++-- Remark: While we could generalize this algorithm this comes at a runtime+-- cost and with no advantages. If you find yourself using this with graphs+-- not easily represented using Int nodes please consider rewriting this+-- using the more general Graph type.++-- | Edge direction based on DFS Classification+data EdgeType+  = Forward+  | Cross+  | Backward -- ^ Loop back towards the root node.+             -- Eg backjumps in loops+  | SelfLoop -- ^ v -> v+   deriving (Eq,Ord)++instance Outputable EdgeType where+  ppr Forward = text "Forward"+  ppr Cross = text "Cross"+  ppr Backward = text "Backward"+  ppr SelfLoop = text "SelfLoop"++newtype Time = Time Int deriving (Eq,Ord,Num,Outputable)++--Allow for specialization+{-# INLINEABLE classifyEdges #-}++-- | Given a start vertex, a way to get successors from a node+-- and a list of (directed) edges classify the types of edges.+classifyEdges :: forall key. Uniquable key => key -> (key -> [key])+              -> [(key,key)] -> [((key, key), EdgeType)]+classifyEdges root getSucc edges =+    --let uqe (from,to) = (getUnique from, getUnique to)+    --in pprTrace "Edges:" (ppr $ map uqe edges) $+    zip edges $ map classify edges+  where+    (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root+    classify :: (key,key) -> EdgeType+    classify (from,to)+      | startFrom < startTo+      , endFrom   > endTo+      = Forward+      | startFrom > startTo+      , endFrom   < endTo+      = Backward+      | startFrom > startTo+      , endFrom   > endTo+      = Cross+      | getUnique from == getUnique to+      = SelfLoop+      | otherwise+      = pprPanic "Failed to classify edge of Graph"+                 (ppr (getUnique from, getUnique to))++      where+        getTime event node+          | Just time <- lookupUFM event node+          = time+          | otherwise+          = pprPanic "Failed to classify edge of CFG - not not timed"+            (text "edges" <> ppr (getUnique from, getUnique to)+                          <+> ppr starts <+> ppr ends )+        startFrom = getTime starts from+        startTo   = getTime starts to+        endFrom   = getTime ends   from+        endTo     = getTime ends   to++    addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key+             -> (Time, UniqFM key Time, UniqFM key Time)+    addTimes (time,starts,ends) n+      --Dont reenter nodes+      | elemUFM n starts+      = (time,starts,ends)+      | otherwise =+        let+          starts' = addToUFM starts n time+          time' = time + 1+          succs = getSucc n :: [key]+          (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs+          ends'' = addToUFM ends' n time''+        in+        (time'' + 1, starts'', ends'')++graphFromVerticesAndAdjacency+        :: Ord key+        => [Node key payload]+        -> [(key, key)]  -- First component is source vertex key,+                         -- second is target vertex key (thing depended on)+                         -- Unlike the other interface I insist they correspond to+                         -- actual vertices because the alternative hides bugs. I can't+                         -- do the same thing for the other one for backcompat reasons.+        -> Graph (Node key payload)+graphFromVerticesAndAdjacency []       _     = emptyGraph+graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)+  where key_extractor = node_key+        (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor+        key_vertex_pair (a, b) = (expectJust $ key_vertex a,+                                  expectJust $ key_vertex b)+        reduced_edges = map key_vertex_pair edges+        graph = G.buildG bounds reduced_edges+
+ GHC/Data/Graph/Directed/Internal.hs view
@@ -0,0 +1,79 @@+module GHC.Data.Graph.Directed.Internal where++import GHC.Prelude+import GHC.Utils.Outputable++import Data.Array+import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation+import Data.Tree++data Graph node = Graph {+    gr_int_graph      :: IntGraph,+    gr_vertex_to_node :: Vertex -> node,+    gr_node_to_vertex :: node -> Maybe Vertex+}++data Edge node = Edge node node++------------------------------------------------------------+-- Nodes and Edges+------------------------------------------------------------++verticesG :: Graph node -> [node]+verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph)++edgesG :: Graph node -> [Edge node]+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph)+  where v2n = gr_vertex_to_node graph++------------------------------------------------------------+-- Showing Graphs+------------------------------------------------------------++instance Outputable node => Outputable (Graph node) where+    ppr graph = vcat [+                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),+                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))+                ]++instance Outputable node => Outputable (Edge node) where+    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to++{-+************************************************************************+*                                                                      *+*      IntGraphs+*                                                                      *+************************************************************************+-}++type IntGraph = G.Graph++------------------------------------------------------------+-- Depth first search numbering+------------------------------------------------------------++-- Data.Tree has flatten for Tree, but nothing for Forest+preorderF           :: Forest a -> [a]+preorderF ts         = concatMap flatten ts++------------------------------------------------------------+-- Finding reachable vertices+------------------------------------------------------------++-- This generalizes reachable which was found in Data.Graph+reachable    :: IntGraph -> [Vertex] -> [Vertex]+reachable g vs = preorderF (G.dfs g vs)++scc :: IntGraph -> [SCC Vertex]+scc graph = map decode forest+  where+    forest = {-# SCC "Digraph.scc" #-} G.scc graph++    decode (Node v []) | mentions_itself v = CyclicSCC [v]+                       | otherwise         = AcyclicSCC v+    decode other = CyclicSCC (dec other [])+      where dec (Node v ts) vs = v : foldr dec vs ts+    mentions_itself v = v `elem` (graph ! v)+
+ GHC/Data/Graph/Directed/Reachability.hs view
@@ -0,0 +1,178 @@+-- | An abstract interface for a fast reachability data structure constructed+-- from a 'GHC.Data.Graph.Directed' graph.+module GHC.Data.Graph.Directed.Reachability+  ( ReachabilityIndex++  -- * Constructing a reachability index+  , graphReachability, cyclicGraphReachability++  -- * Reachability queries+  , allReachable, allReachableMany+  , isReachable, isReachableMany++  -- * Debugging+  , reachabilityIndexMembers++  )+  where++import GHC.Prelude+import GHC.Data.Maybe++import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) )++import Data.Array ((!))+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS++import GHC.Data.Graph.Directed.Internal++--------------------------------------------------------------------------------+-- * Reachability index+--------------------------------------------------------------------------------++-- | The abstract data structure for fast reachability queries+data ReachabilityIndex node = ReachabilityIndex {+    index :: IM.IntMap IS.IntSet,+    from_vertex :: Vertex -> node,+    to_vertex :: node -> Maybe Vertex+}++--+reachabilityIndexMembers :: ReachabilityIndex node -> [node]+reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index)++--------------------------------------------------------------------------------+-- * Construction+--------------------------------------------------------------------------------++-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'.+-- If the graph can have cycles, use 'cyclicGraphReachability'+graphReachability :: Graph node -> ReachabilityIndex node+graphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to}+    where+      reachableGraph :: IM.IntMap IS.IntSet+      reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g]++      do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v))++-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles.+-- If this reachability index is just going to be used once, it may make sense+-- to use 'reachablesG' instead, which will traverse the reachable nodes without+-- constructing the index -- which may be faster.+cyclicGraphReachability :: Graph node -> ReachabilityIndex node+cyclicGraphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to}+    where+      reachableGraphCyclic :: IM.IntMap IS.IntSet+      reachableGraphCyclic = foldl' add_one_comp mempty comps++      neighboursOf v = g!v++      comps = scc g++      -- To avoid divergence on cyclic input, we build the result+      -- strongly connected component by component, in topological+      -- order. For each SCC, we know that:+      --+      --   * All vertices in the component can reach all other vertices+      --     in the component ("local" reachables)+      --+      --   * Other reachable vertices ("remote" reachables) must come+      --     from earlier components, either via direct neighbourhood, or+      --     transitively from earlier reachability map+      --+      -- This allows us to build the extension of the reachability map+      -- directly, without any self-reference, thereby avoiding a loop.+      add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet+      add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier+        where+          earlier_neighbours = neighboursOf v+          earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours+          all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)+      add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier+        where+          all_locals = IS.fromList vs+          local v = IS.delete v all_locals+              -- Arguably, for a cyclic SCC we should include each+              -- vertex in its own reachable set. However, this could+              -- lead to a lot of extra pain in client code to avoid+              -- looping when traversing the reachability map.+          all_neighbours = IS.fromList (concatMap neighboursOf vs)+          earlier_neighbours = all_neighbours IS.\\ all_locals+          earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)+          all_remotes = IS.unions (earlier_neighbours : earlier_further)++--------------------------------------------------------------------------------+-- * Reachability queries+--------------------------------------------------------------------------------++-- | 'allReachable' returns the nodes reachable from the given @root@ node.+--+-- Properties:+--  * The list of nodes /does not/ include the @root@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--+-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead.+allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -}+allReachable (ReachabilityIndex index from to) root = map from result+  where root_i = expectJust (to root)+        hits = {-# SCC "allReachable" #-} IM.lookup root_i index+        result = IS.toList $! expectJust hits++-- | 'allReachableMany' returns all nodes reachable from the many given @roots@.+--+-- Properties:+--  * The list of nodes /does not/ include the @roots@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--  * This function has $O(n)$ complexity where $n$ is the number of @roots@.+--+-- If you need a topologically sorted list, consider using the functions+-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG').+allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -}+allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits)+  where roots_i = [ v | Just v <- map to roots ]+        hits = {-# SCC "allReachableMany" #-}+               IS.unions $ map (expectJust . flip IM.lookup index) roots_i++-- | Fast reachability query.+--+-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@+-- asks whether @b@ can be reached through @g@ starting from @a@.+--+-- Properties:+--  * No self loops, i.e. @isReachable _ a a == False@+isReachable :: ReachabilityIndex node {-^ @g@ -}+            -> node -- ^ @a@+            -> node -- ^ @b@+            -> Bool -- ^ @b@ is reachable from @a@+isReachable (ReachabilityIndex index _ to) a b =+    IS.member b_i $+    expectJust $ IM.lookup a_i index+  where a_i = expectJust $ to a+        b_i = expectJust $ to b++-- | Fast reachability query with many roots.+--+-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@+-- asks whether @b@ can be reached through @g@ from any of the @roots@.+--+-- By partially applying this function to a set of roots, the resulting function can+-- be applied many times and share the initial work.+--+-- Properties:+--  * No self loops, i.e. @isReachableMany _ [a] a == False@+isReachableMany :: ReachabilityIndex node -- ^ @g@+                -> [node] -- ^ @roots@+                -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@+isReachableMany (ReachabilityIndex index _ to) roots =+  let roots_i = [ v | Just v <- map to roots ]+      unions =+          IS.unions $+            map (expectJust . flip IM.lookup index) roots_i+  in \b -> let b_i = expectJust $ to b+           in IS.member b_i unions
+ GHC/Data/Graph/Inductive/Graph.hs view
@@ -0,0 +1,642 @@+-- (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.List.NonEmpty (nonEmpty)+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 = case nonEmpty (nodes g) of+      Nothing -> panic "nodeRange of empty graph"+      Just vs -> (minimum vs, maximum vs)++  -- | 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.++----------------------------------------------------------------}
+ GHC/Data/Graph/Inductive/PatriciaTree.hs view
@@ -0,0 +1,344 @@++-- |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 Functor (Gr a) where+  fmap = fastEMap++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.++----------------------------------------------------------------}
+ GHC/Data/Graph/Ops.hs view
@@ -0,0 +1,699 @@+-- | 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)+
+ GHC/Data/Graph/Ppr.hs view
@@ -0,0 +1,173 @@++-- | 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 ];"
+ GHC/Data/Graph/UnVar.hs view
@@ -0,0 +1,188 @@+{-++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 GHC.Data.Graph.UnVar+    ( UnVarSet+    , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets+    , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList+    , elemUnVarSet, isEmptyUnVarSet+    , UnVarGraph+    , emptyUnVarGraph+    , unionUnVarGraph, unionUnVarGraphs+    , completeGraph, completeBipartiteGraph+    , neighbors+    , hasLoopAt+    , delNode+    , domUFMUnVarSet+    ) where++import GHC.Prelude++import GHC.Types.Unique.FM( UniqFM, ufmToSet_Directly )+import GHC.Types.Var+import GHC.Utils.Outputable+import GHC.Types.Unique+import GHC.Word++import qualified GHC.Data.Word64Set 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 adjacent nodes+newtype UnVarSet = UnVarSet S.Word64Set+    deriving Eq++k :: Var -> Word64+k v = getKey (getUnique v)++domUFMUnVarSet :: UniqFM key elt -> UnVarSet+domUFMUnVarSet ae = UnVarSet $ ufmToSet_Directly ae++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++delUnVarSetList :: UnVarSet -> [Var] -> UnVarSet+delUnVarSetList s vs = s `minusUnVarSet` mkUnVarSet vs++minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet+minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'++sizeUnVarSet :: UnVarSet -> Int+sizeUnVarSet (UnVarSet s) = S.size s++mkUnVarSet :: [Var] -> UnVarSet+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs++extendUnVarSet :: Var -> UnVarSet -> UnVarSet+extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s++extendUnVarSetList :: [Var] -> UnVarSet -> UnVarSet+extendUnVarSetList vs s = s `unionUnVarSet` mkUnVarSet vs++unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)++unionUnVarSets :: [UnVarSet] -> UnVarSet+unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet++instance Outputable UnVarSet where+    ppr (UnVarSet s) = braces $+        hcat $ punctuate comma [ ppr (mkUniqueGrimily i) | i <- S.toList s]++data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph+                | CG    !UnVarSet           -- ^ complete graph+                | Union UnVarGraph UnVarGraph+                | Del   !UnVarSet UnVarGraph++emptyUnVarGraph :: UnVarGraph+emptyUnVarGraph = CG emptyUnVarSet++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 a b+  | is_null a = b+  | is_null b = a+  | otherwise = Union a b++unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph++-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph+completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2++completeGraph :: UnVarSet -> UnVarGraph+completeGraph s = prune $ CG s++-- (v' ∈ neighbors G v) <=> v--v' ∈ G+neighbors :: UnVarGraph -> Var -> UnVarSet+neighbors = go+  where+    go (Del d g) v+      | v `elemUnVarSet` d = emptyUnVarSet+      | otherwise          = go g v `minusUnVarSet` d+    go (Union g1 g2) v     = go g1 v `unionUnVarSet` go g2 v+    go (CG s) v            = if v `elemUnVarSet` s then s else emptyUnVarSet+    go (CBPG s1 s2) v      = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`+                             (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)++-- hasLoopAt G v <=> v--v ∈ G+hasLoopAt :: UnVarGraph -> Var -> Bool+hasLoopAt = go+  where+    go (Del d g) v+      | v `elemUnVarSet` d  = False+      | otherwise           = go g v+    go (Union g1 g2) v      = go g1 v || go g2 v+    go (CG s) v             = v `elemUnVarSet` s+    go (CBPG s1 s2) v       = v `elemUnVarSet` s1 && v `elemUnVarSet` s2++delNode :: UnVarGraph -> Var -> UnVarGraph+delNode (Del d g) v = Del (extendUnVarSet v d) g+delNode g         v+  | is_null g       = emptyUnVarGraph+  | otherwise       = Del (mkUnVarSet [v]) g++-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`+prune :: UnVarGraph -> UnVarGraph+prune = go emptyUnVarSet+  where+    go :: UnVarSet -> UnVarGraph -> UnVarGraph+    go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g+    go dels (Union g1 g2)+      | is_null g1' = g2'+      | is_null g2' = g1'+      | otherwise   = Union g1' g2'+      where+        g1' = go dels g1+        g2' = go dels g2+    go dels (CG s)        = CG (s `minusUnVarSet` dels)+    go dels (CBPG s1 s2)  = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)++-- | Shallow empty check.+is_null :: UnVarGraph -> Bool+is_null (CBPG s1 s2)  = isEmptyUnVarSet s1 || isEmptyUnVarSet s2+is_null (CG   s)      = isEmptyUnVarSet s+is_null _             = False++instance Outputable UnVarGraph where+    ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)+    ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)+    ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)+    ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)
+ GHC/Data/IOEnv.hs view
@@ -0,0 +1,260 @@++{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PatternSynonyms #-}+--+-- (c) The University of Glasgow 2002-2006+--++-- | The IO Monad with an environment+--+-- The environment is passed around as a Reader monad but+-- as its in the IO monad, mutable references can be used+-- for updating state.+--+module GHC.Data.IOEnv (+        IOEnv, -- Instance of Monad++        -- Monad utilities+        module GHC.Utils.Monad,++        -- Errors+        failM, failWithM,+        IOEnvFailure(..),++        -- Getting at the environment+        getEnv, setEnv, updEnv, updEnvIO,++        runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,+        tryM, tryAllM, tryMostM, fixM,++        -- I/O operations+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,+        atomicUpdMutVar, atomicUpdMutVar'+  ) where++import GHC.Prelude++import GHC.Driver.DynFlags+import {-# SOURCE #-} GHC.Driver.Hooks+import GHC.IO (catchException)+import GHC.Utils.Exception+import GHC.Unit.Module+import GHC.Utils.Panic++import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,+                          atomicModifyIORef, atomicModifyIORef' )+import System.IO.Unsafe ( unsafeInterleaveIO )+import System.IO        ( fixIO )+import Control.Monad+import Control.Monad.Trans.Reader+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import GHC.Utils.Monad+import GHC.Utils.Logger+import Control.Applicative (Alternative(..))+import GHC.Exts( oneShot )+import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar)+import Control.Concurrent (forkIO, killThread)++----------------------------------------------------------------------+-- Defining the monad type+----------------------------------------------------------------------+++newtype IOEnv env a = IOEnv' (env -> IO a)+  deriving (MonadThrow, MonadCatch, MonadMask, MonadFix) via (ReaderT env IO)+++-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+instance Functor (IOEnv env) where+   fmap f (IOEnv g) = IOEnv $ \env -> fmap f (g env)+   a <$ IOEnv g     = IOEnv $ \env -> g env >> pure a++instance MonadIO (IOEnv env) where+   liftIO f = IOEnv (\_ -> f)++pattern IOEnv :: forall env a. (env -> IO a) -> IOEnv env a+pattern IOEnv m <- IOEnv' m+  where+    IOEnv m = IOEnv' (oneShot m)++{-# COMPLETE IOEnv #-}++unIOEnv :: IOEnv env a -> (env -> IO a)+unIOEnv (IOEnv m) = m++instance Monad (IOEnv m) where+    (>>=)  = thenM+    (>>)   = (*>)++instance MonadFail (IOEnv m) where+    fail _ = failM -- Ignore the string++instance Applicative (IOEnv m) where+    pure = returnM+    IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )+    (*>) = thenM_++returnM :: a -> IOEnv env a+returnM a = IOEnv (\ _ -> return a)++thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b+thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;+                                         unIOEnv (f r) env })++thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })++failM :: IOEnv env a+failM = IOEnv (\ _ -> throwIO IOEnvFailure)++failWithM :: String -> IOEnv env a+failWithM s = IOEnv (\ _ -> ioError (userError s))++data IOEnvFailure = IOEnvFailure++instance Show IOEnvFailure where+    show IOEnvFailure = "IOEnv failure"++instance Exception IOEnvFailure++instance ContainsDynFlags env => HasDynFlags (IOEnv env) where+    getDynFlags = do env <- getEnv+                     return $! extractDynFlags env++instance ContainsHooks env => HasHooks (IOEnv env) where+    getHooks = do env <- getEnv+                  return $! extractHooks env++instance ContainsLogger env => HasLogger (IOEnv env) where+    getLogger = do env <- getEnv+                   return $! extractLogger env+++instance ContainsModule env => HasModule (IOEnv env) where+    getModule = do env <- getEnv+                   return $ extractModule env++----------------------------------------------------------------------+-- Fundamental combinators specific to the monad+----------------------------------------------------------------------+++---------------------------+runIOEnv :: env -> IOEnv env a -> IO a+runIOEnv env (IOEnv m) = m env+++---------------------------+{-# NOINLINE fixM #-}+  -- Aargh!  Not inlining fixM alleviates a space leak problem.+  -- Normally fixM is used with a lazy tuple match: if the optimiser is+  -- shown the definition of fixM, it occasionally transforms the code+  -- in such a way that the code generator doesn't spot the selector+  -- thunks.  Sigh.++fixM :: (a -> IOEnv env a) -> IOEnv env a+fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))+++---------------------------+tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)+-- Reflect UserError exceptions (only) into IOEnv monad+-- Other exceptions are not caught; they are simply propagated as exns+--+-- The idea is that errors in the program being compiled will give rise+-- to UserErrors.  But, say, pattern-match failures in GHC itself should+-- not be caught here, else they'll be reported as errors in the program+-- begin compiled!+tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))++tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)+tryIOEnvFailure = try++tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)+-- Catch *all* synchronous exceptions+-- This is used when running a Template-Haskell splice, when+-- even a pattern-match failure is a programmer error+tryAllM (IOEnv thing) = IOEnv (\ env -> safeTry (thing env))++-- | Like 'try', but doesn't catch asynchronous exceptions+safeTry :: IO a -> IO (Either SomeException a)+safeTry act = do+  var <- newEmptyMVar+  -- uninterruptible because we want to mask around 'killThread', which is interruptible.+  uninterruptibleMask $ \restore -> do+    -- Fork, so that 'act' is safe from all asynchronous exceptions other than the ones we send it+    t <- forkIO $ try (restore act) >>= putMVar var+    restore (readMVar var)+      `catchException` \(e :: SomeException) -> do+        -- Control reaches this point only if the parent thread was sent an async exception+        -- In that case, kill the 'act' thread and re-raise the exception+        killThread t+        throwIO e++tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)+tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))++---------------------------+unsafeInterleaveM :: IOEnv env a -> IOEnv env a+unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))++uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a+uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env))++----------------------------------------------------------------------+-- Alternative/MonadPlus+----------------------------------------------------------------------++instance Alternative (IOEnv env) where+    empty   = IOEnv (const empty)+    m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env)++instance MonadPlus (IOEnv env)++----------------------------------------------------------------------+-- Accessing input/output+----------------------------------------------------------------------++newMutVar :: a -> IOEnv env (IORef a)+newMutVar val = liftIO (newIORef val)++writeMutVar :: IORef a -> a -> IOEnv env ()+writeMutVar var val = liftIO (writeIORef var val)++readMutVar :: IORef a -> IOEnv env a+readMutVar var = liftIO (readIORef var)++updMutVar :: IORef a -> (a -> a) -> IOEnv env ()+updMutVar var upd = liftIO (modifyIORef var upd)++-- | Atomically update the reference.  Does not force the evaluation of the+-- new variable contents.  For strict update, use 'atomicUpdMutVar''.+atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b+atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)++-- | Strict variant of 'atomicUpdMutVar'.+atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b+atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd)++----------------------------------------------------------------------+-- Accessing the environment+----------------------------------------------------------------------++getEnv :: IOEnv env env+{-# INLINE getEnv #-}+getEnv = IOEnv (\ env -> return env)++-- | Perform a computation with a different environment+setEnv :: env' -> IOEnv env' a -> IOEnv env a+{-# INLINE setEnv #-}+setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env)++-- | Perform a computation with an altered environment+updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a+{-# INLINE updEnv #-}+updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))++-- | Perform a computation with an altered environment+updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a+{-# INLINE updEnvIO #-}+updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+ GHC/Data/List.hs view
@@ -0,0 +1,25 @@+module GHC.Data.List where++mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])+mapAndUnzip _ [] = ([], [])+mapAndUnzip f (x:xs)+  = let (r1,  r2)  = f x+        (rs1, rs2) = mapAndUnzip f xs+    in+    (r1:rs1, r2:rs2)++mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])+mapAndUnzip3 _ [] = ([], [], [])+mapAndUnzip3 f (x:xs)+  = let (r1,  r2,  r3)  = f x+        (rs1, rs2, rs3) = mapAndUnzip3 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3)++mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e])+mapAndUnzip4 _ [] = ([], [], [], [])+mapAndUnzip4 f (x:xs)+  = let (r1,  r2,  r3, r4)  = f x+        (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
+ GHC/Data/List/Infinite.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-}++module GHC.Data.List.Infinite+  ( Infinite (..)+  , head, tail+  , filter+  , (++)+  , unfoldr+  , (!!)+  , groupBy+  , dropList+  , iterate+  , concatMap+  , allListsOf+  , toList+  , repeat+  , enumFrom+  ) where++import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), Traversable (..), (<$>), flip, otherwise)+import Control.Category (Category (..))+import Control.Monad (guard)+import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty (..))+import qualified GHC.Base as List (build)++infixr 5 `Inf`++data Infinite a = Inf a (Infinite a)+  deriving (Foldable, Functor, Traversable)++head :: Infinite a -> a+head (Inf a _) = a+{-# NOINLINE [1] head #-}++tail :: Infinite a -> Infinite a+tail (Inf _ as) = as+{-# NOINLINE [1] tail #-}++{-# RULES+"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x+  #-}++instance Applicative Infinite where+    pure = repeat+    Inf f fs <*> Inf a as = Inf (f a) (fs <*> as)++instance Monad Infinite where+    x >>= f = join (f <$> x)+      where+        join (Inf a as) = head a `Inf` join (tail <$> as)++mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b+mapMaybe f = go+  where+    go (Inf a as) = let bs = go as in case f a of+        Nothing -> bs+        Just b -> Inf b bs+{-# NOINLINE [1] mapMaybe #-}++{-# RULES+"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as+"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f+  #-}++{-# INLINE [0] mapMaybeFB #-}+mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r+mapMaybeFB cons f a bs = case f a of+    Nothing -> bs+    Just r -> cons r bs++filter :: (a -> Bool) -> Infinite a -> Infinite a+filter f = mapMaybe (\ a -> a <$ guard (f a))+{-# INLINE filter #-}++infixr 5 +++(++) :: Foldable f => f a -> Infinite a -> Infinite a+(++) = flip (F.foldr Inf)++unfoldr :: (b -> (a, b)) -> b -> Infinite a+unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b+{-# INLINE unfoldr #-}++(!!) :: Infinite a -> Int -> a+Inf a _ !! 0 = a+Inf _ as !! n = as !! (n-1)++groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a)+groupBy eq = go+  where+    go (Inf a as) = Inf (a:|bs) (go cs)+      where (bs, cs) = span (eq a) as++span :: (a -> Bool) -> Infinite a -> ([a], Infinite a)+span p = spanJust (\ a -> a <$ guard (p a))+{-# INLINE span #-}++spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a)+spanJust p = go+  where+    go as@(Inf a as')+      | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs)+      | otherwise = ([], as)++iterate :: (a -> a) -> a -> Infinite a+iterate f = go where go a = Inf a (go (f a))+{-# NOINLINE [1] iterate #-}++{-# RULES+"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a)+"iterateFB" [1] iterateFB Inf = iterate+  #-}++iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b+iterateFB c f a = go a+  where go a = a `c` go (f a)+{-# INLINE [0] iterateFB #-}++concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b+concatMap f = go where go (Inf a as) = f a ++ go as+{-# NOINLINE [1] concatMap #-}++{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-}++{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-}++foldr :: (a -> b -> b) -> Infinite a -> b+foldr f = go where go (Inf a as) = f a (go as)+{-# INLINE [0] foldr #-}++build :: (forall b . (a -> b -> b) -> b) -> Infinite a+build g = g Inf+{-# INLINE [1] build #-}++-- Analogous to 'foldr'/'build' fusion for '[]'+{-# RULES+"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f+"foldr/id" foldr Inf = id++"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f)+  #-}++{-# RULES+"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as+"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g)+"mapFB/id" forall c . mapFB c (\ x -> x) = c+  #-}++mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c+mapFB c f = \ x ys -> c (f x) ys+{-# INLINE [0] mapFB #-}++dropList :: [a] -> Infinite b -> Infinite b+dropList [] bs = bs+dropList (_:as) (Inf _ bs) = dropList as bs++-- | Compute all lists of the given alphabet.+-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@+allListsOf :: [a] -> Infinite [a]+allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as)++-- See Note [Fusion for `Infinite` lists].+toList :: Infinite a -> [a]+toList = \ as -> List.build (\ c _ -> foldr c as)+{-# INLINE toList #-}++repeat :: a -> Infinite a+repeat a = as where as = Inf a as+{-# INLINE [0] repeat #-}++repeatFB :: (a -> b -> b) -> a -> b+repeatFB c x = xs where xs = c x xs+{-# INLINE [0] repeatFB #-}++{-# RULES+"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a+"repeatFB" [1] repeatFB Inf = repeat+  #-}++enumFrom :: Enum a => a -> Infinite a+enumFrom = iterate succ+{-# INLINE enumFrom #-}++{-+Note [Fusion for `Infinite` lists]+~~~~~~~~~~~~~~~~~~~~+We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in+GHC.Base to support fusion for regular lists. In particular, we define the following:+• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a`+• `foldr :: (a -> b -> b) -> Infinite a -> b`+• A RULE `foldr f (build g) = g f`+• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in+  terms of `foldr`++This can work across data types. For example, consider `toList :: Infinite a -> [a]`.+We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]').+Ergo, we define it in terms of 'Infinite.foldr' and `List.build`.++For a bigger example, consider `List.map f (toList (Infinite.map g as))`++We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`,+and the list structure between `toList` and `List.map`. And indeed we do: see test+"InfiniteListFusion".+-}
+ GHC/Data/List/NonEmpty.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where++import Prelude (Bool, (.))+import Control.Applicative+import qualified Control.Monad as List (zipWithM)+import Data.Foldable (Foldable (toList))+import Data.List.NonEmpty hiding (toList, unzip)+import qualified Data.List as List+import qualified GHC.Data.List as List++zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c)+zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs)+-- Inline to enable fusion of `List.zipWithM`+-- See Note [Fusion for zipN/zipWithN] in List.hs+{-# INLINE zipWithM #-}++unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)+unzip ((a,b):|xs) = (a:|as, b:|bs)+  where+    (as, bs) = List.unzip xs++unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)+unzip3 ((a,b,c):|xs) = (a:|as, b:|bs, c:|cs)+  where+    (as, bs, cs) = List.unzip3 xs++mapAndUnzip :: (a -> (b, c)) -> NonEmpty a -> (NonEmpty b, NonEmpty c)+mapAndUnzip f (x:|xs) = (b:|bs, c:|cs)+  where+    (b, c) = f x+    (bs, cs) = List.mapAndUnzip f xs++mapAndUnzip3 :: (a -> (b, c, d)) -> NonEmpty a -> (NonEmpty b, NonEmpty c, NonEmpty d)+mapAndUnzip3 f (x:|xs) = (b:|bs, c:|cs, d:|ds)+  where+    (b, c, d) = f x+    (bs, cs, ds) = List.mapAndUnzip3 f xs++isSingleton :: NonEmpty a -> Bool+isSingleton = List.null . tail
+ GHC/Data/List/SetOps.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE CPP #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++++-- | Set-like operations on lists+--+-- Avoid using them as much as possible+module GHC.Data.List.SetOps (+        unionLists, unionListsOrd, minusList,++        -- Association lists+        Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,++        -- Duplicate handling+        hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq,+        equivClasses,++        -- Indexing+        getNth,++        -- Membership+        isIn, isn'tIn,+   ) where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Data.Ord (comparing)+import qualified Data.Set as S++getNth :: Outputable a => [a] -> Int -> a+getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $+             xs !! n++{-+************************************************************************+*                                                                      *+        Treating lists as sets+        Assumes the lists contain no duplicates, but are unordered+*                                                                      *+************************************************************************+-}++++-- | Combines the two lists while keeping their order, placing the first argument+-- first in the result.+--+-- Uses a set internally to record duplicates. This makes it slightly slower for+-- very small lists but avoids quadratic behaviour for large lists.+unionListsOrd :: (HasDebugCallStack, Outputable a, Ord a) => [a] -> [a] -> [a]+unionListsOrd xs ys+  -- Since both arguments don't have internal duplicates we can just take all of xs+  -- and every element of ys that's not already in xs.+  = let set_ys = S.fromList ys+    in (filter (\e -> not $ S.member e set_ys) xs) ++ ys++-- | Assumes that the arguments contain no duplicates+unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]+-- We special case some reasonable common patterns.+unionLists xs [] = xs+unionLists [] ys = ys+unionLists [x] ys+  | isIn "unionLists" x ys = ys+  | otherwise = x:ys+unionLists xs [y]+  | isIn "unionLists" y xs = xs+  | otherwise = y:xs+unionLists xs ys+  = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) "unionLists" (ppr xs $$ ppr ys) $+    [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys++-- | Calculate the set difference of two lists. This is+-- /O((m + n) log n)/, where we subtract a list of /n/ elements+-- from a list of /m/ elements.+--+-- Extremely short cases are handled specially:+-- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1,+-- it takes /O(n)/ time.+minusList :: Ord a => [a] -> [a] -> [a]+-- There's no point building a set to perform just one lookup, so we handle+-- extremely short lists specially. It might actually be better to use+-- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5).+-- The tipping point will be somewhere in the area of where /m/ and /log n/+-- become comparable, but we probably don't want to work too hard on this.+minusList [] _ = []+minusList xs@[x] ys+  | x `elem` ys = []+  | otherwise = xs+-- Using an empty set or a singleton would also be silly, so let's not.+minusList xs [] = xs+minusList xs [y] = filter (/= y) xs+-- When each list has at least two elements, we build a set from the+-- second argument, allowing us to filter the first argument fairly+-- efficiently.+minusList xs ys = filter (`S.notMember` yss) xs+  where+    yss = S.fromList ys++{-+************************************************************************+*                                                                      *+\subsection[Utils-assoc]{Association lists}+*                                                                      *+************************************************************************++Inefficient finite maps based on association lists and equality.+-}++-- | A finite mapping based on equality and association lists.+type Assoc a b = [(a,b)]++assoc             :: (Eq a) => String -> Assoc a b -> a -> b+assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b+assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b+-- | Lookup key, fail gracefully using Nothing if not found.+assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b+assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b++assocDefaultUsing _  deflt []             _   = deflt+assocDefaultUsing eq deflt ((k,v) : rest) key+  | k `eq` key = v+  | otherwise  = assocDefaultUsing eq deflt rest key++assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key+assocDefault deflt      list key = assocDefaultUsing (==) deflt list key+assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key++assocMaybe alist key+  = lookup alist+  where+    lookup []             = Nothing+    lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest++{-+************************************************************************+*                                                                      *+\subsection[Utils-dups]{Duplicate-handling}+*                                                                      *+************************************************************************+-}++hasNoDups :: (Eq a) => [a] -> Bool++hasNoDups xs = f [] xs+  where+    f _           []     = True+    f seen_so_far (x:xs) = if x `is_elem` seen_so_far+                           then False+                           else f (x:seen_so_far) xs++    is_elem = isIn "hasNoDups"++equivClasses :: (a -> a -> Ordering) -- Comparison+             -> [a]+             -> [NonEmpty a]++equivClasses _   []      = []+equivClasses _   [stuff] = [stuff :| []]+equivClasses cmp items   = NE.groupBy eq (L.sortBy cmp items)+  where+    eq a b = case cmp a b of { EQ -> True; _ -> False }++-- | Remove the duplicates from a list using the provided+-- comparison function. Might change the order of elements.+--+-- Returns the list without duplicates, and accumulates+-- all the duplicates in the second component of its result.+removeDups :: (a -> a -> Ordering) -- Comparison function+           -> [a]+           -> ([a],          -- List with no duplicates+               [NonEmpty a]) -- List of duplicate groups.  One representative+                             -- from each group appears in the first result++removeDups _   []  = ([], [])+removeDups _   [x] = ([x],[])+removeDups cmp xs+  = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') ->+    (xs', dups) }+  where+    collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)+    collect_dups dups_so_far (x :| [])     = (dups_so_far,      x)+    collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)++removeDupsOn :: Ord b => (a -> b) -> [a] -> ([a], [NonEmpty a])+removeDupsOn f x = removeDups (comparing f) x++-- | Remove the duplicates from a list using the provided+-- comparison function.+nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a]+nubOrdBy cmp xs = fst (removeDups cmp xs)++findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]+findDupsEq _  [] = []+findDupsEq eq (x:xs) | L.null eq_xs  = findDupsEq eq xs+                     | otherwise     = (x :| eq_xs) : findDupsEq eq neq_xs+    where (eq_xs, neq_xs) = L.partition (eq x) xs++-- Debugging/specialising versions of \tr{elem} and \tr{notElem}++# if !defined(DEBUG)+isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool+isIn    _msg x ys = x `elem` ys+isn'tIn _msg x ys = x `notElem` ys++# else /* DEBUG */+isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool+isIn msg x ys+  = elem100 0 x ys+  where+    elem100 :: Eq a => Int -> a -> [a] -> Bool+    elem100 _ _ [] = False+    elem100 i x (y:ys)+      | i > 100 = warnPprTrace True ("Over-long elem in " ++ msg) empty (x `elem` (y:ys))+      | otherwise = x == y || elem100 (i + 1) x ys++isn'tIn msg x ys+  = notElem100 0 x ys+  where+    notElem100 :: Eq a => Int -> a -> [a] -> Bool+    notElem100 _ _ [] =  True+    notElem100 i x (y:ys)+      | i > 100 = warnPprTrace True ("Over-long notElem in " ++ msg) empty (x `notElem` (y:ys))+      | otherwise = x /= y && notElem100 (i + 1) x ys+# endif /* DEBUG */
+ GHC/Data/Maybe.hs view
@@ -0,0 +1,134 @@++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module GHC.Data.Maybe (+        module Data.Maybe,++        MaybeErr(..), -- Instance of Monad+        failME, isSuccess,++        orElse,+        firstJust, firstJusts, firstJustsM,+        whenIsJust,+        expectJust,+        rightToMaybe,++        -- * MaybeT+        MaybeT(..), liftMaybeT, tryMaybeT+    ) where++import GHC.Prelude+import GHC.IO (catchException)++import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Exception (SomeException(..))+import Data.Maybe+import Data.Foldable ( foldlM, for_ )+import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic+import GHC.Utils.Outputable+import Data.List.NonEmpty ( NonEmpty )+import Control.Applicative( Alternative( (<|>) ) )++infixr 4 `orElse`++{-+************************************************************************+*                                                                      *+\subsection[Maybe type]{The @Maybe@ type}+*                                                                      *+************************************************************************+-}++firstJust :: Maybe a -> Maybe a -> Maybe a+firstJust = (<|>)++-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or+-- @Nothing@ otherwise.+firstJusts :: Foldable f => f (Maybe a) -> Maybe a+firstJusts = msum+{-# SPECIALISE firstJusts :: [Maybe a] -> Maybe a #-}+{-# SPECIALISE firstJusts :: NonEmpty (Maybe a) -> Maybe a #-}++-- | Takes computations returnings @Maybes@; tries each one in order.+-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations+-- return @Nothing@.+firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)+firstJustsM = foldlM go Nothing where+  go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)+  go Nothing         action  = action+  go result@(Just _) _action = return result++expectJust :: HasCallStack => Maybe a -> a+-- always enable the call stack to get the location even on non-debug builds+{-# INLINE expectJust #-}+expectJust = fromMaybe expectJustError++expectJustError :: HasCallStack => a+expectJustError = pprPanic "expectJust" empty+{-# NOINLINE expectJustError #-}++whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenIsJust = for_++-- | Flipped version of @fromMaybe@, useful for chaining.+orElse :: Maybe a -> a -> a+orElse = flip fromMaybe++rightToMaybe :: Either a b -> Maybe b+rightToMaybe (Left _)  = Nothing+rightToMaybe (Right x) = Just x++{-+************************************************************************+*                                                                      *+\subsection[MaybeT type]{The @MaybeT@ monad transformer}+*                                                                      *+************************************************************************+-}++-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT++liftMaybeT :: Monad m => m a -> MaybeT m a+liftMaybeT act = MaybeT $ Just `liftM` act++-- | Try performing an 'IO' action, failing on error.+tryMaybeT :: IO a -> MaybeT IO a+tryMaybeT action = MaybeT $ catchException (Just `fmap` action) handler+  where+    handler (SomeException _) = return Nothing++{-+************************************************************************+*                                                                      *+\subsection[MaybeErr type]{The @MaybeErr@ type}+*                                                                      *+************************************************************************+-}++data MaybeErr err val = Succeeded val | Failed err+    deriving (Functor)++instance Applicative (MaybeErr err) where+  pure  = Succeeded+  (<*>) = ap++instance Monad (MaybeErr err) where+  Succeeded v >>= k = k v+  Failed e    >>= _ = Failed e++isSuccess :: MaybeErr err val -> Bool+isSuccess (Succeeded {}) = True+isSuccess (Failed {})    = False++failME :: err -> MaybeErr err val+failME e = Failed e
+ GHC/Data/OrdList.hs view
@@ -0,0 +1,279 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998+++-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++-- | Provide trees (of instructions), so that lists of instructions can be+-- appended in linear time.+module GHC.Data.OrdList (+        OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,+        nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,+        headOL,+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL,+        partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL+) where++import GHC.Prelude+import Data.Foldable++import GHC.Utils.Misc (strictMap)+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as Semigroup++infixl 5  `appOL`+infixl 5  `snocOL`+infixr 5  `consOL`++data OrdList a+  = None+  | One a+  | Many (NonEmpty a)+  | Cons a (OrdList a)+  | Snoc (OrdList a) a+  | Two (OrdList a) -- Invariant: non-empty+        (OrdList a) -- Invariant: non-empty+  deriving (Functor)++instance Outputable a => Outputable (OrdList a) where+  ppr ol = ppr (fromOL ol)  -- Convert to list and print that++instance Semigroup (OrdList a) where+  (<>) = appOL++instance Monoid (OrdList a) where+  mempty = nilOL+  mappend = (Semigroup.<>)+  mconcat = concatOL++instance Foldable OrdList where+  foldr   = foldrOL+  foldl'  = foldlOL+  toList  = fromOL+  null    = isNilOL+  length  = lengthOL++instance Traversable OrdList where+  traverse f xs = toOL <$> traverse f (fromOL xs)++nilOL    :: OrdList a+isNilOL  :: OrdList a -> Bool++unitOL   :: a           -> OrdList a+snocOL   :: OrdList a   -> a         -> OrdList a+consOL   :: a           -> OrdList a -> OrdList a+appOL    :: OrdList a   -> OrdList a -> OrdList a+concatOL :: [OrdList a] -> OrdList a+headOL   :: OrdList a   -> a+lastOL   :: OrdList a   -> a+lengthOL :: OrdList a   -> Int++nilOL        = None+unitOL as    = One as+snocOL as   b    = Snoc as b+consOL a    bs   = Cons a bs+concatOL aas = foldr appOL None aas++pattern NilOL :: OrdList a+pattern NilOL <- (isNilOL -> True) where+  NilOL = None++-- | An unboxed 'Maybe' type with two unboxed fields in the 'Just' case.+-- Useful for defining 'viewCons' and 'viewSnoc' without overhead.+type VMaybe a b = (# (# a, b #) | (# #) #)+pattern VJust :: a -> b -> VMaybe a b+pattern VJust a b = (# (# a, b #) | #)+pattern VNothing :: VMaybe a b+pattern VNothing = (# | (# #) #)+{-# COMPLETE VJust, VNothing #-}++pattern ConsOL :: a -> OrdList a -> OrdList a+pattern ConsOL x xs <- (viewCons -> VJust x xs) where+  ConsOL x xs = consOL x xs+{-# COMPLETE NilOL, ConsOL #-}++viewCons :: OrdList a -> VMaybe a (OrdList a)+viewCons None        = VNothing+viewCons (One a)     = VJust a NilOL+viewCons (Many (a :| [])) = VJust a NilOL+viewCons (Many (a :| b : bs)) = VJust a (Many (b :| bs))+viewCons (Cons a as) = VJust a as+viewCons (Snoc as a) = case viewCons as of+  VJust a' as' -> VJust a' (Snoc as' a)+  VNothing     -> VJust a NilOL+viewCons (Two as1 as2) = case viewCons as1 of+  VJust a' as1' -> VJust a' (Two as1' as2)+  VNothing      -> viewCons as2++pattern SnocOL :: OrdList a -> a -> OrdList a+pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where+  SnocOL xs x = snocOL xs x+{-# COMPLETE NilOL, SnocOL #-}++viewSnoc :: OrdList a -> VMaybe (OrdList a) a+viewSnoc None        = VNothing+viewSnoc (One a)     = VJust NilOL a+viewSnoc (Many as)   = (`VJust` NE.last as) $ case NE.init as of+  [] -> NilOL+  b : bs -> Many (b :| bs)+viewSnoc (Snoc as a) = VJust as a+viewSnoc (Cons a as) = case viewSnoc as of+  VJust as' a' -> VJust (Cons a as') a'+  VNothing     -> VJust NilOL a+viewSnoc (Two as1 as2) = case viewSnoc as2 of+  VJust as2' a' -> VJust (Two as1 as2') a'+  VNothing      -> viewSnoc as1++headOL None        = panic "headOL"+headOL (One a)     = a+headOL (Many as)   = NE.head as+headOL (Cons a _)  = a+headOL (Snoc as _) = headOL as+headOL (Two as _)  = headOL as++lastOL None        = panic "lastOL"+lastOL (One a)     = a+lastOL (Many as)   = NE.last as+lastOL (Cons _ as) = lastOL as+lastOL (Snoc _ a)  = a+lastOL (Two _ as)  = lastOL as++lengthOL None        = 0+lengthOL (One _)     = 1+lengthOL (Many as)   = length as+lengthOL (Cons _ as) = 1 + length as+lengthOL (Snoc as _) = 1 + length as+lengthOL (Two as bs) = length as + length bs++isNilOL None = True+isNilOL _    = False++None  `appOL` b     = b+a     `appOL` None  = a+One a `appOL` b     = Cons a b+a     `appOL` One b = Snoc a b+a     `appOL` b     = Two a b++fromOL :: OrdList a -> [a]+fromOL a = go a []+  where go None       acc = acc+        go (One a)    acc = a : acc+        go (Cons a b) acc = a : go b acc+        go (Snoc a b) acc = go a (b:acc)+        go (Two a b)  acc = go a (go b acc)+        go (Many xs)  acc = NE.toList xs ++ acc++fromOLReverse :: OrdList a -> [a]+fromOLReverse a = go a []+        -- acc is already in reverse order+  where go :: OrdList a -> [a] -> [a]+        go None       acc = acc+        go (One a)    acc = a : acc+        go (Cons a b) acc = go b (a : acc)+        go (Snoc a b) acc = b : go a acc+        go (Two a b)  acc = go b (go a acc)+        go (Many xs)  acc = reverse (NE.toList xs) ++ acc++mapOL :: (a -> b) -> OrdList a -> OrdList b+mapOL = fmap++mapOL' :: (a->b) -> OrdList a -> OrdList b+mapOL' _ None        = None+mapOL' f (One x)     = One $! f x+mapOL' f (Cons x xs) = let !x1 = f x+                           !xs1 = mapOL' f xs+                       in Cons x1 xs1+mapOL' f (Snoc xs x) = let !x1 = f x+                           !xs1 = mapOL' f xs+                       in Snoc xs1 x1+mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1+                           !b2' = mapOL' f b2+                       in Two b1' b2'+mapOL' f (Many (x :| xs)) = let !x1 = f x+                                !xs1 = strictMap f xs+                            in Many (x1 :| xs1)++foldrOL :: (a->b->b) -> b -> OrdList a -> b+foldrOL _ z None        = z+foldrOL k z (One x)     = k x z+foldrOL k z (Cons x xs) = k x (foldrOL k z xs)+foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs+foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1+foldrOL k z (Many xs)   = foldr k z xs++-- | Strict left fold.+foldlOL :: (b->a->b) -> b -> OrdList a -> b+foldlOL _ z None        = z+foldlOL k z (One x)     = k z x+foldlOL k z (Cons x xs) = let !z' = (k z x) in foldlOL k z' xs+foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x+foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2+foldlOL k z (Many xs)   = foldl' k z xs++partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a)+partitionOL _ None = (None,None)+partitionOL f (One x)+  | f x       = (One x, None)+  | otherwise = (None, One x)+partitionOL f (Two xs ys) = (Two ls1 ls2, Two rs1 rs2)+  where !(!ls1,!rs1) = partitionOL f xs+        !(!ls2,!rs2) = partitionOL f ys+partitionOL f (Cons x xs)+  | f x       = (Cons x ls, rs)+  | otherwise = (ls, Cons x rs)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Snoc xs x)+  | f x       = (Snoc ls x, rs)+  | otherwise = (ls, Snoc rs x)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Many xs) = (toOL ls, toOL rs)+  where !(!ls,!rs) = NE.partition f xs++toOL :: [a] -> OrdList a+toOL [] = None+toOL [x] = One x+toOL (x : xs) = Many (x :| xs)++reverseOL :: OrdList a -> OrdList a+reverseOL None = None+reverseOL (One x) = One x+reverseOL (Cons a b) = Snoc (reverseOL b) a+reverseOL (Snoc a b) = Cons b (reverseOL a)+reverseOL (Two a b)  = Two (reverseOL b) (reverseOL a)+reverseOL (Many xs)  = Many (NE.reverse xs)++-- | Compare not only the values but also the structure of two lists+strictlyEqOL :: Eq a => OrdList a   -> OrdList a -> Bool+strictlyEqOL None         None       = True+strictlyEqOL (One x)     (One y)     = x == y+strictlyEqOL (Cons a as) (Cons b bs) = a == b && as `strictlyEqOL` bs+strictlyEqOL (Snoc as a) (Snoc bs b) = a == b && as `strictlyEqOL` bs+strictlyEqOL (Two a1 a2) (Two b1 b2) = a1 `strictlyEqOL` b1 && a2 `strictlyEqOL` b2+strictlyEqOL (Many as)   (Many bs)   = as == bs+strictlyEqOL _            _          = False++-- | Compare not only the values but also the structure of two lists+strictlyOrdOL :: Ord a => OrdList a   -> OrdList a -> Ordering+strictlyOrdOL None         None       = EQ+strictlyOrdOL None         _          = LT+strictlyOrdOL (One x)     (One y)     = compare x y+strictlyOrdOL (One _)      _          = LT+strictlyOrdOL (Cons a as) (Cons b bs) =+  compare a b `mappend` strictlyOrdOL as bs+strictlyOrdOL (Cons _ _)   _          = LT+strictlyOrdOL (Snoc as a) (Snoc bs b) =+  compare a b `mappend` strictlyOrdOL as bs+strictlyOrdOL (Snoc _ _)   _          = LT+strictlyOrdOL (Two a1 a2) (Two b1 b2) =+  (strictlyOrdOL a1 b1) `mappend` (strictlyOrdOL a2 b2)+strictlyOrdOL (Two _ _)    _          = LT+strictlyOrdOL (Many as)   (Many bs)   = compare as bs+strictlyOrdOL (Many _ )   _           = GT
+ GHC/Data/OsPath.hs view
@@ -0,0 +1,29 @@+module GHC.Data.OsPath+  (+  -- * OsPath initialisation and transformation+    OsPath+  , OsString+  , encodeUtf+  , decodeUtf+  , unsafeDecodeUtf+  , unsafeEncodeUtf+  , os+  -- * Common utility functions+  , (</>)+  , (<.>)+  )+  where++import GHC.Prelude++import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic (panic)++import System.OsPath+import System.Directory.Internal (os)++-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.+-- Prefer 'decodeUtf' and gracious error handling.+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath+unsafeDecodeUtf p =+  either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
+ GHC/Data/Pair.hs view
@@ -0,0 +1,71 @@+{-+A simple homogeneous pair type with useful Functor, Applicative, and+Traversable instances.+-}+++{-# LANGUAGE DeriveTraversable #-}++module GHC.Data.Pair+   ( Pair(..)+   , unPair+   , toPair+   , swap+   , pLiftFst, pLiftSnd+   , unzipPairs+   )+where++import GHC.Prelude++import GHC.Utils.Outputable+import qualified Data.Semigroup as Semi++data Pair a = Pair { pFst :: a, pSnd :: a }+  deriving (Foldable, Functor, Traversable)+-- Note that Pair is a *unary* type constructor+-- whereas (,) is binary++-- The important thing about Pair is that it has a *homogeneous*+-- Functor instance, so you can easily apply the same function+-- to both components++instance Applicative Pair where+  pure x = Pair x x+  (Pair f g) <*> (Pair x y) = Pair (f x) (g y)++instance Semi.Semigroup a => Semi.Semigroup (Pair a) where+  Pair a1 b1 <> Pair a2 b2 =  Pair (a1 Semi.<> a2) (b1 Semi.<> b2)++instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where+  mempty = Pair mempty mempty+  mappend = (Semi.<>)++instance Outputable a => Outputable (Pair a) where+  ppr (Pair a b) = ppr a <+> char '~' <+> ppr b++unPair :: Pair a -> (a,a)+unPair (Pair x y) = (x,y)++toPair :: (a,a) -> Pair a+toPair (x,y) = Pair x y++swap :: Pair a -> Pair a+swap (Pair x y) = Pair y x++pLiftFst :: (a -> a) -> Pair a -> Pair a+pLiftFst f (Pair a b) = Pair (f a) b++pLiftSnd :: (a -> a) -> Pair a -> Pair a+pLiftSnd f (Pair a b) = Pair a (f b)++unzipPairs :: [Pair a] -> ([a], [a])+unzipPairs [] = ([], [])+unzipPairs (Pair a b : prs) = (a:as, b:bs)+  where+    !(as,bs) = unzipPairs prs+    -- This makes the unzip work eagerly, building no thunks at+    -- the cost of doing all the work up-front.++instance Foldable1 Pair where+    foldMap1 f (Pair a b) = f a Semi.<> f b
+ GHC/Data/SmallArray.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE BlockArguments #-}++-- | Small-array+module GHC.Data.SmallArray+  ( SmallMutableArray (..)+  , SmallArray (..)+  , newSmallArray+  , writeSmallArray+  , freezeSmallArray+  , unsafeFreezeSmallArray+  , indexSmallArray+  , sizeofSmallArray+  , listToArray+  , mapSmallArray+  , foldMapSmallArray+  , rnfSmallArray++  -- * IO Operations+  , SmallMutableArrayIO+  , newSmallArrayIO+  , writeSmallArrayIO+  , unsafeFreezeSmallArrayIO+  )+where++import GHC.Exts+import GHC.Prelude+import GHC.IO+import GHC.ST+import Control.DeepSeq++data SmallArray a = SmallArray (SmallArray# a)++data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)++type SmallMutableArrayIO a = SmallMutableArray RealWorld a++newSmallArray+  :: Int  -- ^ size+  -> a    -- ^ initial contents+  -> State# s+  -> (# State# s, SmallMutableArray s a #)+{-# INLINE newSmallArray #-}+newSmallArray (I# sz) x s = case newSmallArray# sz x s of+  (# s', a #) -> (# s', SmallMutableArray a #)++newSmallArrayIO :: Int -> a -> IO (SmallMutableArrayIO a)+newSmallArrayIO sz x = IO $ \s -> newSmallArray sz x s++writeSmallArray+  :: SmallMutableArray s a -- ^ array+  -> Int                   -- ^ index+  -> a                     -- ^ new element+  -> State# s+  -> State# s+{-# INLINE writeSmallArray #-}+writeSmallArray (SmallMutableArray a) (I# i) x = writeSmallArray# a i x++writeSmallArrayIO :: SmallMutableArrayIO a+                  -> Int+                  -> a+                  -> IO ()+writeSmallArrayIO a ix v = IO $ \s -> (# writeSmallArray a ix v s, () #)+++-- | Copy and freeze a slice of a mutable array.+freezeSmallArray+  :: SmallMutableArray s a -- ^ source+  -> Int                   -- ^ offset+  -> Int                   -- ^ length+  -> State# s+  -> (# State# s, SmallArray a #)+{-# INLINE freezeSmallArray #-}+freezeSmallArray (SmallMutableArray ma) (I# offset) (I# len) s =+  case freezeSmallArray# ma offset len s of+    (# s', a #) -> (# s', SmallArray a #)++-- | Freeze a mutable array (no copy!)+unsafeFreezeSmallArray+  :: SmallMutableArray s a+  -> State# s+  -> (# State# s, SmallArray a #)+{-# INLINE unsafeFreezeSmallArray #-}+unsafeFreezeSmallArray (SmallMutableArray ma) s =+  case unsafeFreezeSmallArray# ma s of+    (# s', a #) -> (# s', SmallArray a #)++unsafeFreezeSmallArrayIO :: SmallMutableArrayIO a -> IO (SmallArray a)+unsafeFreezeSmallArrayIO arr = IO $ \s -> unsafeFreezeSmallArray arr s++-- | Get the size of a 'SmallArray'+sizeofSmallArray+  :: SmallArray a+  -> Int+{-# INLINE sizeofSmallArray #-}+sizeofSmallArray (SmallArray sa#) =+  case sizeofSmallArray# sa# of+    s -> I# s++-- | Index a small-array (no bounds checking!)+indexSmallArray+  :: SmallArray a -- ^ array+  -> Int          -- ^ index+  -> a+{-# INLINE indexSmallArray #-}+indexSmallArray (SmallArray sa#) (I# i) =+  case indexSmallArray# sa# i of+    (# v #) -> v++-- | Map a function over the elements of a 'SmallArray'+--+mapSmallArray :: (a -> b) -> SmallArray a -> SmallArray b+{-# INLINE mapSmallArray #-}+mapSmallArray f sa = runST $ ST $ \s ->+  let+    n = sizeofSmallArray sa+    go !i saMut# state#+      | i < n =+        let+          a = indexSmallArray sa i+          newState# = writeSmallArray saMut# i (f a) state#+        in+          go (i + 1) saMut# newState#+      | otherwise = state#+  in+  case newSmallArray n (error "SmallArray: internal error, uninitialised elements") s of+    (# s', mutArr #) ->+      case go 0 mutArr s' of+        s'' -> unsafeFreezeSmallArray mutArr s''++-- | Fold the values of a 'SmallArray' into a 'Monoid m' of choice+foldMapSmallArray :: Monoid m => (a -> m) -> SmallArray a -> m+{-# INLINE foldMapSmallArray #-}+foldMapSmallArray f sa = go 0+  where+    n = sizeofSmallArray sa+    go i+      | i < n = f (indexSmallArray sa i) `mappend` go (i + 1)+      | otherwise = mempty++-- | Force the elements of the given 'SmallArray'+--+rnfSmallArray :: NFData a => SmallArray a -> ()+{-# INLINE rnfSmallArray #-}+rnfSmallArray sa = go 0+  where+    n = sizeofSmallArray sa+    go !i+      | i < n = rnf (indexSmallArray sa i) `seq` go (i + 1)+      | otherwise = ()++-- | Convert a list into an array.+listToArray :: Int -> (e -> Int) -> (e -> a) -> [e] -> SmallArray a+{-# INLINE listToArray #-}+listToArray (I# size) index_of value_of xs = runST $ ST \s ->+  let+    index_of' e = case index_of e of I# i -> i+    write_elems ma es s = case es of+      []    -> s+      e:es' -> case writeSmallArray# ma (index_of' e) (value_of e) s of+                 s' -> write_elems ma es' s'+  in+  case newSmallArray# size undefined s of+    (# s', ma #) -> case write_elems ma xs s' of+      s'' -> case unsafeFreezeSmallArray# ma s'' of+        (# s''', a #) -> (# s''', SmallArray a #)
+ GHC/Data/Stream.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2012+--+-- -----------------------------------------------------------------------------++-- | Monadic streams+module GHC.Data.Stream (+    Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff,+    collect,  consume, fromList,+    map, mapM, mapAccumL_+  ) where++import GHC.Prelude hiding (map,mapM)++import Control.Monad hiding (mapM)+import Control.Monad.IO.Class++-- |+-- @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 @runStreamInternal@+-- in the Monad @m@, and it delivers either+--+--  * the final result: @Done b@, or+--  * @Yield a str@ where @a@ is the next element in the stream, and @str@+--     is the rest of the stream+--  * @Effect mstr@ where @mstr@ is some action running in @m@ which+--  generates 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.+--+-- 'Stream' is implemented in the "yoneda" style for efficiency. By+-- representing a stream in this manner 'fmap' and '>>=' operations are+-- accumulated in the function parameters before being applied once when+-- the stream is destroyed. In the old implementation each usage of 'mapM'+-- and '>>=' would traverse the entire stream in order to apply the+-- substitution at the leaves.+--+-- The >>= operation for 'Stream' was a hot-spot in the ticky profile for+-- the "ManyConstructors" test which called the 'cg' function many times in+-- @StgToCmm.hs@+--+newtype Stream m a b =+          Stream { runStreamInternal :: forall r' r .+                                        (a -> m r') -- For fusing calls to `map` and `mapM`+                                     -> (b -> StreamS m r' r)  -- For fusing `>>=`+                                     -> StreamS m r' r }++runStream :: Applicative m => Stream m r' r -> StreamS m r' r+runStream st = runStreamInternal st pure Done++data StreamS m a b = Yield a (StreamS m a b)+                   | Done b+                   | Effect (m (StreamS m a b))+  deriving (Functor)++instance Monad m => Applicative (StreamS m a) where+  pure = Done+  (<*>) = ap++instance Monad m => Monad (StreamS m a) where+  a >>= k = case a of+                      Done r -> k r+                      Yield a s -> Yield a (s >>= k)+                      Effect m -> Effect (fmap (>>= k) m)++instance Functor (Stream f a) where+  fmap = liftM++instance Applicative (Stream m a) where+  pure a = Stream $ \_f g -> g a+  (<*>) = ap++instance Monad (Stream m a) where+  Stream m >>= k = Stream $ \f h -> m f (\a -> runStreamInternal (k a) f h)++instance MonadIO m => MonadIO (Stream m b) where+  liftIO io = Stream $ \_f g -> Effect (g <$> liftIO io)++yield :: Monad m => a -> Stream m a ()+yield a = Stream $ \f rest -> Effect (flip Yield (rest ())  <$> f a)++-- | Turn a Stream into an ordinary list, by demanding all the elements.+collect :: Monad m => Stream m a () -> m [a]+collect str = go [] (runStream str)+ where+  go acc (Done ()) = return (reverse acc)+  go acc (Effect m) = m >>= go acc+  go acc (Yield a k) = go (a:acc) k++consume :: (Monad m, Monad n) => Stream m a b -> (forall a . m a -> n a) -> (a -> n ()) -> n b+consume str l f = go (runStream str)+  where+    go (Done r) = return r+    go (Yield a p) = f a >> go p+    go (Effect m)  = l m >>= go++-- | 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 $ \g h -> runStreamInternal str (g . f) h++-- | 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 $ \g h -> runStreamInternal str (g <=< f) h++-- | Note this is not very efficient because it traverses the whole stream+-- before rebuilding it, avoid using it if you can. mapAccumL used to+-- implemented but it wasn't used anywhere in the compiler and has similar+-- efficiency problems.+mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r+           -> Stream m b (c, r)+mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str)++  where+    go :: c+             -> (b -> m r')+             -> ((c, r) -> StreamS m r' r1)+             -> StreamS m a r+             -> StreamS m r' r1+    go c _f1 h1 (Done r) = h1 (c, r)+    go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b+                                           >>= \r' -> return $ Yield r' (go c' f1 h1 p)))+    go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)++-- | Lift an effect into the Stream+liftEff :: Monad m => m b -> Stream m a b+liftEff eff = Stream $ \_f g -> Effect (g <$> eff)++-- | Hoist the underlying Stream effect+-- Note this is not very efficience since, just like 'mapAccumL_', it also needs+-- to traverse and rebuild the whole stream.+hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b+hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where+  hs :: (a -> n r')+     -> (b -> StreamS n r' r)+     -> StreamS m a b+     -> StreamS n r' r+  hs f g x = case x of+    Done d -> g d+    Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r))+    Effect e -> Effect (h (hs f g <$> e))+
+ GHC/Data/Strict.hs view
@@ -0,0 +1,77 @@+-- Strict counterparts to common data structures,+-- e.g. tuples, lists, maybes, etc.+--+-- Import this module qualified as Strict.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable #-}++module GHC.Data.Strict (+    Maybe(Nothing, Just),+    fromMaybe,+    GHC.Data.Strict.maybe,+    Pair(And),+    -- Not used at the moment:+    --+    -- Either(Left, Right),+    -- List(Nil, Cons),+  ) where++import GHC.Prelude hiding (Maybe(..), Either(..))++import Control.Applicative+import Data.Semigroup+import Data.Data+import Control.DeepSeq++data Maybe a = Nothing | Just !a+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++instance NFData a => NFData (Maybe a) where+  rnf Nothing = ()+  rnf (Just x) = rnf x++fromMaybe :: a -> Maybe a -> a+fromMaybe d Nothing = d+fromMaybe _ (Just x) = x++maybe :: b -> (a -> b) -> Maybe a -> b+maybe d _ Nothing = d+maybe _ f (Just x) = f x++apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b+apMaybe (Just f) (Just x) = Just (f x)+apMaybe _ _ = Nothing++altMaybe :: Maybe a -> Maybe a -> Maybe a+altMaybe Nothing r = r+altMaybe l _ = l++instance Semigroup a => Semigroup (Maybe a) where+  Nothing <> b       = b+  a       <> Nothing = a+  Just a  <> Just b  = Just (a <> b)++instance Semigroup a => Monoid (Maybe a) where+  mempty = Nothing++instance Applicative Maybe where+  pure = Just+  (<*>) = apMaybe++instance Alternative Maybe where+  empty = Nothing+  (<|>) = altMaybe++data Pair a b = !a `And` !b+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)++-- The definitions below are commented out because they are+-- not used anywhere in the compiler, but are useful to showcase+-- the intent behind this module (i.e. how it may evolve).+--+-- data Either a b = Left !a | Right !b+--   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)+--+-- data List a = Nil | !a `Cons` !(List a)+--   deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+ GHC/Data/StringBuffer.hs view
@@ -0,0 +1,427 @@+{-+(c) The University of Glasgow 2006+(c) The University of Glasgow, 1997-2006+++Buffers for scanning string input stored in external arrays.+-}++{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -O2 #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++module GHC.Data.StringBuffer+       (+        StringBuffer(..),+        -- non-abstract for vs\/HaskellService++         -- * Creation\/destruction+        hGetStringBuffer,+        hGetStringBufferBlock,+        hPutStringBuffer,+        appendStringBuffers,+        stringToStringBuffer,+        stringBufferFromByteString,++        -- * Inspection+        nextChar,+        currentChar,+        prevChar,+        atEnd,+        fingerprintStringBuffer,++        -- * Moving and comparison+        stepOn,+        offsetBytes,+        byteDiff,+        atLine,++        -- * Conversion+        lexemeToString,+        lexemeToFastString,+        decodePrevNChars,++         -- * Parsing integers+        parseUnsignedInteger,+        findHashOffset,++        -- * Checking for bi-directional format characters+        containsBidirectionalFormatChar,+        bidirectionalFormatChars+        ) where++import GHC.Prelude++import GHC.Data.FastString+import GHC.Utils.Encoding+import GHC.Utils.IO.Unsafe+import GHC.Utils.Panic.Plain+import GHC.Utils.Exception      ( bracket_ )+import GHC.Fingerprint++import Data.Maybe+import System.IO+import System.IO.Unsafe         ( unsafePerformIO )+import GHC.IO.Encoding.UTF8     ( mkUTF8 )+import GHC.IO.Encoding.Failure  ( CodingFailureMode(IgnoreCodingFailure) )++import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString as BS+import Data.ByteString ( ByteString )++import GHC.Exts++import Foreign+import GHC.ForeignPtr (unsafeWithForeignPtr)++-- -----------------------------------------------------------------------------+-- The StringBuffer type++-- |A StringBuffer is an internal pointer to a sized chunk of bytes.+-- The bytes are intended to be *immutable*.  There are pure+-- operations to read the contents of a StringBuffer.+--+-- A StringBuffer may have a finalizer, depending on how it was+-- obtained.+--+data StringBuffer+ = StringBuffer {+     buf :: {-# UNPACK #-} !(ForeignPtr Word8),+     len :: {-# UNPACK #-} !Int,        -- length+     cur :: {-# UNPACK #-} !Int         -- current pos+  }+  -- The buffer is assumed to be UTF-8 encoded, and furthermore+  -- we add three @\'\\0\'@ bytes to the end as sentinels so that the+  -- decoder doesn't have to check for overflow at every single byte+  -- of a multibyte sequence.++instance Show StringBuffer where+        showsPrec _ s = showString "<stringbuffer("+                      . shows (len s) . showString "," . shows (cur s)+                      . showString ")>"++-- -----------------------------------------------------------------------------+-- Creation / Destruction++-- | Read a file into a 'StringBuffer'.  The resulting buffer is automatically+-- managed by the garbage collector.+hGetStringBuffer :: FilePath -> IO StringBuffer+hGetStringBuffer fname = do+   h <- openBinaryFile fname ReadMode+   size_i <- hFileSize h+   offset_i <- skipBOM h size_i 0  -- offset is 0 initially+   let size = fromIntegral $ size_i - offset_i+   buf <- mallocForeignPtrArray (size+3)+   unsafeWithForeignPtr buf $ \ptr -> do+     r <- if size == 0 then return 0 else hGetBuf h ptr size+     hClose h+     if (r /= size)+        then ioError (userError "short read of file")+        else newUTF8StringBuffer buf ptr size++hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer+hGetStringBufferBlock handle wanted+    = do size_i <- hFileSize handle+         offset_i <- hTell handle >>= skipBOM handle size_i+         let size = min wanted (fromIntegral $ size_i-offset_i)+         buf <- mallocForeignPtrArray (size+3)+         unsafeWithForeignPtr buf $ \ptr ->+             do r <- if size == 0 then return 0 else hGetBuf handle ptr size+                if r /= size+                   then ioError (userError $ "short read of file: "++show(r,size,size_i,handle))+                   else newUTF8StringBuffer buf ptr size++hPutStringBuffer :: Handle -> StringBuffer -> IO ()+hPutStringBuffer hdl (StringBuffer buf len cur)+    = unsafeWithForeignPtr (plusForeignPtr buf cur) $ \ptr ->+          hPutBuf hdl ptr len++-- | Skip the byte-order mark if there is one (see #1744 and #6016),+-- and return the new position of the handle in bytes.+--+-- This is better than treating #FEFF as whitespace,+-- because that would mess up layout.  We don't have a concept+-- of zero-width whitespace in Haskell: all whitespace codepoints+-- have a width of one column.+skipBOM :: Handle -> Integer -> Integer -> IO Integer+skipBOM h size offset =+  -- Only skip BOM at the beginning of a file.+  if size > 0 && offset == 0+    then do+      -- Validate assumption that handle is in binary mode.+      assertM (hGetEncoding h >>= return . isNothing)+      -- Temporarily select utf8 encoding with error ignoring,+      -- to make `hLookAhead` and `hGetChar` return full Unicode characters.+      bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do+        c <- hLookAhead h+        if c == '\xfeff'+          then hGetChar h >> hTell h+          else return offset+    else return offset+  where+    safeEncoding = mkUTF8 IgnoreCodingFailure++newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer+newUTF8StringBuffer buf ptr size = do+  pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]+  -- sentinels for UTF-8 decoding+  return $ StringBuffer buf size 0++appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer+appendStringBuffers sb1 sb2+    = do newBuf <- mallocForeignPtrArray (size+3)+         unsafeWithForeignPtr newBuf $ \ptr ->+          unsafeWithForeignPtr (buf sb1) $ \sb1Ptr ->+           unsafeWithForeignPtr (buf sb2) $ \sb2Ptr ->+             do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len+                copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len+                pokeArray (ptr `advancePtr` size) [0,0,0]+                return (StringBuffer newBuf size 0)+    where sb1_len = calcLen sb1+          sb2_len = calcLen sb2+          calcLen sb = len sb - cur sb+          size =  sb1_len + sb2_len++-- | Encode a 'String' into a 'StringBuffer' as UTF-8.  The resulting buffer+-- is automatically managed by the garbage collector.+stringToStringBuffer :: String -> StringBuffer+stringToStringBuffer str =+ unsafePerformIO $ do+  let size = utf8EncodedLength str+  buf <- mallocForeignPtrArray (size+3)+  unsafeWithForeignPtr buf $ \ptr -> do+    utf8EncodePtr ptr str+    pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]+    -- sentinels for UTF-8 decoding+  return (StringBuffer buf size 0)++-- | Convert a UTF-8 encoded 'ByteString' into a 'StringBuffer. This really+-- relies on the internals of both 'ByteString' and 'StringBuffer'.+--+-- /O(n)/ (but optimized into a @memcpy@ by @bytestring@ under the hood)+stringBufferFromByteString :: ByteString -> StringBuffer+stringBufferFromByteString bs =+  let BS.PS fp off len = BS.append bs (BS.pack [0,0,0])+  in StringBuffer { buf = fp, len = len - 3, cur = off }++-- -----------------------------------------------------------------------------+-- Grab a character++-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well+-- the remaining portion (analogous to 'Data.List.uncons').  __Warning:__ The+-- behavior is undefined if the 'StringBuffer' is empty.  The result shares+-- the same buffer as the original.  Similar to 'utf8DecodeChar', if the+-- character cannot be decoded as UTF-8, @\'\\0\'@ is returned.+{-# INLINE nextChar #-}+nextChar :: StringBuffer -> (Char,StringBuffer)+nextChar (StringBuffer buf len (I# cur#)) =+  -- Getting our fingers dirty a little here, but this is performance-critical+  inlinePerformIO $+    unsafeWithForeignPtr buf $ \(Ptr a#) ->+        case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of+          (# c#, nBytes# #) ->+             let cur' = I# (cur# +# nBytes#) in+             return (C# c#, StringBuffer buf len cur')+++bidirectionalFormatChars :: [(Char,String)]+bidirectionalFormatChars =+  [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)")+  , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)")+  , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)")+  , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)")+  , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)")+  , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)")+  , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)")+  , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)")+  , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)")+  ]++{-| Returns true if the buffer contains Unicode bi-directional formatting+characters.++https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types++Bidirectional format characters are one of+'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)"+'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)"+'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)"+'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)"+'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)"+'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)"+'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)"+'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)"+'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)"++This list is encoded in 'bidirectionalFormatChars'++-}+{-# INLINE containsBidirectionalFormatChar #-}+containsBidirectionalFormatChar :: StringBuffer -> Bool+containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#))+  = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do+  let go :: Int# -> Bool+      go i | isTrue# (i >=# len#) = False+           | otherwise = case utf8DecodeCharAddr# a# i of+                (# '\x202a'#  , _ #) -> True+                (# '\x202b'#  , _ #) -> True+                (# '\x202c'#  , _ #) -> True+                (# '\x202d'#  , _ #) -> True+                (# '\x202e'#  , _ #) -> True+                (# '\x2066'#  , _ #) -> True+                (# '\x2067'#  , _ #) -> True+                (# '\x2068'#  , _ #) -> True+                (# '\x2069'#  , _ #) -> True+                (# _, bytes #) -> go (i +# bytes)+  pure $! go cur#++-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous+-- to 'Data.List.head').  __Warning:__ The behavior is undefined if the+-- 'StringBuffer' is empty.  Similar to 'utf8DecodeChar', if the character+-- cannot be decoded as UTF-8, @\'\\0\'@ is returned.+currentChar :: StringBuffer -> Char+currentChar = fst . nextChar++prevChar :: StringBuffer -> Char -> Char+prevChar (StringBuffer _   _   0)   deflt = deflt+prevChar (StringBuffer buf _   cur) _     =+  inlinePerformIO $+    unsafeWithForeignPtr buf $ \p -> do+      p' <- utf8PrevChar (p `plusPtr` cur)+      return (fst (utf8DecodeCharPtr p'))++-- -----------------------------------------------------------------------------+-- Moving++-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous+-- to 'Data.List.tail').  __Warning:__ The behavior is undefined if the+-- 'StringBuffer' is empty.  The result shares the same buffer as the+-- original.+stepOn :: StringBuffer -> StringBuffer+stepOn s = snd (nextChar s)++-- | Return a 'StringBuffer' with the first @n@ bytes removed.  __Warning:__+-- If there aren't enough characters, the returned 'StringBuffer' will be+-- invalid and any use of it may lead to undefined behavior.  The result+-- shares the same buffer as the original.+offsetBytes :: Int                      -- ^ @n@, the number of bytes+            -> StringBuffer+            -> StringBuffer+offsetBytes i s = s { cur = cur s + i }++-- | Compute the difference in offset between two 'StringBuffer's that share+-- the same buffer.  __Warning:__ The behavior is undefined if the+-- 'StringBuffer's use separate buffers.+byteDiff :: StringBuffer -> StringBuffer -> Int+byteDiff s1 s2 = cur s2 - cur s1++-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null').+atEnd :: StringBuffer -> Bool+atEnd (StringBuffer _ l c) = l == c++-- | Computes a hash of the contents of a 'StringBuffer'.+fingerprintStringBuffer :: StringBuffer -> Fingerprint+fingerprintStringBuffer (StringBuffer buf len cur) =+  unsafePerformIO $+    withForeignPtr buf $ \ptr ->+      fingerprintData (ptr `plusPtr` cur) len++-- | Computes a 'StringBuffer' which points to the first character of the+-- wanted line. Lines begin at 1.+atLine :: Int -> StringBuffer -> Maybe StringBuffer+atLine line sb@(StringBuffer buf len _) =+  inlinePerformIO $+    unsafeWithForeignPtr buf $ \p -> do+      p' <- skipToLine line len p+      if p' == nullPtr+        then return Nothing+        else+          let+            delta = p' `minusPtr` p+          in return $ Just (sb { cur = delta+                               , len = len - delta+                               })++skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8)+skipToLine !line !len !op0 = go 1 op0+  where+    !opend = op0 `plusPtr` len++    go !i_line !op+      | op >= opend    = pure nullPtr+      | i_line == line = pure op+      | otherwise      = do+          w <- peek op :: IO Word8+          case w of+            10 -> go (i_line + 1) (plusPtr op 1)+            13 -> do+              -- this is safe because a 'StringBuffer' is+              -- guaranteed to have 3 bytes sentinel values.+              w' <- peek (plusPtr op 1) :: IO Word8+              case w' of+                10 -> go (i_line + 1) (plusPtr op 2)+                _  -> go (i_line + 1) (plusPtr op 1)+            _  -> go i_line (plusPtr op 1)++-- -----------------------------------------------------------------------------+-- Conversion++-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'.+-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8,+-- they will be replaced with @\'\\0\'@.+lexemeToString :: StringBuffer+               -> Int                   -- ^ @n@, the number of bytes+               -> String+lexemeToString _ 0 = ""+lexemeToString (StringBuffer buf _ cur) bytes =+  utf8DecodeForeignPtr buf cur bytes++lexemeToFastString :: StringBuffer+                   -> Int               -- ^ @n@, the number of bytes+                   -> FastString+lexemeToFastString _ 0 = nilFS+lexemeToFastString (StringBuffer buf _ cur) len =+   inlinePerformIO $+     unsafeWithForeignPtr buf $ \ptr ->+       return $! mkFastStringBytes (ptr `plusPtr` cur) len++-- | Return the previous @n@ characters (or fewer if we are less than @n@+-- characters into the buffer.+decodePrevNChars :: Int -> StringBuffer -> String+decodePrevNChars n (StringBuffer buf _ cur) =+    inlinePerformIO $ unsafeWithForeignPtr buf $ \p0 ->+      go p0 n "" (p0 `plusPtr` (cur - 1))+  where+    go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String+    go buf0 n acc p | n == 0 || buf0 >= p = return acc+    go buf0 n acc p = do+        p' <- utf8PrevChar p+        let (c,_) = utf8DecodeCharPtr p'+        go buf0 (n - 1) (c:acc) p'++-- -----------------------------------------------------------------------------+-- Parsing integer strings in various bases+parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer+parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let+    go i x | i == len  = x+           | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of+               '_'  -> go (i + 1) x    -- skip "_" (#14473)+               char -> go (i + 1) (x * radix + toInteger (char_to_int char))+  in go 0 0++-- | Find the offset of the '#' character in the StringBuffer.+--+-- Make sure that it contains one before calling this function!+findHashOffset :: StringBuffer -> Int+findHashOffset (StringBuffer buf _ cur)+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> do+      let+        go p = peek p >>= \case+          (0x23 :: Word8) -> pure $! ((p `minusPtr` ptr) - cur)+          _               -> go (p `plusPtr` 1)+      go (ptr `plusPtr` cur)
+ GHC/Data/TrieMap.hs view
@@ -0,0 +1,481 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+module GHC.Data.TrieMap(+   -- * Maps over 'Maybe' values+   MaybeMap,+   -- * Maps over 'List' values+   ListMap,+   -- * 'TrieMap' class+   TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,++   -- * Things helpful for adding additional Instances.+   (>.>), (|>), (|>>), XT,+   foldMaybe, filterMaybe,+   -- * Map for leaf compression+   GenMap,+   lkG, xtG, mapG, fdG,+   xtList, lkList++ ) where++import GHC.Prelude++import GHC.Types.Unique.DFM+import GHC.Types.Unique( Uniquable )++import qualified Data.Map    as Map+import qualified Data.IntMap as IntMap+import GHC.Utils.Outputable+import Control.Monad( (>=>) )+import Data.Kind( Type )++import qualified Data.Semigroup as S++{-+This module implements TrieMaps, which are finite mappings+whose key is a structured value like a CoreExpr or Type.++This file implements tries over general data structures.+Implementation for tries over Core Expressions/Types are+available in GHC.Core.Map.Expr.++The regular pattern for handling TrieMaps on data structures was first+described (to my knowledge) in Connelly and Morris's 1995 paper "A+generalization of the Trie Data Structure"; there is also an accessible+description of the idea in Okasaki's book "Purely Functional Data+Structures", Section 10.3.2++************************************************************************+*                                                                      *+                   The TrieMap class+*                                                                      *+************************************************************************+-}++type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)+                                --               or an existing elt (Just)++class Functor m => TrieMap m where+   type Key m :: Type+   emptyTM  :: m a+   lookupTM :: forall b. Key m -> m b -> Maybe b+   alterTM  :: forall b. Key m -> XT b -> m b -> m b+   filterTM :: (a -> Bool) -> m a -> m a+   mapMaybeTM :: (a -> Maybe b) -> m a -> m b+   foldTM   :: (a -> b -> b) -> m a -> b -> b+      -- The unusual argument order here makes+      -- it easy to compose calls to foldTM;+      -- see for example fdE below++insertTM :: TrieMap m => Key m -> a -> m a -> m a+insertTM k v m = alterTM k (\_ -> Just v) m++deleteTM :: TrieMap m => Key m -> m a -> m a+deleteTM k m = alterTM k (\_ -> Nothing) m++foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r+foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty++-- This looks inefficient.+isEmptyTM :: TrieMap m => m a -> Bool+isEmptyTM m = foldTM (\ _ _ -> False) m True++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++(>.>) :: (a -> b) -> (b -> c) -> a -> c+-- Reverse function composition (do f first, then g)+infixr 1 >.>+(f >.> g) x = g (f x)+infixr 1 |>, |>>++(|>) :: a -> (a->b) -> b     -- Reverse application+x |> f = f x++----------------------+(|>>) :: TrieMap m2+      => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a))+      -> (m2 a -> m2 a)+      -> m1 (m2 a) -> m1 (m2 a)+(|>>) f g = f (Just . g . deMaybe)++deMaybe :: TrieMap m => Maybe (m a) -> m a+deMaybe Nothing  = emptyTM+deMaybe (Just m) = m++{-+Note [Every TrieMap is a Functor]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every TrieMap T admits+   fmap :: (a->b) -> T a -> T b+where (fmap f t) applies `f` to every element of the range of `t`.+Ergo, we make `Functor` a superclass of `TrieMap`.++Moreover it is almost invariably possible to /derive/ Functor for each+particular instance. E.g. in the list instance we have+    data ListMap m a+      = LM { lm_nil  :: Maybe a+           , lm_cons :: m (ListMap m a) }+      deriving (Functor)+    instance TrieMap m => TrieMap (ListMap m) where { .. }++Alas, we not yet derive `Functor` for reasons of performance; see #22292.+-}++{-+************************************************************************+*                                                                      *+                   IntMaps+*                                                                      *+************************************************************************+-}++instance TrieMap IntMap.IntMap where+  type Key IntMap.IntMap = Int+  emptyTM = IntMap.empty+  lookupTM k m = IntMap.lookup k m+  alterTM = xtInt+  foldTM k m z = IntMap.foldr k z m+  filterTM f m = IntMap.filter f m+  mapMaybeTM f m = IntMap.mapMaybe f m++xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a+xtInt k f m = IntMap.alter f k m++instance Ord k => TrieMap (Map.Map k) where+  type Key (Map.Map k) = k+  emptyTM = Map.empty+  lookupTM = Map.lookup+  alterTM k f m = Map.alter f k m+  foldTM k m z = Map.foldr k z m+  filterTM f m = Map.filter f m+  mapMaybeTM f m = Map.mapMaybe f m+++{-+Note [foldTM determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~+We want foldTM to be deterministic, which is why we have an instance of+TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that+go wrong if foldTM is nondeterministic. Consider:++  f a b = return (a <> b)++Depending on the order that the typechecker generates constraints you+get either:++  f :: (Monad m, Monoid a) => a -> a -> m a++or:++  f :: (Monoid a, Monad m) => a -> a -> m a++The generated code will be different after desugaring as the dictionaries+will be bound in different orders, leading to potential ABI incompatibility.++One way to solve this would be to notice that the typeclasses could be+sorted alphabetically.++Unfortunately that doesn't quite work with this example:++  f a b = let x = a <> a; y = b <> b in x++where you infer:++  f :: (Monoid m, Monoid m1) => m1 -> m -> m1++or:++  f :: (Monoid m1, Monoid m) => m1 -> m -> m1++Here you could decide to take the order of the type variables in the type+according to depth first traversal and use it to order the constraints.++The real trouble starts when the user enables incoherent instances and+the compiler has to make an arbitrary choice. Consider:++  class T a b where+    go :: a -> b -> String++  instance (Show b) => T Int b where+    go a b = show a ++ show b++  instance (Show a) => T a Bool where+    go a b = show a ++ show b++  f = go 10 True++GHC is free to choose either dictionary to implement f, but for the sake of+determinism we'd like it to be consistent when compiling the same sources+with the same flags.++inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it+gets converted to a bag of (Wanted) Cts using a fold. Then in+solve_simple_wanteds it's merged with other WantedConstraints. We want the+conversion to a bag to be deterministic. For that purpose we use UniqDFM+instead of UniqFM to implement the TrieMap.++See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made+deterministic.+-}++instance forall key. Uniquable key => TrieMap (UniqDFM key) where+  type Key (UniqDFM key) = key+  emptyTM = emptyUDFM+  lookupTM k m = lookupUDFM m k+  alterTM k f m = alterUDFM f m k+  foldTM k m z = foldUDFM k z m+  filterTM f m = filterUDFM f m+  mapMaybeTM f m = mapMaybeUDFM f m++{-+************************************************************************+*                                                                      *+                   Maybes+*                                                                      *+************************************************************************++If              m is a map from k -> val+then (MaybeMap m) is a map from (Maybe k) -> val+-}++data MaybeMap m a = MM { mm_nothing  :: Maybe a, mm_just :: m a }++-- TODO(22292): derive+instance Functor m => Functor (MaybeMap m) where+    fmap f MM { mm_nothing = mn, mm_just = mj } = MM+      { mm_nothing = fmap f mn, mm_just = fmap f mj }++instance TrieMap m => TrieMap (MaybeMap m) where+   type Key (MaybeMap m) = Maybe (Key m)+   emptyTM  = MM { mm_nothing = Nothing, mm_just = emptyTM }+   lookupTM = lkMaybe lookupTM+   alterTM  = xtMaybe alterTM+   foldTM   = fdMaybe+   filterTM = ftMaybe+   mapMaybeTM = mpMaybe++instance TrieMap m => Foldable (MaybeMap m) where+  foldMap = foldMapTM++lkMaybe :: (forall b. k -> m b -> Maybe b)+        -> Maybe k -> MaybeMap m a -> Maybe a+lkMaybe _  Nothing  = mm_nothing+lkMaybe lk (Just x) = mm_just >.> lk x++xtMaybe :: (forall b. k -> XT b -> m b -> m b)+        -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a+xtMaybe _  Nothing  f m = m { mm_nothing  = f (mm_nothing m) }+xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f }++fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b+fdMaybe k m = foldMaybe k (mm_nothing m)+            . foldTM k (mm_just m)++ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a+ftMaybe f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }++mpMaybe :: TrieMap m => (a -> Maybe b) -> MaybeMap m a -> MaybeMap m b+mpMaybe f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = mn >>= f, mm_just = mapMaybeTM f mj }++foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b+foldMaybe _ Nothing  b = b+foldMaybe k (Just a) b = k a b++filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a+filterMaybe _ Nothing = Nothing+filterMaybe f input@(Just x) | f x       = input+                             | otherwise = Nothing++{-+************************************************************************+*                                                                      *+                   Lists+*                                                                      *+************************************************************************+-}++data ListMap m a+  = LM { lm_nil  :: Maybe a+       , lm_cons :: m (ListMap m a) }++-- TODO(22292): derive+instance Functor m => Functor (ListMap m) where+    fmap f LM { lm_nil = mnil, lm_cons = mcons } = LM+      { lm_nil = fmap f mnil, lm_cons = fmap (fmap f) mcons }++instance TrieMap m => TrieMap (ListMap m) where+   type Key (ListMap m) = [Key m]+   emptyTM  = LM { lm_nil = Nothing, lm_cons = emptyTM }+   lookupTM = lkList lookupTM+   alterTM  = xtList alterTM+   foldTM   = fdList+   filterTM = ftList+   mapMaybeTM = mpList++instance TrieMap m => Foldable (ListMap m) where+  foldMap = foldMapTM++instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where+  ppr m = text "List elts" <+> ppr (foldTM (:) m [])++lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)+        -> [k] -> ListMap m a -> Maybe a+lkList _  []     = lm_nil+lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs++xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b)+        -> [k] -> XT a -> ListMap m a -> ListMap m a+xtList _  []     f m = m { lm_nil  = f (lm_nil m) }+xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f }++fdList :: forall m a b. TrieMap m+       => (a -> b -> b) -> ListMap m a -> b -> b+fdList k m = foldMaybe k          (lm_nil m)+           . foldTM    (fdList k) (lm_cons m)++ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a+ftList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons }++mpList :: TrieMap m => (a -> Maybe b) -> ListMap m a -> ListMap m b+mpList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = mnil >>= f, lm_cons = fmap (mapMaybeTM f) mcons }++{-+************************************************************************+*                                                                      *+                   GenMap+*                                                                      *+************************************************************************++Note [Compressed TrieMap]+~~~~~~~~~~~~~~~~~~~~~~~~~++The GenMap constructor augments TrieMaps with leaf compression.  This helps+solve the performance problem detailed in #9960: suppose we have a handful+H of entries in a TrieMap, each with a very large key, size K. If you fold over+such a TrieMap you'd expect time O(H). That would certainly be true of an+association list! But with TrieMap we actually have to navigate down a long+singleton structure to get to the elements, so it takes time O(K*H).  This+can really hurt on many type-level computation benchmarks:+see for example T9872d.++The point of a TrieMap is that you need to navigate to the point where only one+key remains, and then things should be fast.  So the point of a SingletonMap+is that, once we are down to a single (key,value) pair, we stop and+just use SingletonMap.++'EmptyMap' provides an even more basic (but essential) optimization: if there is+nothing in the map, don't bother building out the (possibly infinite) recursive+TrieMap structure!++Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things+as INLINEABLE to permit specialization.+-}++data GenMap m a+   = EmptyMap+   | SingletonMap (Key m) a+   | MultiMap (m a)++instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where+  ppr EmptyMap = text "Empty map"+  ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v+  ppr (MultiMap m) = ppr m++-- TODO(22292): derive+instance Functor m => Functor (GenMap m) where+    fmap = mapG+    {-# INLINE fmap #-}++-- TODO undecidable instance+instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where+   type Key (GenMap m) = Key m+   emptyTM  = EmptyMap+   lookupTM = lkG+   alterTM  = xtG+   foldTM   = fdG+   filterTM = ftG+   mapMaybeTM = mpG++instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where+  foldMap = foldMapTM++--We want to be able to specialize these functions when defining eg+--tries over (GenMap CoreExpr) which requires INLINEABLE++{-# INLINEABLE lkG #-}+lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a+lkG _ EmptyMap                         = Nothing+lkG k (SingletonMap k' v') | k == k'   = Just v'+                           | otherwise = Nothing+lkG k (MultiMap m)                     = lookupTM k m++{-# INLINEABLE xtG #-}+xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a+xtG k f EmptyMap+    = case f Nothing of+        Just v  -> SingletonMap k v+        Nothing -> EmptyMap+xtG k f m@(SingletonMap k' v')+    | k' == k+    -- The new key matches the (single) key already in the tree.  Hence,+    -- apply @f@ to @Just v'@ and build a singleton or empty map depending+    -- on the 'Just'/'Nothing' response respectively.+    = case f (Just v') of+        Just v'' -> SingletonMap k' v''+        Nothing  -> EmptyMap+    | otherwise+    -- We've hit a singleton tree for a different key than the one we are+    -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then+    -- we can just return the old map. If not, we need a map with *two*+    -- entries. The easiest way to do that is to insert two items into an empty+    -- map of type @m a@.+    = case f Nothing of+        Nothing  -> m+        Just v   -> emptyTM |> alterTM k' (const (Just v'))+                           >.> alterTM k  (const (Just v))+                           >.> MultiMap+xtG k f (MultiMap m) = MultiMap (alterTM k f m)++{-# INLINEABLE mapG #-}+mapG :: Functor m => (a -> b) -> GenMap m a -> GenMap m b+mapG _ EmptyMap = EmptyMap+mapG f (SingletonMap k v) = SingletonMap k (f v)+mapG f (MultiMap m) = MultiMap (fmap f m)++{-# INLINEABLE fdG #-}+fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b+fdG _ EmptyMap = \z -> z+fdG k (SingletonMap _ v) = \z -> k v z+fdG k (MultiMap m) = foldTM k m++{-# INLINEABLE ftG #-}+ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a+ftG _ EmptyMap = EmptyMap+ftG f input@(SingletonMap _ v)+  | f v       = input+  | otherwise = EmptyMap+ftG f (MultiMap m) = MultiMap (filterTM f m)+  -- we don't have enough information to reconstruct the key to make+  -- a SingletonMap++{-# INLINEABLE mpG #-}+mpG :: TrieMap m => (a -> Maybe b) -> GenMap m a -> GenMap m b+mpG _ EmptyMap = EmptyMap+mpG f (SingletonMap k v) = case f v of+                             Just v' -> SingletonMap k v'+                             Nothing -> EmptyMap+mpG f (MultiMap m) = MultiMap (mapMaybeTM f m)
+ GHC/Data/Unboxed.hs view
@@ -0,0 +1,56 @@+-- Unboxed counterparts to data structures++{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnliftedNewtypes #-}++{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}+  -- If you use -fomit-interface-pragmas for your build, we won't+  -- inline the matcher for JustUB, and that turns out to have a+  -- catastropic effect on Lint, which uses unboxed Maybes.+  -- Simple fix: switch off -fomit-interface-pragmas for this tiny+  -- and very stable module.++module GHC.Data.Unboxed (+  MaybeUB(JustUB, NothingUB),+  fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB+  ) where++import GHC.Prelude hiding (Maybe(..), Either(..))++-- | Like Maybe, but using unboxed sums.+--+-- Use with care. Using a unboxed maybe is not always a win+-- in execution *time* even when allocations go down. So make+-- sure to benchmark for execution time as well. If the difference+-- in *runtime* for the compiler is too small to measure it's likely+-- better to use a regular Maybe instead.+--+-- This is since it causes more function arguments to be passed, and+-- potentially more variables to be captured by closures increasing+-- closure size.+newtype MaybeUB a = MaybeUB (# (# #) | a #)++pattern JustUB :: a -> MaybeUB a+pattern JustUB x = MaybeUB (# | x #)++pattern NothingUB :: MaybeUB a+pattern NothingUB = MaybeUB (# (# #) | #)++{-# COMPLETE NothingUB, JustUB #-}++fromMaybeUB :: a -> MaybeUB a -> a+fromMaybeUB d NothingUB = d+fromMaybeUB _ (JustUB x) = x++apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b+apMaybeUB (JustUB f) (JustUB x) = JustUB (f x)+apMaybeUB _ _ = NothingUB++fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b+fmapMaybeUB _f NothingUB = NothingUB+fmapMaybeUB f (JustUB x) = JustUB $ f x++maybeUB :: b -> (a -> b) -> MaybeUB a -> b+maybeUB _def f (JustUB x) = f x+maybeUB def _f NothingUB = def
+ GHC/Data/UnionFind.hs view
@@ -0,0 +1,91 @@+{- 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)+
+ GHC/Data/Word64Map.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonoLocalBinds #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- An efficient implementation of maps from integer keys to values+-- (dictionaries).+--+-- This module re-exports the value lazy "Data.Word64Map.Lazy" API, plus+-- several deprecated value strict functions. Please note that these functions+-- have different strictness properties than those in "Data.Word64Map.Strict":+-- they only evaluate the result of the combining function. For example, the+-- default value to 'insertWith'' is only evaluated if the combining function+-- is called and uses it.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Map (Word64Map)+-- >  import qualified Data.Word64Map as Word64Map+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+-- Many operations have a worst-case complexity of \(O(\min(n,64))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(64\)+-----------------------------------------------------------------------------++module GHC.Data.Word64Map+    ( module GHC.Data.Word64Map.Lazy+    ) where++import GHC.Data.Word64Map.Lazy
+ GHC/Data/Word64Map/Internal.hs view
@@ -0,0 +1,3575 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+--                (c) wren romano 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This defines the data structures and core (hidden) manipulations+-- on representations.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Word64Map matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.+--++module GHC.Data.Word64Map.Internal (+    -- * Map type+      Word64Map(..), Key          -- instance Eq,Show++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA+    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched+    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- ** Deprecated general combining function+    , mergeWithKey+    , mergeWithKey'++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internal types+    , Mask, Prefix, Nat++    -- * Utility+    , natFromInt+    , intFromNat+    , link+    , linkWithMask+    , bin+    , binCheckLeft+    , binCheckRight+    , zero+    , nomatch+    , match+    , mask+    , maskW+    , shorter+    , branchMask+    , highestBitMask++    -- * Used by "Word64Map.Merge.Lazy" and "Word64Map.Merge.Strict"+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++import GHC.Prelude.Basic hiding+  (lookup, filter, foldr, foldl, foldl', null, map)++import Data.Functor.Identity (Identity (..))+import Data.Semigroup (Semigroup(stimes,(<>)),stimesIdempotentMonoid)+import Data.Functor.Classes++import Control.DeepSeq (NFData(rnf))+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)++import GHC.Data.Word64Set.Internal (Key)+import qualified GHC.Data.Word64Set.Internal as Word64Set+import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair++import Data.Coerce+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),+                  DataType, mkDataType, gcast1)+import GHC.Exts (build)+import qualified GHC.Exts as GHCExts+import Text.Read+import qualified Control.Category as Category+import Data.Word+++-- A "Nat" is a 64 bit machine word (an unsigned Int64)+type Nat = Word64++natFromInt :: Key -> Nat+natFromInt = id+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Key+intFromNat = id+{-# INLINE intFromNat #-}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data Word64Map a = Bin {-# UNPACK #-} !Prefix+                    {-# UNPACK #-} !Mask+                    !(Word64Map a)+                    !(Word64Map a)+-- Fields:+--   prefix: The most significant bits shared by all keys in this Bin.+--   mask: The switching bit to determine if a key should follow the left+--         or right subtree of a 'Bin'.+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2. It is the largest bit position at which+--            two keys of the map differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+--            the left of the Mask bit.+-- Invariant: In (Bin prefix mask left right), left consists of the elements that+--            don't have the mask bit set; right is all the elements that do.+              | Tip {-# UNPACK #-} !Key a+              | Nil++type Prefix = Word64+type Mask   = Word64+++-- Some stuff from "Data.Word64Set.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type Word64SetPrefix = Word64+type Word64SetBitMap = Word64++bitmapOf :: Word64 -> Word64SetBitMap+bitmapOf x = shiftLL 1 (fromIntegral (x .&. Word64Set.suffixBitMask))+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Word64Map a -> Key -> a+(!) m k = find k m++-- | \(O(\min(n,W))\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: Word64Map a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: Word64Map a -> Word64Map b -> Word64Map a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++instance Monoid (Word64Map a) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @since 0.5.7+instance Semigroup (Word64Map a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable Word64Map where+  fold = go+    where go Nil = mempty+          go (Tip _ v) = v+          go (Bin _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Nil = mempty+          go (Tip _ v) = f v+          go (Bin _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= Word64Map.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "Data.Foldable.maximum (for Data.Word64Map): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "Data.Foldable.minimum (for Data.Word64Map): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}++-- | Traverses in order of increasing key.+instance Traversable Word64Map where+    traverse f = traverseWithKey (\_ -> f)+    {-# INLINE traverse #-}++instance NFData a => NFData (Word64Map a) where+    rnf Nil = ()+    rnf (Tip _ v) = rnf v+    rnf (Bin _ _ l r) = rnf l `seq` rnf r+++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (Word64Map a) where+  gfoldl f z im = z fromList `f` (toList im)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intMapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr]+++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.Word64Map.null (empty)           == True+-- > Data.Word64Map.null (singleton 1 'a') == False++null :: Word64Map a -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: Word64Map a -> Int+size = go 0+  where+    go !acc (Bin _ _ l r) = go (go acc l) r+    go acc (Tip _ _) = 1 + acc+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> Word64Map a -> Bool+member !k = go+  where+    go (Bin p m l r) | nomatch k p m = False+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx _) = k == kx+    go Nil = False++-- | \(O(\min(n,W))\). Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> Word64Map a -> Bool+notMember k m = not $ member k m++-- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing+lookup :: Key -> Word64Map a -> Maybe a+lookup !k = go+  where+    go (Bin _p m l r) | zero k m  = go l+                      | otherwise = go r+    go (Tip kx x) | k == kx   = Just x+                  | otherwise = Nothing+    go Nil = Nothing++-- See Note: Local 'go' functions and capturing]+find :: Key -> Word64Map a -> a+find !k = go+  where+    go (Bin _p m l r) | zero k m  = go l+                      | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = not_found+    go Nil = not_found++    not_found = error ("Word64Map.!: key " ++ show k ++ " is not an element of the map")++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> Word64Map a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> Word64Map a -> Maybe (Key, a)+lookupLT !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k <= ky   = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> Word64Map a -> Maybe (Key, a)+lookupGT !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k >= ky   = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def++-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> Word64Map a -> Maybe (Key, a)+lookupLE !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k < ky    = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> Word64Map a -> Maybe (Key, a)+lookupGE !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k > ky    = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: Word64Map a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: Word64Map a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(n+m)\). Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: Word64Map a -> Word64Map b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2 = disjoint1+  | shorter m2 m1 = disjoint2+  | p1 == p2      = disjoint l1 l2 && disjoint r1 r2+  | otherwise     = True+  where+    disjoint1 | nomatch p2 p1 m1 = True+              | zero p2 m1       = disjoint l1 t2+              | otherwise        = disjoint r1 t2+    disjoint2 | nomatch p1 p2 m2 = True+              | zero p1 m2       = disjoint t1 l2+              | otherwise        = disjoint t1 r2++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Word64Map.Strict" exposed a version of+-- 'compose' that forced the values of the output 'Word64Map'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: Word64Map c -> Word64Map Word64 -> Word64Map c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: Word64Map a+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> Word64Map a+singleton k x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> Word64Map a -> Word64Map a+insert !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insert k x l) r+  | otherwise     = Bin p m l (insert k x r)+insert k x t@(Tip ky _)+  | k==ky         = Tip k x+  | otherwise     = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"++insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insertWithKey f k x l) r+  | otherwise     = Bin p m l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+  | k == ky       = Tip k (f k x y)+  | otherwise     = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)+insertLookupWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = (Nothing,link k (Tip k x) p t)+  | zero k m      = let (found,l') = insertLookupWithKey f k x l+                    in (found,Bin p m l' r)+  | otherwise     = let (found,r') = insertLookupWithKey f k x r+                    in (found,Bin p m l r')+insertLookupWithKey f k x t@(Tip ky y)+  | k == ky       = (Just y,Tip k (f k x y))+  | otherwise     = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty                         == empty++delete :: Key -> Word64Map a -> Word64Map a+delete !k t@(Bin p m l r)+  | nomatch k p m = t+  | zero k m      = binCheckLeft p m (delete k l) r+  | otherwise     = binCheckRight p m l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a+adjustWithKey f !k (Bin p m l r)+  | zero k m      = Bin p m (adjustWithKey f k l) r+  | otherwise     = Bin p m l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+  | k == ky       = Tip ky (f k y)+  | otherwise     = t+adjustWithKey _ _ Nil = Nil+++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+updateWithKey f !k (Bin p m l r)+  | zero k m      = binCheckLeft p m (updateWithKey f k l) r+  | otherwise     = binCheckRight p m l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+  | k == ky       = case (f k y) of+                      Just y' -> Tip ky y'+                      Nothing -> Nil+  | otherwise     = t+updateWithKey _ _ Nil = Nil++-- | \(O(\min(n,W))\). Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)+updateLookupWithKey f !k (Bin p m l r)+  | zero k m      = let !(found,l') = updateLookupWithKey f k l+                    in (found,binCheckLeft p m l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckRight p m l r')+updateLookupWithKey f k t@(Tip ky y)+  | k==ky         = case (f k y) of+                      Just y' -> (Just y,Tip ky y')+                      Nothing -> (Just y,Nil)+  | otherwise     = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+alter f !k t@(Bin p m l r)+  | nomatch k p m = case f Nothing of+                      Nothing -> t+                      Just x -> link k (Tip k x) p t+  | zero k m      = binCheckLeft p m (alter f k l) r+  | otherwise     = binCheckRight p m l (alter f k r)+alter f k t@(Tip ky y)+  | k==ky         = case f (Just y) of+                      Just x -> Tip ky x+                      Nothing -> Nil+  | otherwise     = case f Nothing of+                      Just x -> link k (Tip k x) ky t+                      Nothing -> Tip ky y+alter f k Nil     = case f Nothing of+                      Just x -> Tip k x+                      Nothing -> Nil++-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just v' -> insert k v' m+  where mv = lookup k m++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Foldable f => f (Word64Map a) -> Word64Map a+unions xs+  = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(n+m)\). The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Word64Map a -> Word64Map a -> Word64Map a+union m1 m2+  = mergeWithKey' Bin const id id m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(n+m)\). Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Word64Map a -> Word64Map b -> Word64Map a+difference m1 m2+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | \(O(n+m)\). Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | \(O(n+m)\). Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a+withoutKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)+    | shorter m1 m2  = difference1+    | shorter m2 m1  = difference2+    | p1 == p2       = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)+    | otherwise      = t1+    where+    difference1+        | nomatch p2 p1 m1  = t1+        | zero p2 m1        = binCheckLeft p1 m1 (withoutKeys l1 t2) r1+        | otherwise         = binCheckRight p1 m1 l1 (withoutKeys r1 t2)+    difference2+        | nomatch p1 p2 m2  = t1+        | zero p1 m2        = withoutKeys t1 l2+        | otherwise         = withoutKeys t1 r2+withoutKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =+    let minbit = bitmapOf p1+        lt_minbit = minbit - 1+        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+        gt_maxbit = (-maxbit) `xor` maxbit+    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+    -- and 'withoutBM' here, in order to avoid redundant case analyses?+    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _ _) Word64Set.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `Word64Set.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+    :: Word64SetPrefix -> Word64Map a -> (Word64Map a -> Word64Map a) -> Word64Map a+updatePrefix !kp t@(Bin p m l r) f+    | m .&. Word64Set.suffixBitMask /= 0 =+        if p .&. Word64Set.prefixBitMask == kp then f t else t+    | nomatch kp p m = t+    | zero kp m      = binCheckLeft p m (updatePrefix kp l f) r+    | otherwise      = binCheckRight p m l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+    | kx .&. Word64Set.prefixBitMask == kp = f t+    | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: Word64SetBitMap -> Word64Map a -> Word64Map a+withoutBM 0 t = t+withoutBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?+    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = Nil+    | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Word64Map a -> Word64Map b -> Word64Map a+intersection m1 m2+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | \(O(n+m)\). The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a+restrictKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)+    | shorter m1 m2  = intersection1+    | shorter m2 m1  = intersection2+    | p1 == p2       = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)+    | otherwise      = Nil+    where+    intersection1+        | nomatch p2 p1 m1  = Nil+        | zero p2 m1        = restrictKeys l1 t2+        | otherwise         = restrictKeys r1 t2+    intersection2+        | nomatch p1 p2 m2  = Nil+        | zero p1 m2        = restrictKeys t1 l2+        | otherwise         = restrictKeys t1 r2+restrictKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =+    let minbit = bitmapOf p1+        ge_minbit = complement (minbit - 1)+        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+        le_maxbit = maxbit .|. (maxbit - 1)+    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+    -- and 'restrictBM' here, in order to avoid redundant case analyses?+    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _ _) Word64Set.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `Word64Set.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: Word64SetPrefix -> Word64Map a -> Word64Map a+lookupPrefix !kp t@(Bin p m l r)+    | m .&. Word64Set.suffixBitMask /= 0 =+        if p .&. Word64Set.prefixBitMask == kp then t else Nil+    | nomatch kp p m = Nil+    | zero kp m      = lookupPrefix kp l+    | otherwise      = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+    | (kx .&. Word64Set.prefixBitMask) == kp = t+    | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: Word64SetBitMap -> Word64Map a -> Word64Map a+restrictBM 0 _ = Nil+restrictBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?+    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = t+    | otherwise = Nil+restrictBM _ Nil = Nil+++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Word64Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+             -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) ->+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+--   reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+--   Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> Mask -> Word64Map c -> Word64Map c -> Word64Map c)+              -> (Word64Map a -> Word64Map b -> Word64Map c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+              -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey' bin' f g1 g2 = go+  where+    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)+      where+        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)+               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)+        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)+               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)++    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+      where+        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)+          | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)+          | otherwise  = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)+        merge0 t2 k2 t1@(Tip k1 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t2 _  Nil = g2 t2++    go t1@(Bin _ _ _ _) Nil = g1 t1++    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+      where+        merge0 t1 k1 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)+          | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)+          | otherwise  = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)+        merge0 t1 k1 t2@(Tip k2 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t1 _  Nil = g1 t1++    go Nil t2 = g2 t2++    maybe_link _ Nil _ t2 = t2+    maybe_link _ t1 _ Nil = t1+    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2+    {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+  mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+  { missingSubtree :: Word64Map x -> f (Word64Map y)+  , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+  where+    id = preserveMissing+    f . g =+      traverseMaybeMissing $ \ k x -> do+        y <- missingKey g k x+        case y of+          Nothing -> pure Nothing+          Just q  -> missingKey f k q+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey f k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+  m >>= f =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey m k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> missingKey (f r) k x+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: (Applicative f, Monad f)+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+  :: Functor f+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+  { missingSubtree = \m -> fmap f <$> missingSubtree t m+  , missingKey     = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapGentlyWhenMatched f t =+  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey     = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+  :: (b -> a)+  -> WhenMatched f a y z+  -> WhenMatched f b y z+contramapFirstWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+  :: (b -> a)+  -> WhenMatched f x a z+  -> WhenMatched f x b z+contramapSecondWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+  { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+  where+    id = zipWithMatched (\_ _ y -> y)+    f . g =+      zipWithMaybeAMatched $ \k x y -> do+        res <- runWhenMatched g k x y+        case res of+          Nothing -> pure Nothing+          Just r  -> runWhenMatched f k x r+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched fs k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+  m >>= f =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched m k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | When a key is found in both maps, apply a function to the key+-- and values and use the result in the merged map.+--+-- > zipWithMatched+-- >   :: (Key -> x -> y -> z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMatched+  :: Applicative f+  => (Key -> x -> y -> z)+  -> WhenMatched f x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values to produce an action and use its result in the merged+-- map.+--+-- @since 0.5.9+zipWithAMatched+  :: Applicative f+  => (Key -> x -> y -> f z)+  -> WhenMatched f x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values and maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- >   :: (Key -> x -> y -> Maybe z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+  :: Applicative f+  => (Key -> x -> y -> Maybe z)+  -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values, perform the resulting action, and maybe use the+-- result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched+  :: (Key -> x -> y -> f (Maybe z))+  -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Nil)+  , missingKey     = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey     = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey     = \k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}+++-- | Map over the entries whose keys are missing from the other+-- map, optionally removing some. This is the most powerful+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.+--+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey     = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+  :: Applicative f => (Key -> a -> f Bool) -> Word64Map a -> f (Word64Map a)+filterWithKeyA _ Nil           = pure Nil+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p m l r)+  | m < 0     = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+traverseMissing+  :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}+++-- | Traverse over the entries whose keys are missing from the other+-- map, optionally producing values to put in the result. This is+-- the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing+  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k) <$> f k x+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)+++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic+-- and two maps. It uses the tactics to merge the maps. Its behavior+-- is best understood via its fundamental tactics, 'mapMaybeMissing'+-- and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Word64Map a -- ^ Map @m1@+  -> Word64Map b -- ^ Map @m2@+  -> Word64Map c+merge g1 g2 f m1 m2 =+  runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f)+  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Word64Map a -- ^ Map @m1@+  -> Word64Map b -- ^ Map @m2@+  -> f (Word64Map c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t, missingKey = g2k}+    WhenMatched{matchedKey = f}+    = go+  where+    go t1  Nil = g1t t1+    go Nil t2  = g2t t2++    -- This case is already covered below.+    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++    go (Tip k1 x1) t2' = merge2 t2'+      where+        merge2 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)+          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)+          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)+        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2+        merge2 Nil           = subsingletonBy g1k k1 x1++    go t1' (Tip k2 x2) = merge1 t1'+      where+        merge1 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)+          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)+          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)+        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2+        merge1 Nil           = subsingletonBy g2k k2 x2++    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)+      where+        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)+               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)+        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)+               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)++    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+    {-# INLINE subsingletonBy #-}++    mergeTips k1 x1 k2 x2+      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2+      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+        {-+        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+        -}+      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+    {-# INLINE mergeTips #-}++    subdoubleton _ _   Nothing Nothing     = Nil+    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2+    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1+    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+    {-# INLINE subdoubleton #-}++    -- A variant of 'link_' which makes sure to execute side-effects+    -- in the right order.+    linkA+        :: Applicative f+        => Prefix -> f (Word64Map a)+        -> Prefix -> f (Word64Map a)+        -> f (Word64Map a)+    linkA p1 t1 p2 t2+      | zero p1 m = binA p m t1 t2+      | otherwise = binA p m t2 t1+      where+        m = branchMask p1 p2+        p = mask p1 m+    {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> Mask+        -> f (Word64Map a)+        -> f (Word64Map a)+        -> f (Word64Map a)+    binA p m a b+      | m < 0     = liftA2 (flip (bin p m)) b a+      | otherwise = liftA2       (bin p m)  a b+    {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"+++data View a = View {-# UNPACK #-} !Key a !(Word64Map a)++-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)+maxViewWithKey t = case t of+  Nil -> Nothing+  _ -> Just $ case maxViewWithKeySure t of+                View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: Word64Map a -> View a+maxViewWithKeySure t =+  case t of+    Nil -> error "maxViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    _ -> go t+  where+    go (Bin p m l r) =+        case go r of View k a r' -> View k a (binCheckRight p m l r')+    go (Tip k y) = View k y Nil+    go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)+minViewWithKey t =+  case t of+    Nil -> Nothing+    _ -> Just $ case minViewWithKeySure t of+                  View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: Word64Map a -> View a+minViewWithKeySure t =+  case t of+    Nil -> error "minViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go r of+        View k a r' -> View k a (binCheckRight p m l r')+    _ -> go t+  where+    go (Bin p m l r) =+        case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    go (Tip k y) = View k y Nil+    go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMin f = updateMinWithKey (const f)++-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: Word64Map a -> Maybe (a, Word64Map a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: Word64Map a -> Maybe (a, Word64Map a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | \(O(\min(n,W))\). Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: Word64Map a -> ((Key, a), Word64Map a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | \(O(\min(n,W))\). Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: Word64Map a -> ((Key, a), Word64Map a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: Word64Map a -> Maybe (Key, a)+lookupMin Nil = Nothing+lookupMin (Tip k v) = Just (k,v)+lookupMin (Bin _ m l r)+  | m < 0     = go r+  | otherwise = go l+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ l' _) = go l'+          go Nil            = Nothing++-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.+-- Use 'minViewWithKey' if the map may be empty.+findMin :: Word64Map a -> (Key, a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty map has no minimal element"++-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: Word64Map a -> Maybe (Key, a)+lookupMax Nil = Nothing+lookupMax (Tip k v) = Just (k,v)+lookupMax (Bin _ m l r)+  | m < 0     = go l+  | otherwise = go r+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ _ r') = go r'+          go Nil            = Nothing++-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.+-- Use 'maxViewWithKey' if the map may be empty.+findMax :: Word64Map a -> (Key, a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty map has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.+deleteMin :: Word64Map a -> Word64Map a+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.+deleteMax :: Word64Map a -> Word64Map a+deleteMax = maybe Nil snd . maxView+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2++{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool+isProperSubmapOfBy predicate t1 t2+  = case submapCmp predicate t1 t2 of+      LT -> True+      _  -> False++submapCmp :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Ordering+submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = submapCmpLt+  | p1 == p2       = submapCmpEq+  | otherwise      = GT  -- disjoint+  where+    submapCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = submapCmp predicate t1 l2+                | otherwise         = submapCmp predicate t1 r2+    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++submapCmp _         (Bin _ _ _ _) _  = GT+submapCmp predicate (Tip kx x) (Tip ky y)+  | (kx == ky) && predicate x y = EQ+  | otherwise                   = GT  -- disjoint+submapCmp predicate (Tip k x) t+  = case lookup k t of+     Just y | predicate x y -> LT+     _                      -> GT -- disjoint+submapCmp _    Nil Nil = EQ+submapCmp _    Nil _   = LT++-- | \(O(n+m)\). Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool+isSubmapOf m1 m2+  = isSubmapOfBy (==) m1 m2++{- | \(O(n+m)\).+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool+isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 &&+                       if zero p1 m2+                       then isSubmapOfBy predicate t1 l2+                       else isSubmapOfBy predicate t1 r2+  | otherwise      = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+isSubmapOfBy _         (Bin _ _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t     = case lookup k t of+                                         Just y  -> predicate x y+                                         Nothing -> False+isSubmapOfBy _         Nil _           = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Word64Map a -> Word64Map b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k (f x)+    go Nil           = Nil++{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = Tip k <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumL f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,r') = mapAccumL f a r+                (a2,l') = mapAccumL f a1 l+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,l') = mapAccumL f a l+                (a2,r') = mapAccumL f a1 r+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumRWithKey f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,l') = mapAccumRWithKey f a l+                (a2,r') = mapAccumRWithKey f a1 r+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,r') = mapAccumRWithKey f a r+                (a2,l') = mapAccumRWithKey f a1 l+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n \min(n,W))\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: (Key->Key) -> Word64Map a -> Word64Map a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a+mapKeysWith c f+  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> Word64Map a -> Word64Map a+mapKeysMonotonic f+  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> Word64Map a -> Word64Map a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> Word64Map a -> Word64Map a+filterWithKey predicate = go+    where+    go Nil           = Nil+    go t@(Tip k x)   = if predicate k x then t else Nil+    go (Bin p m l r) = bin p m (go l) (go r)++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t =+      case t of+        Bin p m l r ->+          let (l1 :*: l2) = go predicate l+              (r1 :*: r2) = go predicate r+          in bin p m l1 r1 :*: bin p m l2 r2+        Tip k x+          | predicate k x -> (t :*: Nil)+          | otherwise     -> (Nil :*: t)+        Nil -> (Nil :*: Nil)++-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a+takeWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then bin p m (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = bin p m l (go predicate' r)+      | otherwise         = go predicate' l+    go predicate' t'@(Tip ky _)+      | predicate' ky = t'+      | otherwise     = Nil+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a+dropWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p m l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = go predicate' r+      | otherwise         = bin p m (go predicate' l) r+    go predicate' t'@(Tip ky _)+      | predicate' ky = Nil+      | otherwise     = t'+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> Word64Map a -> (Word64Map a, Word64Map a)+spanAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt+      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r+    go predicate' t'@(Tip ky _)+      | predicate' ky = (t' :*: Nil)+      | otherwise     = (Nil :*: t')+    go _ Nil = (Nil :*: Nil)++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r) =+      bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left y  -> (Tip k y :*: Nil)+      Right z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> Word64Map a -> (Word64Map a, Word64Map a)+split k t =+  case t of+    Bin p m l r+      | m < 0 ->+        if k >= 0 -- handle negative numbers.+        then+          case go k l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go k t of+          (lt :*: gt) -> (lt, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'+      | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r+      | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(Word64Map a) !(Maybe a) !(Word64Map a)++mapLT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> Word64Map a -> (Word64Map a, Maybe a, Word64Map a)+splitLookup k t =+  case+    case t of+      Bin p m l r+        | m < 0 ->+          if k >= 0 -- handle negative numbers.+          then mapLT (flip (bin p m) r) (go k l)+          else mapGT (bin p m l) (go k r)+      _ -> go k t+  of SplitLookup lt fnd gt -> (lt, fnd, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m =+          if k' > p+          then SplitLookup t' Nothing Nil+          else SplitLookup Nil Nothing t'+      | zero k' m = mapGT (flip (bin p m) r) (go k' l)+      | otherwise = mapLT (bin p m l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = SplitLookup t'  Nothing  Nil+      | k' < ky   = SplitLookup Nil Nothing  t'+      | otherwise = SplitLookup Nil (Just y) Nil+    go _ Nil      = SplitLookup Nil Nothing  Nil++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Word64Map a -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Word64Map a -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Word64Map b -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Word64Map b -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> Word64Map a -> m+foldMapWithKey f = go+  where+    go Nil           = mempty+    go (Tip kx x)    = f kx x+    go (Bin _ m l r)+      | m < 0     = go r `mappend` go l+      | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Word64Map a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: Word64Map a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Word64Map a -> [(Key,a)]+assocs = toAscList++-- | \(O(n \min(n,W))\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Word64Set.fromList [3,5]+-- > keysSet empty == Data.Word64Set.empty++keysSet :: Word64Map a -> Word64Set.Word64Set+keysSet Nil = Word64Set.Nil+keysSet (Tip kx _) = Word64Set.singleton kx+keysSet (Bin p m l r)+  | m .&. Word64Set.suffixBitMask == 0 = Word64Set.Bin p m (keysSet l) (keysSet r)+  | otherwise = Word64Set.Tip (p .&. Word64Set.prefixBitMask) (computeBm (computeBm 0 l) r)+  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'+        computeBm acc (Tip kx _) = acc .|. Word64Set.bitmapOf kx+        computeBm _   Nil = error "Data.Word64Set.keysSet: Nil"++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Word64Set.empty == empty++fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a+fromSet _ Word64Set.Nil = Nil+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)+  where+    -- This is slightly complicated, as we to convert the dense+    -- representation of Word64Set into tree representation of Word64Map.+    --+    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+    -- prefix 'prefix'. We split bmask into halves corresponding+    -- to left and right subtree. If they are both nonempty, we+    -- create a Bin node, otherwise exactly one of them is nonempty+    -- and we construct the Word64Map from that half.+    buildTree g !prefix !bmask bits = case bits of+      0 -> Tip prefix (g prefix)+      _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+        bits2+          | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+              buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2+          | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+              buildTree g prefix bmask bits2+          | otherwise ->+              Bin prefix bits2+                (buildTree g prefix bmask bits2)+                (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++-- | @since 0.5.6.2+instance GHCExts.IsList (Word64Map a) where+  type Item (Word64Map a) = (Key,a)+  fromList = fromList+  toList   = toList++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Word64Map a -> [(Key,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Word64Map a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Word64Map a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Word64Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Word64Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Word64Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Word64Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Word64Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> Word64Map a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> Word64Map a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> Word64Map a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(Word64Map a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq a => Eq (Word64Map a) where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Eq a => Word64Map a -> Word64Map a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal _   _   = False++nequal :: Eq a => Word64Map a -> Word64Map a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal _   _   = True++-- | @since 0.5.9+instance Eq1 Word64Map where+  liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+    = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)+  liftEq eq (Tip kx x) (Tip ky y)+    = (kx == ky) && (eq x y)+  liftEq _eq Nil Nil = True+  liftEq _eq _   _   = False++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (Word64Map a) where+    compare m1 m2 = compare (toList m1) (toList m2)++-- | @since 0.5.9+instance Ord1 Word64Map where+  liftCompare cmp m n =+    liftCompare (liftCompare cmp) (toList m) (toList n)++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}++instance Functor Word64Map where+    fmap = map++    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)+    a <$ Tip k _     = Tip k a+    _ <$ Nil         = Nil++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show a => Show (Word64Map a) where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++-- | @since 0.5.9+instance Show1 Word64Map where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read e) => Read (Word64Map e) where+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault++-- | @since 0.5.9+instance Read1 Word64Map where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: Prefix -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> Word64Map a -> Word64Map a -> Word64Map a+linkWithMask m p1 t1 {-p2-} t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    p = mask p1 m+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+binCheckLeft _ _ Nil r = r+binCheckLeft p m l r   = Bin p m l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+binCheckRight _ _ l Nil = l+binCheckRight p m l r   = Bin p m l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}++-- | Should this key follow the left subtree of a 'Bin' with switching+-- bit @m@? N.B., the answer is only valid when @match i p m@ is true.+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Key -> Prefix -> Mask -> Bool++-- | Does the key @i@ differ from the prefix @p@ before getting to+-- the switching bit @m@?+nomatch i p m+  = (mask i m) /= p+{-# INLINE nomatch #-}++-- | Does the key @i@ match the prefix @p@ (up to but not including+-- bit @m@)?+match i p m+  = (mask i m) == p+{-# INLINE match #-}+++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}+++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. ((-m) `xor` m))+{-# INLINE maskW #-}++-- | Does the left switching bit specify a shorter prefix?+shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++-- | The first switching bit where the two prefixes disagree.+branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+splitRoot :: Word64Map a -> [Word64Map a]+splitRoot orig =+  case orig of+    Nil -> []+    x@(Tip _ _) -> [x]+    Bin _ m l r | m < 0 -> [r, l]+                | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}++-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => Word64Map a -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> Word64Map a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Word64Map a -> ShowS+showsTree wide lbars rbars t = case t of+  Bin p m l r ->+    showsTree wide (withBar rbars) (withEmpty rbars) r .+    showWide wide rbars .+    showsBars lbars . showString (showBin p m) . showString "\n" .+    showWide wide lbars .+    showsTree wide (withEmpty lbars) (withBar lbars) l+  Tip k x ->+    showsBars lbars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> Word64Map a -> ShowS+showsTreeHang wide bars t = case t of+  Bin p m l r ->+    showsBars bars . showString (showBin p m) . showString "\n" .+    showWide wide bars .+    showsTreeHang wide (withBar bars) l .+    showWide wide bars .+    showsTreeHang wide (withEmpty bars) r+  Tip k x ->+    showsBars bars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars
+ GHC/Data/Word64Map/Lazy.hs view
@@ -0,0 +1,227 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Lazy+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Word64 Maps (lazy interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Word64@ to values of type @v@.+--+-- The functions in "Data.Word64Map.Strict" are careful to force values before+-- installing them in an 'Word64Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Lazy (Word64Map)+-- > import qualified Data.Word64Map.Lazy as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Word64' (64).+--+-- Benchmarks comparing "Data.Word64Map.Lazy" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++module GHC.Data.Word64Map.Lazy (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , WM.lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , WM.null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , WM.map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , WM.foldr+    , WM.foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++    -- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , WM.filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Data.Word64Map.Internal as WM
+ GHC/Data/Word64Map/Strict.hs view
@@ -0,0 +1,245 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Strict+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Word64 Maps (strict interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Word64@ to values of type @v@.+--+-- Each function in this module is careful to force values before installing+-- them in an 'Word64Map'. This is usually more efficient when laziness is not+-- necessary. When laziness /is/ required, use the functions in+-- "Data.Word64Map.Lazy".+--+-- In particular, the functions in this module obey the following law:+--+--  - If all values stored in all maps in the arguments are in WHNF, then all+--    values stored in all maps in the results will be in WHNF once those maps+--    are evaluated.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Strict (Word64Map)+-- > import qualified Data.Word64Map.Strict as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Word64' (64).+--+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Warning+--+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that+-- the same 'Word64Map' value can be passed to functions in both modules. This+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the+-- resulting map may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Word64Map.Internal.++module GHC.Data.Word64Map.Strict (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Data.Word64Map.Strict.Internal
+ GHC/Data/Word64Map/Strict/Internal.hs view
@@ -0,0 +1,1195 @@++{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Strict.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Int Maps (strict interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Int@ to values of type @v@.+--+-- Each function in this module is careful to force values before installing+-- them in an 'Word64Map'. This is usually more efficient when laziness is not+-- necessary. When laziness /is/ required, use the functions in+-- "Data.Word64Map.Lazy".+--+-- In particular, the functions in this module obey the following law:+--+--  - If all values stored in all maps in the arguments are in WHNF, then all+--    values stored in all maps in the results will be in WHNF once those maps+--    are evaluated.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Strict (Word64Map)+-- > import qualified Data.Word64Map.Strict as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Int' (32 or 64).+--+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Warning+--+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that+-- the same 'Word64Map' value can be passed to functions in both modules. This+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the+-- resulting map may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Word64Map.Internal.++module GHC.Data.Word64Map.Strict.Internal (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Prelude.Basic hiding+  (lookup, filter, foldr, foldl, foldl', null, map)++import qualified GHC.Data.Word64Map.Internal as L+import GHC.Data.Word64Map.Internal+  ( Word64Map (..)+  , Key+  , mask+  , branchMask+  , nomatch+  , zero+  , natFromInt+  , intFromNat+  , bin+  , binCheckLeft+  , binCheckRight+  , link+  , linkWithMask++  , (\\)+  , (!)+  , (!?)+  , empty+  , assocs+  , filter+  , filterWithKey+  , findMin+  , findMax+  , foldMapWithKey+  , foldr+  , foldl+  , foldr'+  , foldl'+  , foldlWithKey+  , foldrWithKey+  , foldlWithKey'+  , foldrWithKey'+  , keysSet+  , mergeWithKey'+  , compose+  , delete+  , deleteMin+  , deleteMax+  , deleteFindMax+  , deleteFindMin+  , difference+  , elems+  , intersection+  , disjoint+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , lookup+  , lookupLE+  , lookupGE+  , lookupLT+  , lookupGT+  , lookupMin+  , lookupMax+  , minView+  , maxView+  , minViewWithKey+  , maxViewWithKey+  , keys+  , mapKeys+  , mapKeysMonotonic+  , member+  , notMember+  , null+  , partition+  , partitionWithKey+  , takeWhileAntitone+  , dropWhileAntitone+  , spanAntitone+  , restrictKeys+  , size+  , split+  , splitLookup+  , splitRoot+  , toAscList+  , toDescList+  , toList+  , union+  , unions+  , withoutKeys+  )+import qualified GHC.Data.Word64Set.Internal as Word64Set+import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair+import qualified Data.Foldable as Foldable++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Word64Map.Internal.Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> Word64Map a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> Word64Map a+singleton k !x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> Word64Map a -> Word64Map a+insert !k !x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (Tip k x) p t+      | zero k m      -> Bin p m (insert k x l) r+      | otherwise     -> Bin p m l (insert k x r)+    Tip ky _+      | k==ky         -> Tip k x+      | otherwise     -> link k (Tip k x) ky t+    Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"++insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- If the key exists in the map, this function is lazy in @value@ but strict+-- in the result of @f@.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWithKey f !k x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (singleton k x) p t+      | zero k m      -> Bin p m (insertWithKey f k x l) r+      | otherwise     -> Bin p m l (insertWithKey f k x r)+    Tip ky y+      | k==ky         -> Tip k $! f k x y+      | otherwise     -> link k (singleton k x) ky t+    Nil -> singleton k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)+insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0+  where+    go f k x t =+      case t of+        Bin p m l r+          | nomatch k p m -> Nothing :*: link k (singleton k x) p t+          | zero k m      -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)+          | otherwise     -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')+        Tip ky y+          | k==ky         -> (Just y :*: (Tip k $! f k x y))+          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)+        Nil -> Nothing :*: (singleton k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a+adjustWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> Bin p m (adjustWithKey f k l) r+      | otherwise     -> Bin p m l (adjustWithKey f k r)+    Tip ky y+      | k==ky         -> Tip ky $! f k y+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+updateWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> binCheckLeft p m (updateWithKey f k l) r+      | otherwise     -> binCheckRight p m l (updateWithKey f k r)+    Tip ky y+      | k==ky         -> case f k y of+                           Just !y' -> Tip ky y'+                           Nothing -> Nil+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)+updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0+  where+    go f k t =+      case t of+        Bin p m l r+          | nomatch k p m -> (Nothing :*: t)+          | zero k m      -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)+          | otherwise     -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')+        Tip ky y+          | k==ky         -> case f k y of+                               Just !y' -> (Just y :*: Tip ky y')+                               Nothing  -> (Just y :*: Nil)+          | otherwise     -> (Nothing :*: t)+        Nil -> (Nothing :*: Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+alter f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> case f Nothing of+                           Nothing -> t+                           Just !x  -> link k (Tip k x) p t+      | zero k m      -> binCheckLeft p m (alter f k l) r+      | otherwise     -> binCheckRight p m l (alter f k r)+    Tip ky y+      | k==ky         -> case f (Just y) of+                           Just !x -> Tip ky x+                           Nothing -> Nil+      | otherwise     -> case f Nothing of+                           Just !x -> link k (Tip k x) ky t+                           Nothing -> t+    Nil               -> case f Nothing of+                           Just !x -> Tip k x+                           Nothing -> Nil++-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.++-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- 'Control.Lens.At'.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)+-- This implementation was modified from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just !v' -> insert k v' m+  where mv = lookup k m+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(n+m)\). The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | \(O(n+m)\). Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Word64Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily.  Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+             -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil+                                                                  Just !x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMin f = updateMinWithKey (const f)+++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Word64Map a -> Word64Map b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k $! f x+    go Nil           = Nil++{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs+ #-}++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k $! f k x+      Nil         -> Nil++-- Pay close attention to strictness here. We need to force the+-- intermediate result for map f . map g, and we need to refrain+-- from forcing it for map f . L.map g, etc.+--+-- TODO Consider moving map and mapWithKey to Word64Map.Internal so we can write+-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function+-- for this, and we'd have to pay attention to simplifier phases. Something like+--+-- lsmap :: (b -> c) -> (a -> b) -> Word64Map a -> Word64Map c+-- lsmap _ _ Nil = Nil+-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)+-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = (\ !v' -> Tip k v') <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k $!) <$> f k x+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.  Strict in+-- the accumulating argument and the both elements of the+-- result of the function.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+                let (a1 :*: r') = go f a r+                    (a2 :*: l') = go f a1 l+                in (a2 :*: Bin p m l' r')+            | otherwise ->+                let (a1 :*: l') = go f a l+                    (a2 :*: r') = go f a1 r+                in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+              let (a1 :*: l') = go f a l+                  (a2 :*: r') = go f a1 r+              in (a2 :*: Bin p m l' r')+            | otherwise ->+              let (a1 :*: r') = go f a r+                  (a2 :*: l') = go f a1 l+              in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | \(O(n \log n)\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just !y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r)+      = bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left !y  -> (Tip k y :*: Nil)+      Right !z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++{--------------------------------------------------------------------+  Conversions+--------------------------------------------------------------------}++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Word64Set.empty == empty++fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a+fromSet _ Word64Set.Nil = Nil+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)+  where -- This is slightly complicated, as we to convert the dense+        -- representation of Word64Set into tree representation of Word64Map.+        --+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.+        -- We split bmask into halves corresponding to left and right subtree.+        -- If they are both nonempty, we create a Bin node, otherwise exactly+        -- one of them is nonempty and we construct the Word64Map from that half.+        buildTree g !prefix !bmask bits = case bits of+          0 -> Tip prefix $! g prefix+          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+                 bits2 | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+                           buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2+                       | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+                           buildTree g prefix bmask bits2+                       | otherwise ->+                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> Word64Map a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> Word64Map a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> Word64Map a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx $! vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx $! vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx $! vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(Word64Map a) ![(Key,a)]++data Distinct = Distinct | Nondistinct
+ GHC/Data/Word64Set.hs view
@@ -0,0 +1,160 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Set+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Int Sets+--+-- The @'Word64Set'@ type represents a set of elements of type @Int@.+--+-- For a walkthrough of the most commonly used functions see their+-- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Set (Word64Set)+-- >  import qualified Data.Word64Set as Word64Set+--+--+-- == Performance information+--+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'+-- (32 or 64).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+-----------------------------------------------------------------------------++module GHC.Data.Word64Set (+            -- * Strictness properties+            -- $strictness++            -- * Set type+              Word64Set          -- instance Eq,Show+            , Key++            -- * Construction+            , empty+            , singleton+            , fromList+            , fromAscList+            , fromDistinctAscList++            -- * Insertion+            , insert++            -- * Deletion+            , delete++            -- * Generalized insertion/deletion+            , alterF++            -- * Query+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , WS.null+            , size+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Combine+            , union+            , unions+            , difference+            , (\\)+            , intersection++            -- * Filter+            , WS.filter+            , partition++            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone++            , split+            , splitMember+            , splitRoot++            -- * Map+            , WS.map+            , mapMonotonic++            -- * Folds+            , WS.foldr+            , WS.foldl+            -- ** Strict folds+            , foldr'+            , foldl'+            -- ** Legacy folds+            , fold++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , toAscList+            , toDescList++            -- * Debugging+            , showTree+            , showTreeWith++            ) where++import GHC.Data.Word64Set.Internal as WS++-- $strictness+--+-- This module satisfies the following strictness property:+--+-- * Key arguments are evaluated to WHNF+--+-- Here are some examples that illustrate the property:+--+-- > delete undefined s  ==  undefined
+ GHC/Data/Word64Set/Internal.hs view
@@ -0,0 +1,1613 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Set.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- An efficient implementation of integer sets.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Set (Word64Set)+-- >  import qualified Data.Word64Set as Word64Set+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduce memory footprint and execution times for dense sets, e.g. sets where+-- it is likely that many values lie close to each other. The asymptotics are+-- not affected by this optimization.+--+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'+-- (32 or 64).+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Word64Set matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module GHC.Data.Word64Set.Internal (+    -- * Set type+      Word64Set(..), Key -- instance Eq,Show+    , Prefix, Mask, BitMap++    -- * Operators+    , (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , isSubsetOf+    , isProperSubsetOf+    , disjoint++    -- * Construction+    , empty+    , singleton+    , insert+    , delete+    , alterF++    -- * Combine+    , union+    , unions+    , difference+    , intersection++    -- * Filter+    , filter+    , partition++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , split+    , splitMember+    , splitRoot++    -- * Map+    , map+    , mapMonotonic++    -- * Folds+    , foldr+    , foldl+    -- ** Strict folds+    , foldr'+    , foldl'+    -- ** Legacy folds+    , fold++    -- * Min\/Max+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , maxView+    , minView++    -- * Conversion++    -- ** List+    , elems+    , toList+    , fromList++    -- ** Ordered list+    , toAscList+    , toDescList+    , fromAscList+    , fromDistinctAscList++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internals+    , match+    , suffixBitMask+    , prefixBitMask+    , bitmapOf+    , zero+    ) where++import Control.Applicative (Const(..))+import Control.DeepSeq (NFData(rnf))+import Data.Bits+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup(stimes, (<>)), stimesIdempotentMonoid)+import GHC.Prelude.Basic hiding+  (filter, foldr, foldl, foldl', null, map)+import Data.Word ( Word64 )++import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair++import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data+import Text.Read++import qualified GHC.Exts++import Data.Functor.Identity (Identity(..))++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a 64 bit machine word+type Nat = Word64++natFromInt :: Word64 -> Nat+natFromInt = id+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Word64+intFromNat = id+{-# INLINE intFromNat #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+-- | \(O(n+m)\). See 'difference'.+(\\) :: Word64Set -> Word64Set -> Word64Set+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | A set of integers.++-- See Note: Order of constructors+data Word64Set = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !Word64Set !Word64Set+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2.  It is the largest bit position at which+--            two elements of the set differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+--            the left of the Mask bit.+-- Invariant: In Bin prefix mask left right, left consists of the elements that+--            don't have the mask bit set; right is all the elements that do.+            | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap+-- Invariant: The Prefix is zero for the last 6 bits. The values of the set+--            represented by a tip are the prefix plus the indices of the set+--            bits in the bit map.+            | Nil++-- A number stored in a set is stored as+-- * Prefix (all but last 6 bits) and+-- * BitMap (last 6 bits stored as a bitmask)+--   Last 6 bits are called a Suffix.++type Prefix = Word64+type Mask   = Word64+type BitMap = Word64+type Key    = Word64++instance Monoid Word64Set where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @since 0.5.7+instance Semigroup Word64Set where+    (<>)    = union+    stimes  = stimesIdempotentMonoid+++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data Word64Set where+  gfoldl f z is = z fromList `f` (toList is)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intSetDataType++fromListConstr :: Constr+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix++intSetDataType :: DataType+intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr]+++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the set empty?+null :: Word64Set -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Cardinality of the set.+size :: Word64Set -> Int+size = go 0+  where+    go !acc (Bin _ _ l r) = go (go acc l) r+    go acc (Tip _ bm) = acc + bitcount 0 bm+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the value a member of the set?++-- See Note: Local 'go' functions and capturing.+member :: Key -> Word64Set -> Bool+member !x = go+  where+    go (Bin p m l r)+      | nomatch x p m = False+      | zero x m      = go l+      | otherwise     = go r+    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0+    go Nil = False++-- | \(O(\min(n,W))\). Is the element not in the set?+notMember :: Key -> Word64Set -> Bool+notMember k = not . member k++-- | \(O(\min(n,W))\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> Word64Set -> Maybe Key+lookupLT !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r+                         | zero x m  = go def l+                         | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT+                       | otherwise = unsafeFindMax def+                       where maskLT = (bitmapOf x - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> Word64Set -> Maybe Key+lookupGT !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def+                         | zero x m  = go r l+                         | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT+                       | otherwise = unsafeFindMin def+                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm+    go def Nil = unsafeFindMin def+++-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> Word64Set -> Maybe Key+lookupLE !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r+                         | zero x m  = go def l+                         | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE+                       | otherwise = unsafeFindMax def+                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> Word64Set -> Maybe Key+lookupGE !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def+                         | zero x m  = go r l+                         | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE+                       | otherwise = unsafeFindMin def+                       where maskGE = (- (bitmapOf x)) .&. bm+    go def Nil = unsafeFindMin def++++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: Word64Set -> Maybe Key+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: Word64Set -> Maybe Key+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty :: Word64Set+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A set of one element.+singleton :: Key -> Word64Set+singleton x+  = Tip (prefixOf x) (bitmapOf x)+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for+-- Word64Sets.+insert :: Key -> Word64Set -> Word64Set+insert !x = insertBM (prefixOf x) (bitmapOf x)++-- Helper function for insert and union.+insertBM :: Prefix -> BitMap -> Word64Set -> Word64Set+insertBM !kx !bm t@(Bin p m l r)+  | nomatch kx p m = link kx (Tip kx bm) p t+  | zero kx m      = Bin p m (insertBM kx bm l) r+  | otherwise      = Bin p m l (insertBM kx bm r)+insertBM kx bm t@(Tip kx' bm')+  | kx' == kx = Tip kx' (bm .|. bm')+  | otherwise = link kx (Tip kx bm) kx' t+insertBM kx bm Nil = Tip kx bm++-- | \(O(\min(n,W))\). Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> Word64Set -> Word64Set+delete !x = deleteBM (prefixOf x) (bitmapOf x)++-- Deletes all values mentioned in the BitMap from the set.+-- Helper function for delete and difference.+deleteBM :: Prefix -> BitMap -> Word64Set -> Word64Set+deleteBM !kx !bm t@(Bin p m l r)+  | nomatch kx p m = t+  | zero kx m      = bin p m (deleteBM kx bm l) r+  | otherwise      = bin p m l (deleteBM kx bm r)+deleteBM kx bm t@(Tip kx' bm')+  | kx' == kx = tip kx (bm' .&. complement bm)+  | otherwise = t+deleteBM _ _ Nil = Nil++-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> Word64Set -> f Word64Set+alterF f k s = fmap choose (f member_)+  where+    member_ = member k s++    (inserted, deleted)+      | member_   = (s         , delete k s)+      | otherwise = (insert k s, s         )++    choose True  = inserted+    choose False = deleted+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}++{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-}++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.++{-# INLINABLE unions #-}+unions :: [Word64Set] -> Word64Set+unions = List.foldl' union empty++-- | \(O(n+m)\). The union of two sets.+union :: Word64Set -> Word64Set -> Word64Set+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = link p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = link p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = link p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t+union t@(Bin _ _ _ _) Nil = t+union (Tip kx bm) t = insertBM kx bm t+union Nil t = t+++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(n+m)\). Difference between two sets.+difference :: Word64Set -> Word64Set -> Word64Set+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+                | otherwise         = bin p1 m1 l1 (difference r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = difference t1 l2+                | otherwise         = difference t1 r2++difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t+difference t@(Bin _ _ _ _) Nil = t++difference t1@(Tip kx bm) t2 = differenceTip t2+  where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1+                                        | zero kx m2 = differenceTip l2+                                        | otherwise = differenceTip r2+        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)+                                    | otherwise = t1+        differenceTip Nil = t1++difference Nil _     = Nil++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(n+m)\). The intersection of two sets.+intersection :: Word64Set -> Word64Set -> Word64Set+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersection l1 t2+                  | otherwise         = intersection r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersection t1 l2+                  | otherwise         = intersection t1 r2++intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1+  where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil+                                      | zero kx2 m1       = intersectBM l1+                                      | otherwise         = intersectBM r1+        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection (Bin _ _ _ _) Nil = Nil++intersection (Tip kx1 bm1) t2 = intersectBM t2+  where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil+                                      | zero kx1 m2       = intersectBM l2+                                      | otherwise         = intersectBM r2+        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection Nil _ = Nil++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(O(n+m)\). Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: Word64Set -> Word64Set -> Bool+isProperSubsetOf t1 t2+  = case subsetCmp t1 t2 of+      LT -> True+      _  -> False++subsetCmp :: Word64Set -> Word64Set -> Ordering+subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = case subsetCmpLt of+                       GT -> GT+                       _  -> LT+  | p1 == p2       = subsetCmpEq+  | otherwise      = GT  -- disjoint+  where+    subsetCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = subsetCmp t1 l2+                | otherwise         = subsetCmp t1 r2+    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++subsetCmp (Bin _ _ _ _) _  = GT+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)+  | kx1 /= kx2                  = GT -- disjoint+  | bm1 == bm2                  = EQ+  | bm1 .&. complement bm2 == 0 = LT+  | otherwise                   = GT+subsetCmp t1@(Tip kx _) (Bin p m l r)+  | nomatch kx p m = GT+  | zero kx m      = case subsetCmp t1 l of GT -> GT ; _ -> LT+  | otherwise      = case subsetCmp t1 r of GT -> GT ; _ -> LT+subsetCmp (Tip _ _) Nil = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _   = LT++-- | \(O(n+m)\). Is this a subset?+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: Word64Set -> Word64Set -> Bool+isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2+                                                      else isSubsetOf t1 r2)+  | otherwise      = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2+isSubsetOf (Bin _ _ _ _) _  = False+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0+isSubsetOf t1@(Tip kx _) (Bin p m l r)+  | nomatch kx p m = False+  | zero kx m      = isSubsetOf t1 l+  | otherwise      = isSubsetOf t1 r+isSubsetOf (Tip _ _) Nil = False+isSubsetOf Nil _         = True+++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(n+m)\). Check whether two sets are disjoint (i.e. their intersection+--   is empty).+--+-- > disjoint (fromList [2,4,6])   (fromList [1,3])     == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False+-- > disjoint (fromList [])        (fromList [])        == True+--+-- @since 0.5.11+disjoint :: Word64Set -> Word64Set -> Bool+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = disjoint1+  | shorter m2 m1  = disjoint2+  | p1 == p2       = disjoint l1 l2 && disjoint r1 r2+  | otherwise      = True+  where+    disjoint1 | nomatch p2 p1 m1  = True+              | zero p2 m1        = disjoint l1 t2+              | otherwise         = disjoint r1 t2++    disjoint2 | nomatch p1 p2 m2  = True+              | zero p1 m2        = disjoint t1 l2+              | otherwise         = disjoint t1 r2++disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1+  where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True+                                     | zero kx2 m1       = disjointBM l1+                                     | otherwise         = disjointBM r1+        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint (Bin _ _ _ _) Nil = True++disjoint (Tip kx1 bm1) t2 = disjointBM t2+  where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True+                                     | zero kx1 m2       = disjointBM l2+                                     | otherwise         = disjointBM r2+        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint Nil _ = True+++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> Word64Set -> Word64Set+filter predicate t+  = case t of+      Bin p m l r+        -> bin p m (filter predicate l) (filter predicate r)+      Tip kx bm+        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)+      Nil -> Nil+  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                         | otherwise           = bm+        {-# INLINE bitPred #-}++-- | \(O(n)\). partition the set according to some predicate.+partition :: (Key -> Bool) -> Word64Set -> (Word64Set,Word64Set)+partition predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t+      = case t of+          Bin p m l r+            -> let (l1 :*: l2) = go predicate l+                   (r1 :*: r2) = go predicate r+               in bin p m l1 r1 :*: bin p m l2 r2+          Tip kx bm+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)+          Nil -> (Nil :*: Nil)+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                             | otherwise           = bm+            {-# INLINE bitPred #-}++-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set+takeWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then bin p m (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = bin p m l (go predicate' r)+      | otherwise         = go predicate' l+    go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set+dropWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p m l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = go predicate' r+      | otherwise         = bin p m (go predicate' l) r+    go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partition' p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> Word64Set -> (Word64Set, Word64Set)+spanAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt+      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r+    go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm+                                in (tip kx bm' :*: tip kx (bm `xor` bm'))+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> Word64Set -> (Word64Set,Word64Set)+split x t =+  case t of+    Bin p m l r+      | m < 0 ->+        if x >= 0  -- handle negative numbers.+        then+          case go x l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go x r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go x t of+          (lt :*: gt) -> (lt, gt)+  where+    go !x' t'@(Bin p m l r)+        | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil)+        | zero x' m      = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r+        | otherwise      = case go x' r of (lt :*: gt) -> bin p m l lt :*: gt+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil :*: t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t' :*: Nil)+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+            where lowerBitmap = bitmapOf x' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOf x')+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> Word64Set -> (Word64Set,Bool,Word64Set)+splitMember x t =+  case t of+    Bin p m l r+      | m < 0 ->+        if x >= 0 -- handle negative numbers.+        then+          case go x l of+            (lt, fnd, gt) ->+              let !lt' = bin p m lt r+              in (lt', fnd, gt)+        else+          case go x r of+            (lt, fnd, gt) ->+              let !gt' = bin p m l gt+              in (lt, fnd, gt')+    _ -> go x t+  where+    go x' t'@(Bin p m l r)+        | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil)+        | zero x' m =+          case go x' l of+            (lt, fnd, gt) ->+              let !gt' = bin p m gt r+              in (lt, fnd, gt')+        | otherwise =+          case go x' r of+            (lt, fnd, gt) ->+              let !lt' = bin p m l lt+              in (lt', fnd, gt)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil, False, t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t', False, Nil)+        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+                          !found = (bm .&. bitmapOfx') /= 0+                          !gt = tip kx' (bm .&. higherBitmap)+                      in (lt, found, gt)+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')+    go _ Nil = (Nil, False, Nil)++{----------------------------------------------------------------------+  Min/Max+----------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: Word64Set -> Maybe (Key, Word64Set)+maxView t =+  case t of Nil -> Nothing+            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)+            _ -> Just (go t)+  where+    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')+    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "maxView Nil"++-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: Word64Set -> Maybe (Key, Word64Set)+minView t =+  case t of Nil -> Nothing+            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')+            _ -> Just (go t)+  where+    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)+    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "minView Nil"++-- | \(O(\min(n,W))\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: Word64Set -> (Key, Word64Set)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | \(O(\min(n,W))\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: Word64Set -> (Key, Word64Set)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView+++-- | \(O(\min(n,W))\). The minimal element of the set.+findMin :: Word64Set -> Key+findMin Nil = error "findMin: empty set has no minimal element"+findMin (Tip kx bm) = kx + lowestBitSet bm+findMin (Bin _ m l r)+  |   m < 0   = find r+  | otherwise = find l+    where find (Tip kx bm) = kx + lowestBitSet bm+          find (Bin _ _ l' _) = find l'+          find Nil            = error "findMin Nil"++-- | \(O(\min(n,W))\). The maximal element of a set.+findMax :: Word64Set -> Key+findMax Nil = error "findMax: empty set has no maximal element"+findMax (Tip kx bm) = kx + highestBitSet bm+findMax (Bin _ m l r)+  |   m < 0   = find l+  | otherwise = find r+    where find (Tip kx bm) = kx + highestBitSet bm+          find (Bin _ _ _ r') = find r'+          find Nil            = error "findMax Nil"+++-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.+deleteMin :: Word64Set -> Word64Set+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.+deleteMax :: Word64Set -> Word64Set+deleteMax = maybe Nil snd . maxView++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | \(O(n \min(n,W))\).+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (Key -> Key) -> Word64Set -> Word64Set+map f = fromList . List.map f . toList++-- | \(O(n)\). The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> Word64Set -> Word64Set+mapMonotonic f = fromDistinctAscList . List.map f . toAscList+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator. This function is an equivalent of 'foldr' and is present+-- for compatibility only.+--+-- /Please note that fold will be deprecated in the future and removed./+fold :: (Key -> b -> b) -> b -> Word64Set -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (Key -> b -> b) -> b -> Word64Set -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before+                        | otherwise -> go (go z r) l+            _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx bm)   = foldrBits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (Key -> b -> b) -> b -> Word64Set -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before+                        | otherwise -> go (go z r) l+            _ -> go z t+  where+    go !z' Nil           = z'+    go z' (Tip kx bm)   = foldr'Bits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> Key -> a) -> a -> Word64Set -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before+                        | otherwise -> go (go z l) r+            _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx bm)   = foldlBits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> Key -> a) -> a -> Word64Set -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before+                        | otherwise -> go (go z l) r+            _ -> go z t+  where+    go !z' Nil           = z'+    go z' (Tip kx bm)   = foldl'Bits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: Word64Set -> [Key]+elems+  = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++-- | @since 0.5.6.2+instance GHC.Exts.IsList Word64Set where+  type Item Word64Set = Key+  fromList = fromList+  toList   = toList++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: Word64Set -> [Key]+toList+  = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list+-- fusion.+toAscList :: Word64Set -> [Key]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: Word64Set -> [Key]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> a) -> a -> Word64Set -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Word64Set.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}+{-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+++-- | \(O(n \min(n,W))\). Create a set from a list of integers.+{-# INLINABLE fromList #-}+fromList :: [Key] -> Word64Set+fromList = List.foldl' ins empty+  where+    ins t x  = insert x t++-- | \(O(n)\). Build a set from an ascending list of elements.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: [Key] -> Word64Set+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+-- /The precondition (input list is strictly ascending) is not checked./+fromDistinctAscList :: [Key] -> Word64Set+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a set from a monotonic list of elements.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+fromMonoList :: [Key] -> Word64Set+fromMonoList []         = Nil+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1+  where+    -- `addAll'` collects all keys with the prefix `px` into a single+    -- bitmap, and then proceeds with `addAll`.+    addAll' !px !bm []+        = Tip px bm+    addAll' !px !bm (ky : zs)+        | px == prefixOf ky+        = addAll' px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs'++    -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_px !tx []+        = tx+    addAll !px !tx (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty {-px-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !px !bm []+        = Inserted (Tip px bm) []+    addMany' !m !px !bm zs0@(ky : zs)+        | px == prefixOf ky+        = addMany' m px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)+        | mask px m /= mask ky m+        = Inserted (Tip (prefixOf px) bm) zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.+    addMany !_m !_px tx []+        = Inserted tx []+    addMany !m !px tx zs0@(ky : zs)+        | mask px m /= mask ky m+        = Inserted tx zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty {-px-} tx) zs'+{-# INLINE fromMonoList #-}++data Inserted = Inserted !Word64Set ![Key]++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq Word64Set where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Word64Set -> Word64Set -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 == kx2 && bm1 == bm2+equal Nil Nil = True+equal _   _   = False++nequal :: Word64Set -> Word64Set -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 /= kx2 || bm1 /= bm2+nequal Nil Nil = False+nequal _   _   = True++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord Word64Set where+    compare s1 s2 = compare (toAscList s1) (toAscList s2)+    -- tentative implementation. See if more efficient exists.++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show Word64Set where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance Read Word64Set where+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++-- The Word64Set constructors consist only of strict fields of Ints and+-- Word64Sets, thus the default NFData instance which evaluates to whnf+-- should suffice+instance NFData Word64Set where rnf x = seq x ()++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: Word64Set -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> Word64Set -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> Word64Set -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p m l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p m) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip kx bm+          -> showsBars lbars . showString " " . shows kx . showString " + " .+                                                showsBitMap bm . showString "\n"+      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> Word64Set -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p m l r+          -> showsBars bars . showString (showBin p m) . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip kx bm+          -> showsBars bars . showString " " . shows kx . showString " + " .+                                               showsBitMap bm . showString "\n"+      Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars [] = id+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node++showsBitMap :: Word64 -> ShowS+showsBitMap = showString . showBitMap++showBitMap :: Word64 -> String+showBitMap w = show $ foldrBits 0 (:) [] w++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: Prefix -> Word64Set -> Prefix -> Word64Set -> Word64Set+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> Word64Set -> Word64Set -> Word64Set+linkWithMask m p1 t1 {-p2-} t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    p = mask p1 m+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> Word64Set -> Word64Set -> Word64Set+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+  @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Prefix -> BitMap -> Word64Set+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}+++{----------------------------------------------------------------------+  Functions that generate Prefix and BitMap of a Key or a Suffix.+----------------------------------------------------------------------}++suffixBitMask :: Word64+suffixBitMask = fromIntegral (finiteBitSize (undefined::Word64)) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Word64+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Word64 -> Prefix+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Word64 -> Word64+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Word64 -> BitMap+bitmapOfSuffix s = 1 `shiftLL` fromIntegral s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Word64 -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}+++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+-- Returns True iff the bits set in i and the Mask m are disjoint.+zero :: Word64 -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Word64 -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p+{-# INLINE nomatch #-}++match i p m+  = (mask i m) == p+{-# INLINE match #-}++-- Suppose a is largest such that 2^a divides 2*m.+-- Then mask i m is i with the low a bits zeroed out.+mask :: Word64 -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))+{-# INLINE maskW #-}++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{----------------------------------------------------------------------+  To get best performance, we provide fast implementations of+  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.+  If the intel bsf and bsr instructions ever become GHC primops,+  this code should be reimplemented using these.++  Performance of this code is crucial for folds, toList, filter, partition.++  The signatures of methods in question are placed after this comment.+----------------------------------------------------------------------}++lowestBitSet :: Nat -> Word64+highestBitSet :: Nat -> Word64+foldlBits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a+foldl'Bits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a+foldrBits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a+foldr'Bits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a+takeWhileAntitoneBits :: Word64 -> (Word64 -> Bool) -> Nat -> Nat++{-# INLINE lowestBitSet #-}+{-# INLINE highestBitSet #-}+{-# INLINE foldlBits #-}+{-# INLINE foldl'Bits #-}+{-# INLINE foldrBits #-}+{-# INLINE foldr'Bits #-}+{-# INLINE takeWhileAntitoneBits #-}++indexOfTheOnlyBit :: Nat -> Word64+{-# INLINE indexOfTheOnlyBit #-}+indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask++lowestBitSet x = fromIntegral $ countTrailingZeros x++highestBitSet x = fromIntegral $ 63 - countLeadingZeros x++lowestBitMask :: Nat -> Nat+lowestBitMask x = x .&. negate x+{-# INLINE lowestBitMask #-}++-- Reverse the order of bits in the Nat.+revNat :: Nat -> Nat+revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);++foldlBits prefix f z bitmap = go bitmap z+  where go 0 acc = acc+        go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))+          where+            !bitmask = lowestBitMask bm+            !bi = indexOfTheOnlyBit bitmask++foldl'Bits prefix f z bitmap = go bitmap z+  where go 0 acc = acc+        go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask++foldrBits prefix f z bitmap = go (revNat bitmap) z+  where go 0 acc = acc+        go bm acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask+++foldr'Bits prefix f z bitmap = go (revNat bitmap) z+  where go 0 acc = acc+        go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask++takeWhileAntitoneBits prefix predicate bitmap =+  -- Binary search for the first index where the predicate returns false, but skip a predicate+  -- call if the high half of the current range is empty. This ensures+  -- min (log2 64 + 1 = 7) (popcount bitmap) predicate calls.+  let next d h (n',b') =+        if n' .&. h /= 0 && (predicate $! prefix + fromIntegral (b'+d)) then (n' `shiftRL` d, b'+d) else (n',b')+      {-# INLINE next #-}+      (_,b) = next 1  0x2 $+              next 2  0xC $+              next 4  0xF0 $+              next 8  0xFF00 $+              next 16 0xFFFF0000 $+              next 32 0xFFFFFFFF00000000 $+              (bitmap,0)+      m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)+          then ((2 `shiftLL` b) - 1)+          else ((1 `shiftLL` b) - 1)+  in bitmap .&. m++++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice. Also, the current version does not continue+--  splitting all the way to individual singleton sets -- it stops at some+--  point.+splitRoot :: Word64Set -> [Word64Set]+splitRoot Nil = []+-- NOTE: we don't currently split below Tip, but we could.+splitRoot x@(Tip _ _) = [x]+splitRoot (Bin _ m l r) | m < 0 = [r, l]+                        | otherwise = [l, r]+{-# INLINE splitRoot #-}
+ GHC/Driver/Backend.hs view
@@ -0,0 +1,912 @@+{-# LANGUAGE MultiWayIf, LambdaCase #-}++{-|+Module      : GHC.Driver.Backend+Description : Back ends for code generation++This module exports the `Backend` type and all the available values+of that type.  The type is abstract, and GHC assumes a "closed world":+all the back ends are known and are known here.  The compiler driver+chooses a `Backend` value based on how it is asked to generate code.++A `Backend` value encapsulates the knowledge needed to take Cmm, STG,+or Core and write assembly language to a file.  A back end also+provides a function that enables the compiler driver to run an+assembler on the code that is written, if any (the "post-backend+pipeline").  Finally, a back end has myriad /properties/.  Properties+mediate interactions between a back end and the rest of the compiler,+especially the driver.  Examples include the following:++ * Property `backendValidityOfCImport` says whether the back end can+   import foreign C functions.++ * Property `backendForcesOptimization0` says whether the back end can+   be used with optimization levels higher than `-O0`.++ * Property `backendCDefs` tells the compiler driver, "if you're using+   this back end, then these are the command-line flags you should add+   to any invocation of the C compiler."++These properties are used elsewhere in GHC, primarily in the driver, to+fine-tune operations according to the capabilities of the chosen back+end.  You might use a property to make GHC aware of a potential+limitation of certain back ends, or a special feature available only+in certain back ends.  If your client code needs to know a fact that+is not exposed in an existing property, you would define and export a+new property.  Conditioning client code on the /identity/ or /name/ of+a back end is Not Done.++For full details, see the documentation of each property.+-}++module GHC.Driver.Backend+   ( -- * The @Backend@ type+     Backend  -- note: type is abstract+   -- * Available back ends+   , ncgBackend+   , llvmBackend+   , jsBackend+   , viaCBackend+   , interpreterBackend+   , noBackend+   , allBackends++    -- * Types used to specify properties of back ends+   , PrimitiveImplementation(..)+     -- ** Properties that stand for functions+     -- *** Back-end function for code generation+   , DefunctionalizedCodeOutput(..)+     -- *** Back-end functions for assembly+   , DefunctionalizedPostHscPipeline(..)+     -- *** Other back-end functions+   , DefunctionalizedCDefs(..)+     -- ** Names of back ends (for API clients of version 9.4 or earlier)+   , BackendName++++     -- * Properties of back ends+   , backendDescription+   , backendWritesFiles+   , backendPipelineOutput+   , backendCanReuseLoadedCode+   , backendGeneratesCode+   , backendGeneratesCodeForHsBoot+   , backendSupportsInterfaceWriting+   , backendRespectsSpecialise+   , backendWantsGlobalBindings+   , backendHasNativeSwitch+   , backendPrimitiveImplementation+   , backendSimdValidity+   , backendSupportsEmbeddedBlobs+   , backendNeedsPlatformNcgSupport+   , backendSupportsUnsplitProcPoints+   , backendSwappableWithViaC+   , backendUnregisterisedAbiOnly+   , backendGeneratesHc+   , backendSptIsDynamic+   , backendSupportsBreakpoints+   , backendForcesOptimization0+   , backendNeedsFullWays+   , backendSpecialModuleSource+   , backendSupportsHpc+   , backendSupportsCImport+   , backendSupportsCExport+   , backendCDefs+   , backendCodeOutput+   , backendUseJSLinker+   , backendPostHscPipeline+   , backendNormalSuccessorPhase+   , backendName+   , backendValidityOfCImport+   , backendValidityOfCExport++   -- * Other functions of back ends+   , platformDefaultBackend+   , platformNcgSupported+   )++where+++import GHC.Prelude++import GHC.Driver.Backend.Internal (BackendName(..))+import GHC.Driver.Phases+++import GHC.Utils.Error+import GHC.Utils.Panic++import GHC.Driver.Pipeline.Monad+import GHC.Platform+++---------------------------------------------------------------------------------+--+--   DESIGN CONSIDERATIONS+--+--+--+-- The `Backend` type is made abstract in order to make it possible to+-- add new back ends without having to inspect or modify much code+-- elsewhere in GHC.  Adding a new back end would be /easiest/ if+-- `Backend` were represented as a record type, but in peer review,+-- the clear will of the majority was to use a sum type.  As a result,+-- when adding a new back end it is necessary to modify /every/+-- function in this module that expects `Backend` as its first argument.+-- **By design, these functions have no default/wildcard cases.** This+-- design forces the author of a new back end to consider the semantics+-- in every case, rather than relying on a default that may be wrong.+-- The names and documentation of the functions defined in the `Backend`+-- record are sufficiently descriptive that the author of a new back+-- end will be able to identify correct result values without having to go+-- spelunking throughout the compiler.+--+-- While the design localizes /most/ back-end logic in this module,+-- the author of a new back end will still have to make changes+-- elsewhere in the compiler:+--+--   * For reasons described in Note [Backend Defunctionalization],+--     code-generation and post-backend pipeline functions, among other+--     functions, cannot be placed in the `Backend` record itself.+--     Instead, the /names/ of those functions are placed.  Each name is+--     a value constructor in one of the algebraic data types defined in+--     this module.  The named function is then defined near its point+--     of use.+--+--     The author of a new back end will have to consider whether an+--     existing function will do or whether a new function needs to be+--     defined.  When a new function needs to be defined, the author+--     must take two steps:+--+--       - Add a value constructor to the relevant data type here+--         in the `Backend` module+--+--       - Add a case to the location in the compiler (there should be+--         exactly one) where the value constructors of the relevant+--         data type are used+--+--   * When a new back end is defined, it's quite possible that the+--     compiler driver will have to be changed in some way.  Just because+--     the driver supports five back ends doesn't mean it will support a sixth+--     without changes.+--+-- The collection of functions exported from this module hasn't+-- really been "designed"; it's what emerged from a refactoring of+-- older code.  The real design criterion was "make it crystal clear+-- what has to be done to add a new back end."+--+-- One issue remains unresolved: some of the error messages and+-- warning messages used in the driver assume a "closed world": they+-- think they know all the back ends that exist, and they are not shy+-- about enumerating them.  Just one set of error messages has been+-- ported to have an open-world assumption: these are the error+-- messages associated with type checking of foreign imports and+-- exports.  To allow other errors to be issued with an open-world+-- assumption, use functions `backendValidityOfCImport` and+-- `backendValidityOfCExport` as models, and have a look at how the+-- 'expected back ends' are used in modules "GHC.Tc.Gen.Foreign" and+-- "GHC.Tc.Errors.Ppr"+--+---------------------------------------------------------------------------------+++platformDefaultBackend :: Platform -> Backend+platformDefaultBackend platform = if+      | platformUnregisterised platform -> viaCBackend+      | platformNcgSupported platform   -> ncgBackend+      | platformJSSupported platform    -> jsBackend+      | otherwise                       -> llvmBackend++-- | Is the platform supported by the Native Code Generator?+platformNcgSupported :: Platform -> Bool+platformNcgSupported platform = if+      | platformUnregisterised platform -> False -- NCG doesn't support unregisterised ABI+      | ncgValidArch                    -> True+      | otherwise                       -> False+   where+      ncgValidArch = case platformArch platform of+         ArchX86       -> True+         ArchX86_64    -> True+         ArchPPC       -> True+         ArchPPC_64 {} -> True+         ArchAArch64   -> True+         ArchWasm32    -> True+         ArchRISCV64   -> True+         ArchLoongArch64 -> True+         _             -> False++-- | Is the platform supported by the JS backend?+platformJSSupported :: Platform -> Bool+platformJSSupported platform+  | platformArch platform == ArchJavaScript = True+  | otherwise                               = False+++-- | A value of type @Backend@ represents one of GHC's back ends.+-- The set of back ends cannot be extended except by modifying the+-- definition of @Backend@ in this module.+--+-- The @Backend@ type is abstract; that is, its value constructors are+-- not exported.  It's crucial that they not be exported, because a+-- value of type @Backend@ carries only the back end's /name/, not its+-- behavior or properties.  If @Backend@ were not abstract, then code+-- elsewhere in the compiler could depend directly on the name, not on+-- the semantics, which would make it challenging to create a new back end.+-- Because @Backend@ /is/ abstract, all the obligations of a new back+-- end are enumerated in this module, in the form of functions that+-- take @Backend@ as an argument.+--+-- The issue of abstraction is discussed at great length in #20927 and !7442.+++newtype Backend = Named BackendName+  -- Must be a newtype so that it has no `Eq` instance and+  -- a different `Show` instance.++-- | The Show instance is for messages /only/.  If code depends on+-- what's in the string, you deserve what happens to you.++instance Show Backend where+  show = backendDescription+++ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend+    :: Backend++-- | The native code generator.+-- Compiles Cmm code into textual assembler, then relies on+-- an external assembler toolchain to produce machine code.+--+-- Only supports a few platforms (X86, PowerPC, SPARC).+--+-- See "GHC.CmmToAsm".+ncgBackend = Named NCG++-- | The LLVM backend.+--+-- Compiles Cmm code into LLVM textual IR, then relies on+-- LLVM toolchain to produce machine code.+--+-- It relies on LLVM support for the calling convention used+-- by the NCG backend to produce code objects ABI compatible+-- with it (see "cc 10" or "ghccc" calling convention in+-- https://llvm.org/docs/LangRef.html#calling-conventions).+--+-- Supports a few platforms (X86, AArch64, s390x, ARM).+--+-- See "GHC.CmmToLlvm"+llvmBackend = Named LLVM++-- | The JavaScript Backend+--+-- See documentation in GHC.StgToJS+jsBackend = Named JavaScript++-- | Via-C ("unregisterised") backend.+--+-- Compiles Cmm code into C code, then relies on a C compiler+-- to produce machine code.+--+-- It produces code objects that are /not/ ABI compatible+-- with those produced by NCG and LLVM backends.+--+-- Produced code is expected to be less efficient than the+-- one produced by NCG and LLVM backends because STG+-- registers are not pinned into real registers.  On the+-- other hand, it supports more target platforms (those+-- having a valid C toolchain).+--+-- See "GHC.CmmToC"+viaCBackend = Named ViaC++-- | The ByteCode interpreter.+--+-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that+-- can be interpreted. It is used by GHCi.+--+-- Currently some extensions are not supported+-- (foreign primops).+--+-- See "GHC.StgToByteCode"+interpreterBackend = Named Interpreter++-- | A dummy back end that generates no code.+--+-- Use this back end to disable code generation. It is particularly+-- useful when GHC is used as a library for other purpose than+-- generating code (e.g. to generate documentation with Haddock) or+-- when the user requested it (via `-fno-code`) for some reason.+noBackend = Named NoBackend++---------------------------------------------------------------------------------+++++-- | This enumeration type specifies how the back end wishes GHC's+-- primitives to be implemented.  (Module "GHC.StgToCmm.Prim" provides+-- a generic implementation of every primitive, but some primitives,+-- like `IntQuotRemOp`, can be implemented more efficiently by+-- certain back ends on certain platforms.  For example, by using a+-- machine instruction that simultaneously computes quotient and remainder.)+--+-- For the meaning of each alternative, consult+-- "GHC.StgToCmm.Config".  (In a perfect world, type+-- `PrimitiveImplementation` would be defined there, in the module+-- that determines its meaning.  But I could not figure out how to do+-- it without mutual recursion across module boundaries.)++data PrimitiveImplementation+    = LlvmPrimitives    -- ^ Primitives supported by LLVM+    | NcgPrimitives     -- ^ Primitives supported by the native code generator+    | JSPrimitives      -- ^ Primitives supported by JS backend+    | GenericPrimitives -- ^ Primitives supported by all back ends+  deriving Show+++-- | Names a function that generates code and writes the results to a+--  file, of this type:+--+--  >    Logger+--  > -> DynFlags+--  > -> Module -- ^ module being compiled+--  > -> ModLocation+--  > -> FilePath -- ^ Where to write output+--  > -> Set UnitId -- ^ dependencies+--  > -> Stream IO RawCmmGroup a -- results from `StgToCmm`+--  > -> IO a+--+-- The functions so named are defined in "GHC.Driver.CodeOutput".+--+-- We expect one function per back end—or more precisely, one function+-- for each back end that writes code to a file.  (The interpreter+-- does not write to files; its output lives only in memory.)++data DefunctionalizedCodeOutput+  = NcgCodeOutput+  | ViaCCodeOutput+  | LlvmCodeOutput+  | JSCodeOutput+++-- | Names a function that tells the driver what should happen after+-- assembly code is written.  This might include running a C compiler,+-- running LLVM, running an assembler, or various similar activities.+-- The function named normally has this type:+--+-- >    TPipelineClass TPhase m+-- > => PipeEnv+-- > -> HscEnv+-- > -> Maybe ModLocation+-- > -> FilePath+-- > -> m (Maybe FilePath)+--+-- The functions so named are defined in "GHC.Driver.Pipeline".++data DefunctionalizedPostHscPipeline+  = NcgPostHscPipeline+  | ViaCPostHscPipeline+  | LlvmPostHscPipeline+  | JSPostHscPipeline+  | NoPostHscPipeline -- ^ After code generation, nothing else need happen.++-- | Names a function that tells the driver what command-line options+-- to include when invoking a C compiler.  It's meant for @-D@ options that+-- define symbols for the C preprocessor.  Because the exact symbols+-- defined might depend on versions of tools located in the file+-- system (/cough/ LLVM /cough/), the function requires an `IO` action.+-- The function named has this type:+--+-- > Logger -> DynFlags -> IO [String]++data DefunctionalizedCDefs+  = NoCDefs   -- ^ No additional command-line options are needed++  | LlvmCDefs -- ^ Return command-line options that tell GHC about the+              -- LLVM version.++---------------------------------------------------------------------------------++++-- | An informal description of the back end, for use in+-- issuing warning messages /only/.  If code depends on+-- what's in the string, you deserve what happens to you.+backendDescription :: Backend -> String+backendDescription (Named NCG)         = "native code generator"+backendDescription (Named LLVM)        = "LLVM"+backendDescription (Named ViaC)        = "compiling via C"+backendDescription (Named JavaScript)  = "compiling to JavaScript"+backendDescription (Named Interpreter) = "byte-code interpreter"+backendDescription (Named NoBackend)   = "no code generated"++-- | This flag tells the compiler driver whether the back+-- end will write files: interface files and object files.+-- It is typically true for "real" back ends that generate+-- code into the filesystem.  (That means, not the interpreter.)+backendWritesFiles :: Backend -> Bool+backendWritesFiles (Named NCG)         = True+backendWritesFiles (Named LLVM)        = True+backendWritesFiles (Named ViaC)        = True+backendWritesFiles (Named JavaScript)  = True+backendWritesFiles (Named Interpreter) = False+backendWritesFiles (Named NoBackend)   = False++-- | When the back end does write files, this value tells+-- the compiler in what manner of file the output should go:+-- temporary, persistent, or specific.+backendPipelineOutput :: Backend -> PipelineOutput+backendPipelineOutput (Named NCG)  = Persistent+backendPipelineOutput (Named LLVM) = Persistent+backendPipelineOutput (Named ViaC) = Persistent+backendPipelineOutput (Named JavaScript)  = Persistent+backendPipelineOutput (Named Interpreter) = NoOutputFile+backendPipelineOutput (Named NoBackend)   = NoOutputFile++-- | This flag tells the driver whether the back end can+-- reuse code (bytecode or object code) that has been+-- loaded dynamically.  Likely true only of the interpreter.+backendCanReuseLoadedCode :: Backend -> Bool+backendCanReuseLoadedCode (Named NCG)         = False+backendCanReuseLoadedCode (Named LLVM)        = False+backendCanReuseLoadedCode (Named ViaC)        = False+backendCanReuseLoadedCode (Named JavaScript)  = False+backendCanReuseLoadedCode (Named Interpreter) = True+backendCanReuseLoadedCode (Named NoBackend)   = False++-- | It is is true of every back end except @-fno-code@+-- that it "generates code."  Surprisingly, this property+-- influences the driver in a ton of ways.  Some examples:+--+--   * If the back end does not generate code, then the+--     driver needs to turn on code generation for+--     Template Haskell (because that code needs to be+--     generated and run at compile time).+--+--   * If the back end does not generate code, then the+--     driver does not need to deal with an output file.+--+--   * If the back end /does/ generated code, then the+--     driver supports `HscRecomp`.  If not, recompilation+--     does not need a linkable (and is automatically up+--     to date).+--+backendGeneratesCode :: Backend -> Bool+backendGeneratesCode (Named NCG)         = True+backendGeneratesCode (Named LLVM)        = True+backendGeneratesCode (Named ViaC)        = True+backendGeneratesCode (Named JavaScript)  = True+backendGeneratesCode (Named Interpreter) = True+backendGeneratesCode (Named NoBackend)   = False++backendGeneratesCodeForHsBoot :: Backend -> Bool+backendGeneratesCodeForHsBoot (Named NCG)         = True+backendGeneratesCodeForHsBoot (Named LLVM)        = True+backendGeneratesCodeForHsBoot (Named ViaC)        = True+backendGeneratesCodeForHsBoot (Named JavaScript)  = True+backendGeneratesCodeForHsBoot (Named Interpreter) = False+backendGeneratesCodeForHsBoot (Named NoBackend)   = False++-- | When set, this flag turns on interface writing for+-- Backpack.  It should probably be the same as+-- `backendGeneratesCode`, but it is kept distinct for+-- reasons described in Note [-fno-code mode].+backendSupportsInterfaceWriting :: Backend -> Bool+backendSupportsInterfaceWriting (Named NCG)         = True+backendSupportsInterfaceWriting (Named LLVM)        = True+backendSupportsInterfaceWriting (Named ViaC)        = True+backendSupportsInterfaceWriting (Named JavaScript)  = True+backendSupportsInterfaceWriting (Named Interpreter) = True+backendSupportsInterfaceWriting (Named NoBackend)   = False++-- | When preparing code for this back end, the type+-- checker should pay attention to SPECIALISE pragmas.  If+-- this flag is `False`, then the type checker ignores+-- SPECIALISE pragmas (for imported things?).+backendRespectsSpecialise :: Backend -> Bool+backendRespectsSpecialise (Named NCG)         = True+backendRespectsSpecialise (Named LLVM)        = True+backendRespectsSpecialise (Named ViaC)        = True+backendRespectsSpecialise (Named JavaScript)  = True+backendRespectsSpecialise (Named Interpreter) = False+backendRespectsSpecialise (Named NoBackend)   = False++-- | This back end wants the `mi_top_env` field of a+-- `ModIface` to be populated (with the top-level bindings+-- of the original source).  Only true for the interpreter.+backendWantsGlobalBindings :: Backend -> Bool+backendWantsGlobalBindings (Named NCG)         = False+backendWantsGlobalBindings (Named LLVM)        = False+backendWantsGlobalBindings (Named ViaC)        = False+backendWantsGlobalBindings (Named JavaScript)  = False+backendWantsGlobalBindings (Named NoBackend)   = False+backendWantsGlobalBindings (Named Interpreter) = True++-- | The back end targets a technology that implements+-- `switch` natively.  (For example, LLVM or C.) Therefore+-- it is not necessary for GHC to ccompile a Cmm `Switch`+-- form into a decision tree with jump tables at the+-- leaves.+backendHasNativeSwitch :: Backend -> Bool+backendHasNativeSwitch (Named NCG)         = False+backendHasNativeSwitch (Named LLVM)        = True+backendHasNativeSwitch (Named ViaC)        = True+backendHasNativeSwitch (Named JavaScript)  = True+backendHasNativeSwitch (Named Interpreter) = False+backendHasNativeSwitch (Named NoBackend)   = False++-- | As noted in the documentation for+-- `PrimitiveImplementation`, certain primitives have+-- multiple implementations, depending on the capabilities+-- of the back end.  This field signals to module+-- "GHC.StgToCmm.Prim" what implementations to use with+-- this back end.+backendPrimitiveImplementation :: Backend -> PrimitiveImplementation+backendPrimitiveImplementation (Named NCG)         = NcgPrimitives+backendPrimitiveImplementation (Named LLVM)        = LlvmPrimitives+backendPrimitiveImplementation (Named JavaScript)  = JSPrimitives+backendPrimitiveImplementation (Named ViaC)        = GenericPrimitives+backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives+backendPrimitiveImplementation (Named NoBackend)   = GenericPrimitives++-- | When this value is `IsValid`, the back end is+-- compatible with vector instructions.  When it is+-- `NotValid`, it carries a message that is shown to+-- users.+backendSimdValidity :: Backend -> Validity' String+backendSimdValidity (Named NCG)         = IsValid+backendSimdValidity (Named LLVM)        = IsValid+backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]++-- | This flag says whether the back end supports large+-- binary blobs.  See Note [Embedding large binary blobs]+-- in "GHC.CmmToAsm.Ppr".+backendSupportsEmbeddedBlobs :: Backend -> Bool+backendSupportsEmbeddedBlobs (Named NCG)         = True+backendSupportsEmbeddedBlobs (Named LLVM)        = False+backendSupportsEmbeddedBlobs (Named ViaC)        = False+backendSupportsEmbeddedBlobs (Named JavaScript)  = False+backendSupportsEmbeddedBlobs (Named Interpreter) = False+backendSupportsEmbeddedBlobs (Named NoBackend)   = False++-- | This flag tells the compiler driver that the back end+-- does not support every target platform; it supports+-- only platforms that claim NCG support.  (It's set only+-- for the native code generator.)  Crufty.  If the driver+-- tries to use the native code generator /without/+-- platform support, the driver fails over to the LLVM+-- back end.+backendNeedsPlatformNcgSupport :: Backend -> Bool+backendNeedsPlatformNcgSupport (Named NCG)         = True+backendNeedsPlatformNcgSupport (Named LLVM)        = False+backendNeedsPlatformNcgSupport (Named ViaC)        = False+backendNeedsPlatformNcgSupport (Named JavaScript)  = False+backendNeedsPlatformNcgSupport (Named Interpreter) = False+backendNeedsPlatformNcgSupport (Named NoBackend)   = False++-- | This flag is set if the back end can generate code+-- for proc points.  If the flag is not set, then a Cmm+-- pass needs to split proc points (that is, turn each+-- proc point into a standalone procedure).+backendSupportsUnsplitProcPoints :: Backend -> Bool+backendSupportsUnsplitProcPoints (Named NCG)         = True+backendSupportsUnsplitProcPoints (Named LLVM)        = False+backendSupportsUnsplitProcPoints (Named ViaC)        = False+backendSupportsUnsplitProcPoints (Named JavaScript)  = False+backendSupportsUnsplitProcPoints (Named Interpreter) = False+backendSupportsUnsplitProcPoints (Named NoBackend)   = False++-- | This flag guides the driver in resolving issues about+-- API support on the target platform. If the flag is set,+-- then these things are true:+--+--    * When the target platform supports /only/ an unregisterised API,+--      this backend can be replaced with compilation via C.+--+--    * When the target does /not/ support an unregisterised API,+--      this back end can replace compilation via C.+--+backendSwappableWithViaC :: Backend -> Bool+backendSwappableWithViaC (Named NCG)         = True+backendSwappableWithViaC (Named LLVM)        = True+backendSwappableWithViaC (Named ViaC)        = False+backendSwappableWithViaC (Named JavaScript)  = False+backendSwappableWithViaC (Named Interpreter) = False+backendSwappableWithViaC (Named NoBackend)   = False++-- | This flag is true if the back end works *only* with+-- the unregisterised ABI.+backendUnregisterisedAbiOnly :: Backend -> Bool+backendUnregisterisedAbiOnly (Named NCG)         = False+backendUnregisterisedAbiOnly (Named LLVM)        = False+backendUnregisterisedAbiOnly (Named ViaC)        = True+backendUnregisterisedAbiOnly (Named JavaScript)  = False+backendUnregisterisedAbiOnly (Named Interpreter) = False+backendUnregisterisedAbiOnly (Named NoBackend)   = False++-- | This flag is set if the back end generates C code in+-- a @.hc@ file.  The flag lets the compiler driver know+-- if the command-line flag @-C@ is meaningful.+backendGeneratesHc :: Backend -> Bool+backendGeneratesHc (Named NCG)         = False+backendGeneratesHc (Named LLVM)        = False+backendGeneratesHc (Named ViaC)        = True+backendGeneratesHc (Named JavaScript)  = False+backendGeneratesHc (Named Interpreter) = False+backendGeneratesHc (Named NoBackend)   = False++-- | This flag says whether SPT (static pointer table)+-- entries will be inserted dynamically if needed.  If+-- this flag is `False`, then "GHC.Iface.Tidy" should emit C+-- stubs that initialize the SPT entries.+backendSptIsDynamic :: Backend -> Bool+backendSptIsDynamic (Named NCG)         = False+backendSptIsDynamic (Named LLVM)        = False+backendSptIsDynamic (Named ViaC)        = False+backendSptIsDynamic (Named JavaScript)  = False+backendSptIsDynamic (Named Interpreter) = True+backendSptIsDynamic (Named NoBackend)   = False++-- | If this flag is unset, then the driver ignores the flag @-fbreak-points@,+-- since backends other than the interpreter tend to panic on breakpoints.+backendSupportsBreakpoints :: Backend -> Bool+backendSupportsBreakpoints = \case+  Named NCG         -> False+  Named LLVM        -> False+  Named ViaC        -> False+  Named JavaScript  -> False+  Named Interpreter -> True+  Named NoBackend   -> False++-- | If this flag is set, then the driver forces the+-- optimization level to 0, issuing a warning message if+-- the command line requested a higher optimization level.+backendForcesOptimization0 :: Backend -> Bool+backendForcesOptimization0 (Named NCG)         = False+backendForcesOptimization0 (Named LLVM)        = False+backendForcesOptimization0 (Named ViaC)        = False+backendForcesOptimization0 (Named JavaScript)  = False+backendForcesOptimization0 (Named Interpreter) = True+backendForcesOptimization0 (Named NoBackend)   = False++-- | I don't understand exactly how this works.  But if+-- this flag is set *and* another condition is met, then+-- @ghc/Main.hs@ will alter the `DynFlags` so that all the+-- `hostFullWays` are asked for.  It is set only for the interpreter.+backendNeedsFullWays :: Backend -> Bool+backendNeedsFullWays (Named NCG)         = False+backendNeedsFullWays (Named LLVM)        = False+backendNeedsFullWays (Named ViaC)        = False+backendNeedsFullWays (Named JavaScript)  = False+backendNeedsFullWays (Named Interpreter) = True+backendNeedsFullWays (Named NoBackend)   = False++-- | This flag is also special for the interpreter: if a+-- message about a module needs to be shown, do we know+-- anything special about where the module came from?  The+-- Boolean argument is a `recomp` flag.+backendSpecialModuleSource :: Backend -> Bool -> Maybe String+backendSpecialModuleSource (Named NCG)         = const Nothing+backendSpecialModuleSource (Named LLVM)        = const Nothing+backendSpecialModuleSource (Named ViaC)        = const Nothing+backendSpecialModuleSource (Named JavaScript)  = const Nothing+backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing+backendSpecialModuleSource (Named NoBackend)   = const (Just "nothing")++-- | This flag says whether the back end supports Haskell+-- Program Coverage (HPC). If not, the compiler driver+-- will ignore the `-fhpc` option (and will issue a+-- warning message if it is used).+backendSupportsHpc :: Backend -> Bool+backendSupportsHpc (Named NCG)         = True+backendSupportsHpc (Named LLVM)        = True+backendSupportsHpc (Named ViaC)        = True+backendSupportsHpc (Named JavaScript)  = False+backendSupportsHpc (Named Interpreter) = False+backendSupportsHpc (Named NoBackend)   = True++-- | This flag says whether the back end supports foreign+-- import of C functions.  ("Supports" means "does not+-- barf on," so @-fno-code@ supports foreign C imports.)+backendSupportsCImport :: Backend -> Bool+backendSupportsCImport (Named NCG)         = True+backendSupportsCImport (Named LLVM)        = True+backendSupportsCImport (Named ViaC)        = True+backendSupportsCImport (Named JavaScript)  = True+backendSupportsCImport (Named Interpreter) = True+backendSupportsCImport (Named NoBackend)   = True++-- | This flag says whether the back end supports foreign+-- export of Haskell functions to C.+backendSupportsCExport :: Backend -> Bool+backendSupportsCExport (Named NCG)         = True+backendSupportsCExport (Named LLVM)        = True+backendSupportsCExport (Named ViaC)        = True+backendSupportsCExport (Named JavaScript)  = True+backendSupportsCExport (Named Interpreter) = False+backendSupportsCExport (Named NoBackend)   = True++-- | When using this back end, it may be necessary or+-- advisable to pass some `-D` options to a C compiler.+-- This (defunctionalized) function produces those+-- options, if any.  An IO action may be necessary in+-- order to interrogate external tools about what version+-- they are, for example.+--+-- The function's type is+-- @+-- Logger -> DynFlags -> IO [String]+-- @+--+-- This field is usually defaulted.+backendCDefs :: Backend -> DefunctionalizedCDefs+backendCDefs (Named NCG)         = NoCDefs+backendCDefs (Named LLVM)        = LlvmCDefs+backendCDefs (Named ViaC)        = NoCDefs+backendCDefs (Named JavaScript)  = NoCDefs+backendCDefs (Named Interpreter) = NoCDefs+backendCDefs (Named NoBackend)   = NoCDefs++-- | This (defunctionalized) function generates code and+-- writes it to a file.  The type of the function is+--+-- >    Logger+-- > -> DynFlags+-- > -> Module -- ^ module being compiled+-- > -> ModLocation+-- > -> FilePath -- ^ Where to write output+-- > -> Set UnitId -- ^ dependencies+-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm`+-- > -> IO a+backendCodeOutput :: Backend -> DefunctionalizedCodeOutput+backendCodeOutput (Named NCG)         = NcgCodeOutput+backendCodeOutput (Named LLVM)        = LlvmCodeOutput+backendCodeOutput (Named ViaC)        = ViaCCodeOutput+backendCodeOutput (Named JavaScript)  = JSCodeOutput+backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend"+backendCodeOutput (Named NoBackend)   = panic "backendCodeOutput: noBackend"++backendUseJSLinker :: Backend -> Bool+backendUseJSLinker (Named NCG)         = False+backendUseJSLinker (Named LLVM)        = False+backendUseJSLinker (Named ViaC)        = False+backendUseJSLinker (Named JavaScript)  = True+backendUseJSLinker (Named Interpreter) = False+backendUseJSLinker (Named NoBackend)   = False++-- | This (defunctionalized) function tells the compiler+-- driver what else has to be run after code output.+-- The type of the function is+--+-- >+-- >    TPipelineClass TPhase m+-- > => PipeEnv+-- > -> HscEnv+-- > -> Maybe ModLocation+-- > -> FilePath+-- > -> m (Maybe FilePath)+backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline+backendPostHscPipeline (Named NCG)  = NcgPostHscPipeline+backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline+backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline+backendPostHscPipeline (Named JavaScript)  = JSPostHscPipeline+backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline+backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline++-- | Somewhere in the compiler driver, when compiling+-- Haskell source (as opposed to a boot file or a sig+-- file), it needs to know what to do with the code that+-- the `backendCodeOutput` writes to a file.  This `Phase`+-- value gives instructions like "run the C compiler",+-- "run the assembler," or "run the LLVM Optimizer."+backendNormalSuccessorPhase :: Backend -> Phase+backendNormalSuccessorPhase (Named NCG)  = As False+backendNormalSuccessorPhase (Named LLVM) = LlvmOpt+backendNormalSuccessorPhase (Named ViaC) = HCc+backendNormalSuccessorPhase (Named JavaScript)  = StopLn+backendNormalSuccessorPhase (Named Interpreter) = StopLn+backendNormalSuccessorPhase (Named NoBackend)   = StopLn++-- | Name of the back end, if any.  Used to migrate legacy+-- clients of the GHC API.  Code within the GHC source+-- tree should not refer to a back end's name.+backendName :: Backend -> BackendName+backendName (Named NCG)  = NCG+backendName (Named LLVM) = LLVM+backendName (Named ViaC) = ViaC+backendName (Named JavaScript)  = JavaScript+backendName (Named Interpreter) = Interpreter+backendName (Named NoBackend)   = NoBackend++++-- | A list of all back ends.  They are ordered as we wish them to+-- appear when they are enumerated in error messages.++allBackends :: [Backend]+allBackends = [ ncgBackend+              , llvmBackend+              , viaCBackend+              , jsBackend+              , interpreterBackend+              , noBackend+              ]++-- | When foreign C import or export is invalid, the carried value+-- enumerates the /valid/ back ends.++backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend]++backendValidityOfCImport backend =+    if backendSupportsCImport backend then+        IsValid+    else+        NotValid $ filter backendSupportsCImport allBackends++backendValidityOfCExport backend =+    if backendSupportsCExport backend then+        IsValid+    else+        NotValid $ filter backendSupportsCExport allBackends+++++{-+Note [Backend Defunctionalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I had hoped to include code-output and post-hsc-pipeline functions+directly in the `Backend` record itself.  But this agenda was derailed+by mutual recursion in the types:++  - A `DynFlags` record contains a back end of type `Backend`.+  - A `Backend` contains a code-output function.+  - A code-output function takes Cmm as input.+  - Cmm can include a `CLabel`.+  - A `CLabel` can have elements that are defined in+    `GHC.Driver.Session`, where `DynFlags` is defined.++There is also a nasty issue in the values: a typical post-backend+pipeline function both depends on and is depended upon by functions in+"GHC.Driver.Pipeline".++I'm cut the Gordian not by removing the function types from the+`Backend` record.  Instead, a function is represented by its /name/.+This representation is an example of an old trick called+/defunctionalization/, which has been used in both compilers and+interpreters for languages with first-class, nested functions.  Here,+a function's name is a value of an algebraic data type.  For example,+a code-output function is represented by a value of this type:++    data DefunctionalizedCodeOutput+      = NcgCodeOutput+      | ViaCCodeOutput+      | LlvmCodeOutput++Such a function may be applied in one of two ways:++  - In this particular example, a `case` expression in module+    "GHC.Driver.CodeOutput" discriminates on the value and calls the+    designated function.++  - In another example, a function of type `DefunctionalizedCDefs` is+    applied by calling function `applyCDefs`, which has this type:++    @+    applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]+    @++    Function `applyCDefs` is defined in module "GHC.SysTools.Cpp".++I don't love this solution, but defunctionalization is a standard+thing, and it makes the meanings of the enumeration values clear.++Anyone defining a new back end will need to extend both the+`DefunctionalizedCodeOutput` type and the corresponding apply+function.+-}
+ GHC/Driver/Backend/Internal.hs view
@@ -0,0 +1,33 @@+{-|+Module      : GHC.Driver.Backend.Internal+Description : Interface for migrating legacy clients of the GHC API++In versions of GHC up through 9.2, a `Backend` was represented only by+its name.  This module is meant to aid clients written against the GHC+API, versions 9.2 and older.  The module provides an alternative way+to name any back end found in GHC 9.2.  /Code within the GHC source+tree should not import this module./ (#20927).++Only back ends found in version 9.2 have names.++-}++module GHC.Driver.Backend.Internal+   ( -- * Name of a back end+     BackendName(..)+   )++where++++import GHC.Prelude++data BackendName+   = NCG           -- ^ Names the native code generator backend.+   | LLVM          -- ^ Names the LLVM backend.+   | ViaC          -- ^ Names the Via-C backend.+   | JavaScript    -- ^ Names the JS backend.+   | Interpreter   -- ^ Names the ByteCode interpreter.+   | NoBackend     -- ^ Names the `-fno-code` backend.+ deriving (Eq, Show)
+ GHC/Driver/Backpack.hs view
@@ -0,0 +1,945 @@++{-# 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+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.Types.SrcLoc+import GHC.Types.SourceError+import GHC.Types.SourceFile+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet+import GHC.Types.Basic (convImportLevel)++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.Linker.Types++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.Maybe+import GHC.Data.OsPath (unsafeEncodeUtf, os)+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+import GHC.Types.Error (mkUnknownDiagnostic)+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable++-- | 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+    logger0 <- getLogger+    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 (supportedLanguagePragmas dflags1) src_filename+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma logger0 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 $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcDriverMessage <$> 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 HsSrcFile _ _) = emptyUniqDSet+    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname+    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 mkUnknownDiagnostic (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++        let hi_dir = expectJust $ 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 takeLinkables x+              | mi_hsc_src (hm_iface x) == HsSrcFile+              = [Just $ expectJust $ homeModInfoObject x]+              | otherwise+              = [Nothing]+        linkables <- liftIO $ catMaybes <$> concatHpt takeLinkables (hsc_HPT hsc_env)+        let+            obj_files = concatMap linkableFiles linkables+            state     = hsc_units hsc_env++            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 mkUnknownDiagnostic (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 = UnitEnv+          { ue_platform  = targetPlatform dflags+          , ue_namever   = ghcNameVersion dflags+          , ue_current_unit = homeUnitId home_unit++          , ue_home_unit_graph =+                HUG.unitEnv_singleton+                    (homeUnitId home_unit)+                    (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags (ue_hpt old_unit_env) (Just home_unit))+          , ue_eps       = ue_eps old_unit_env+          , ue_module_graph = ue_module_graph 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+        UnitNode {} -> showMsg (text "Package ") 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+          [ moduleNodeInfoModuleName ms+          | ModuleNode _ ms <- nodes+          , moduleNodeInfoHscSource ms == Just 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 inodes = instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env)+    -- TODO: Backpack mode does not properly support ExternalPackage nodes yet+    -- Module nodes do not get given package dependencies (see hsModuleToModSummary).+    let pkg_nodes =  ordNub $ map (\(_, iud) -> UnitNode [] (instUnitInstanceOf iud)) inodes+    let graph_nodes = nodes ++ req_nodes ++ (map (uncurry InstantiationNode) $ inodes) ++ pkg_nodes+        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+                    (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (os "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 HsigFile++    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 = ((,,) NormalLevel NoPkgQual . noLoc) <$> extra_sig_imports,+        ms_parsed_mod = Just (HsParsedModule {+                hpm_module = L loc (HsModule {+                        hsmodExt = XModulePs {+                            hsmodAnn = noAnn,+                            hsmodLayout = EpNoLayout,+                            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 = [mkModuleEdge NormalLevel (NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit))) | mn <- extra_sig_imports ]+    return (ModuleNode nodes (ModuleNodeCompile 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 location = mkHomeModLocation fopts modname+                             (unsafeEncodeUtf $ unpackFS unit_fs </>+                              moduleNameSlashes modname)+                             (case hsc_src of+                                HsigFile   -> os "hsig"+                                HsBootFile -> os "hs-boot"+                                HsSrcFile  -> os "hs")+                             hsc_src+    -- 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++        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) = (convImportLevel (ideclLevelSpec 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 ++ ord_idecls)+    (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 hsc_src+    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 = (\i -> reLoc (ideclName (unLoc i))) <$> src_idecls,+            ms_textual_imps = normal_imports+                           -- We have to do something special here:+                           -- due to merging, requirements may end up with+                           -- extra imports+                           ++ ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports)+                           ++ ((,,) NormalLevel 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 (map mkNormalEdge (mod_nodes ++ inst_nodes)) (ModuleNodeCompile 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])
+ GHC/Driver/Backpack/Syntax.hs view
@@ -0,0 +1,86 @@+-- | This is the syntax for bkp files which are parsed in 'ghc --backpack'+-- mode.  This syntax is used purely for testing purposes.++module GHC.Driver.Backpack.Syntax (+    -- * Backpack abstract syntax+    HsUnitId(..),+    LHsUnitId,+    HsModuleSubst,+    LHsModuleSubst,+    HsModuleId(..),+    LHsModuleId,+    HsComponentId(..),+    LHsUnit, HsUnit(..),+    LHsUnitDecl, HsUnitDecl(..),+    IncludeDecl(..),+    LRenaming, Renaming(..),+    ) where++import GHC.Prelude++import GHC.Hs++import GHC.Types.SrcLoc+import GHC.Types.SourceFile++import GHC.Unit.Types+import GHC.Unit.Info++import GHC.Utils.Outputable++{-+************************************************************************+*                                                                      *+                        User syntax+*                                                                      *+************************************************************************+-}++data HsComponentId = HsComponentId {+    hsPackageName :: PackageName,+    hsComponentId :: UnitId+    }++instance Outputable HsComponentId where+    ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn++data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n]+type LHsUnitId n = Located (HsUnitId n)++type HsModuleSubst n = (Located ModuleName, LHsModuleId n)+type LHsModuleSubst n = Located (HsModuleSubst n)++data HsModuleId n = HsModuleVar (Located ModuleName)+                  | HsModuleId (LHsUnitId n) (Located ModuleName)+type LHsModuleId n = Located (HsModuleId n)++-- | Top level @unit@ declaration in a Backpack file.+data HsUnit n = HsUnit {+        hsunitName :: Located n,+        hsunitBody :: [LHsUnitDecl n]+    }+type LHsUnit n = Located (HsUnit n)++-- | A declaration in a package, e.g. a module or signature definition,+-- or an include.+data HsUnitDecl n+    = DeclD   HscSource (Located ModuleName) (Located (HsModule GhcPs))+    | IncludeD   (IncludeDecl n)+type LHsUnitDecl n = Located (HsUnitDecl n)++-- | An include of another unit+data IncludeDecl n = IncludeDecl {+        idUnitId :: LHsUnitId n,+        idModRenaming :: Maybe [ LRenaming ],+        -- | Is this a @dependency signature@ include?  If so,+        -- we don't compile this include when we instantiate this+        -- unit (as there should not be any modules brought into+        -- scope.)+        idSignatureInclude :: Bool+    }++-- | Rename a module from one name to another.  The identity renaming+-- means that the module should be brought into scope.+data Renaming = Renaming { renameFrom :: Located ModuleName+                         , renameTo :: Maybe (Located ModuleName) }+type LRenaming = Located Renaming
+ GHC/Driver/CmdLine.hs view
@@ -0,0 +1,343 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}++-------------------------------------------------------------------------------+--+-- | Command-line parser+--+-- This is an abstract command-line parser used by DynFlags.+--+-- (c) The University of Glasgow 2005+--+-------------------------------------------------------------------------------++module GHC.Driver.CmdLine+    (+      processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),+      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,+      errorsToGhcException,++      Err(..), Warn, warnsToMessages,++      EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM+    ) where++import GHC.Prelude++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Data.Bag+import GHC.Types.SrcLoc+import GHC.Types.Error+import GHC.Utils.Error+import GHC.Driver.Errors.Types+import GHC.Driver.Errors.Ppr () -- instance Diagnostic DriverMessage+import GHC.Utils.Outputable (text)++import Data.Function+import Data.List (sortBy, intercalate, stripPrefix)+import Data.Word++import GHC.ResponseFile+import Control.Exception (IOException, catch)+import Control.Monad (ap)+import Control.Monad.IO.Class++--------------------------------------------------------+--         The Flag and OptKind types+--------------------------------------------------------++data Flag m = Flag+    {   flagName    :: String,     -- Flag, without the leading "-"+        flagOptKind :: OptKind m,  -- What to do if we see it+        flagGhcMode :: GhcFlagMode    -- Which modes this flag affects+    }++defFlag :: String -> OptKind m -> Flag m+defFlag name optKind = Flag name optKind AllModes++defGhcFlag :: String -> OptKind m -> Flag m+defGhcFlag name optKind = Flag name optKind OnlyGhc++defGhciFlag :: String -> OptKind m -> Flag m+defGhciFlag name optKind = Flag name optKind OnlyGhci++defHiddenFlag :: String -> OptKind m -> Flag m+defHiddenFlag name optKind = Flag name optKind HiddenFlag++hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n+hoistFlag f (Flag a b c) = Flag a (go b) c+  where+      go (NoArg k)  = NoArg (go2 k)+      go (HasArg k) = HasArg (\s -> go2 (k s))+      go (SepArg k) = SepArg (\s -> go2 (k s))+      go (Prefix k) = Prefix (\s -> go2 (k s))+      go (OptPrefix k) = OptPrefix (\s -> go2 (k s))+      go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))+      go (IntSuffix k) = IntSuffix (\n -> go2 (k n))+      go (Word64Suffix k) = Word64Suffix (\s -> go2 (k s))+      go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))+      go (PassFlag k) = PassFlag (\s -> go2 (k s))+      go (AnySuffix k) = AnySuffix (\s -> go2 (k s))++      go2 :: EwM m a -> EwM n a+      go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws)++-- | GHC flag modes describing when a flag has an effect.+data GhcFlagMode+    = OnlyGhc  -- ^ The flag only affects the non-interactive GHC+    | OnlyGhci -- ^ The flag only affects the interactive GHC+    | AllModes -- ^ The flag affects multiple ghc modes+    | HiddenFlag -- ^ This flag should not be seen in cli completion++data OptKind m                             -- Suppose the flag is -f+    = NoArg     (EwM m ())                 -- -f all by itself+    | HasArg    (String -> EwM m ())       -- -farg or -f arg+    | SepArg    (String -> EwM m ())       -- -f arg+    | Prefix    (String -> EwM m ())       -- -farg+    | OptPrefix (String -> EwM m ())       -- -f or -farg (i.e. the arg is optional)+    | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn+    | IntSuffix (Int -> EwM m ())          -- -f or -f=n; pass n to fn+    | Word64Suffix (Word64 -> EwM m ())    -- -f or -f=n; pass n to fn+    | FloatSuffix (Float -> EwM m ())      -- -f or -f=n; pass n to fn+    | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn+    | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn+++--------------------------------------------------------+--         The EwM monad+--------------------------------------------------------++-- | A command-line error message+newtype Err  = Err { errMsg :: Located String }++-- | A command-line warning message and the reason it arose+--+-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@.+type Warn = Located DriverMessage++type Errs  = Bag Err+type Warns = [Warn]++-- EwM ("errors and warnings monad") is a monad+-- transformer for m that adds an (err, warn) state+newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg+                              -> Errs -> Warns+                              -> m (Errs, Warns, a) }+  deriving (Functor)++instance Monad m => Applicative (EwM m) where+    pure v = EwM (\_ e w -> return (e, w, v))+    (<*>) = ap++instance Monad m => Monad (EwM m) where+    (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w+                                      unEwM (k r) l e' w')+instance MonadIO m => MonadIO (EwM m) where+    liftIO = liftEwM . liftIO++runEwM :: EwM m a -> m (Errs, Warns, a)+runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag mempty++setArg :: Located String -> EwM m () -> EwM m ()+setArg l (EwM f) = EwM (\_ es ws -> f l es ws)++addErr :: Monad m => String -> EwM m ()+addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))++addWarn :: Monad m => String -> EwM m ()+addWarn msg = addFlagWarn $ DriverUnknownMessage $ mkSimpleUnknownDiagnostic $+  mkPlainDiagnostic WarningWithoutFlag noHints $ text msg++addFlagWarn :: Monad m => DriverMessage -> EwM m ()+addFlagWarn msg = EwM+  (\(L loc _) es ws -> return (es, L loc msg : ws, ()))++getArg :: Monad m => EwM m String+getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg))++getCurLoc :: Monad m => EwM m SrcSpan+getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc))++liftEwM :: Monad m => m a -> EwM m a+liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })++warnsToMessages :: DiagOpts -> [Warn] -> Messages DriverMessage+warnsToMessages diag_opts = foldr+  (\(L loc w) ws -> addMessage (mkPlainMsgEnvelope diag_opts loc w) ws)+  emptyMessages++--------------------------------------------------------+--         Processing arguments+--------------------------------------------------------++processArgs :: Monad m+            => [Flag m]               -- ^ cmdline parser spec+            -> [Located String]       -- ^ args+            -> (FilePath -> EwM m [Located String]) -- ^ response file handler+            -> m ( [Located String],  -- spare args+                   [Err],  -- errors+                   Warns ) -- warnings+processArgs spec args handleRespFile = do+    (errs, warns, spare) <- runEwM action+    return (spare, bagToList errs, warns)+  where+    action = process args []++    -- process :: [Located String] -> [Located String] -> EwM m [Located String]+    process [] spare = return (reverse spare)++    process (L _ ('@' : resp_file) : args) spare = do+        resp_args <- handleRespFile resp_file+        process (resp_args ++ args) spare++    process (locArg@(L _ ('-' : arg)) : args) spare =+        case findArg spec arg of+            Just (rest, opt_kind) ->+                case processOneArg opt_kind rest arg args of+                    Left err ->+                        let b = process args spare+                        in (setArg locArg $ addErr err) >> b++                    Right (action,rest) ->+                        let b = process rest spare+                        in (setArg locArg $ action) >> b++            Nothing -> process args (locArg : spare)++    process (arg : args) spare = process args (arg : spare)+++processOneArg :: OptKind m -> String -> String -> [Located String]+              -> Either String (EwM m (), [Located String])+processOneArg opt_kind rest arg args+  = let dash_arg = '-' : arg+        rest_no_eq = dropEq rest+    in case opt_kind of+        NoArg  a -> assert (null rest) Right (a, args)++        HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args)+                 | otherwise -> case args of+                                    []               -> missingArgErr dash_arg+                                    (L _ arg1:args1) -> Right (f arg1, args1)++        -- See #9776+        SepArg f -> case args of+                        []               -> missingArgErr dash_arg+                        (L _ arg1:args1) -> Right (f arg1, args1)++        -- See #12625+        Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args)+                 | otherwise          -> missingArgErr  dash_arg++        PassFlag f  | notNull rest -> unknownFlagErr dash_arg+                    | otherwise    -> Right (f dash_arg, args)++        OptIntSuffix f | null rest                     -> Right (f Nothing,  args)+                       | Just n <- parseInt rest_no_eq -> Right (f (Just n), args)+                       | otherwise -> Left ("malformed integer argument in " ++ dash_arg)++        IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)+                    | otherwise -> Left ("malformed integer argument in " ++ dash_arg)++        Word64Suffix f | Just n <- parseWord64 rest_no_eq -> Right (f n, args)+                     | otherwise -> Left ("malformed natural argument in " ++ dash_arg)++        FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)+                      | otherwise -> Left ("malformed float argument in " ++ dash_arg)++        OptPrefix f       -> Right (f rest_no_eq, args)+        AnySuffix f       -> Right (f dash_arg, args)++findArg :: [Flag m] -> String -> Maybe (String, OptKind m)+findArg spec arg =+    case sortBy (compare `on` (length . fst)) -- prefer longest matching flag+           [ (removeSpaces rest, optKind)+           | flag <- spec,+             let optKind  = flagOptKind flag,+             Just rest <- [stripPrefix (flagName flag) arg],+             arg_ok optKind rest arg ]+    of+        []      -> Nothing+        (one:_) -> Just one++arg_ok :: OptKind t -> [Char] -> String -> Bool+arg_ok (NoArg           _)  rest _   = null rest+arg_ok (HasArg          _)  _    _   = True+arg_ok (SepArg          _)  rest _   = null rest+arg_ok (Prefix          _)  _    _   = True -- Missing argument checked for in processOneArg t+                                            -- to improve error message (#12625)+arg_ok (OptIntSuffix    _)  _    _   = True+arg_ok (IntSuffix       _)  _    _   = True+arg_ok (Word64Suffix    _)  _    _   = True+arg_ok (FloatSuffix     _)  _    _   = True+arg_ok (OptPrefix       _)  _    _   = True+arg_ok (PassFlag        _)  rest _   = null rest+arg_ok (AnySuffix       _)  _    _   = True++-- | Parse an Int+--+-- Looks for "433" or "=342", with no trailing gubbins+--   * n or =n      => Just n+--   * gibberish    => Nothing+parseInt :: String -> Maybe Int+parseInt s = case reads s of+                 ((n,""):_) -> Just n+                 _          -> Nothing++parseWord64 :: String -> Maybe Word64+parseWord64 s = case reads s of+                 ((n,""):_) -> Just n+                 _          -> Nothing++parseFloat :: String -> Maybe Float+parseFloat s = case reads s of+                   ((n,""):_) -> Just n+                   _          -> Nothing++-- | Discards a leading equals sign+dropEq :: String -> String+dropEq ('=' : s) = s+dropEq s         = s++unknownFlagErr :: String -> Either String a+unknownFlagErr f = Left ("unrecognised flag: " ++ f)++missingArgErr :: String -> Either String a+missingArgErr f = Left ("missing argument for flag: " ++ f)++--------------------------------------------------------+-- Utils+--------------------------------------------------------++-- | Parse a response file into arguments.+parseResponseFile :: MonadIO m => FilePath -> EwM m [Located String]+parseResponseFile path = do+  res <- liftIO $ fmap Right (readFile path) `catch`+    \(e :: IOException) -> pure (Left e)+  case res of+    Left _err -> addErr "Could not open response file" >> return []+    Right resp_file -> return $ map (mkGeneralLocated path) (unescapeArgs resp_file)++-- See Note [Handling errors when parsing command-line flags]+errorsToGhcException :: [(String,    -- Location+                          String)]   -- Error+                     -> GhcException+errorsToGhcException errs =+    UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ]++{- Note [Handling errors when parsing command-line flags]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Parsing of static and mode flags happens before any session is started, i.e.,+before the first call to 'GHC.withGhc'. Therefore, to report errors for+invalid usage of these two types of flags, we can not call any function that+needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags+is not set either). So we always print "on the commandline" as the location,+which is true except for Api users, which is probably ok.++When reporting errors for invalid usage of dynamic flags we /can/ make use of+DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull.++Before, we called unsafeGlobalDynFlags when an invalid (combination of)+flag(s) was given on the commandline, resulting in panics (#9963).+-}
+ GHC/Driver/CodeOutput.hs view
@@ -0,0 +1,426 @@+{-+(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.StgToCmm.CgUtils (CgStream)++import GHC.Driver.DynFlags+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 GHC.Data.OsPath+import qualified GHC.Data.ShortText as ST+import GHC.Data.Stream           ( liftIO )+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.DSM++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+    -> DUniqSupply -- ^ The deterministic unique supply to run the CgStream.+                   -- See Note [Deterministic Uniques in the CG]+    -> CgStream 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 dus0+  cmm_stream+  =+    do  {+        -- Lint each CmmGroup as it goes past+        ; let linted_cmm_stream =+                 if gopt Opt_DoCmmLinting dflags+                    then Stream.mapM (liftIO . 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+                                                   MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint"+                                                   noSrcSpan+                                                   $ withPprStyle defaultDumpStyle err+                                       ; ghcExit logger 1+                                       }+                        Nothing  -> return ()+                ; return cmm+                }++        ; let final_stream :: CgStream RawCmmGroup (ForeignStubs, a)+              final_stream = do+                  { a <- linted_cmm_stream+                  ; let stubs = genForeignStubs a+                  ; emitInitializerDecls this_mod stubs+                  ; return (stubs, a) }++        ; let dus1 = newTagDUniqSupply 'n' dus0+        ; (stubs, a) <- case backendCodeOutput (backend dflags) of+                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm dus1+                                             final_stream+                 ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps+                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 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 -> CgStream 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+        -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                       -- See Note [Deterministic Uniques in the CG]+        -> CgStream RawCmmGroup a+        -> Set UnitId+        -> IO a+outputC logger dflags filenm dus 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 -> fmap fst $ runUDSMT dus $ do+      liftIO $ 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 (liftIO . writeC)++{-+************************************************************************+*                                                                      *+\subsection{Assembler}+*                                                                      *+************************************************************************+-}++outputAsm :: Logger+          -> DynFlags+          -> Module+          -> ModLocation+          -> FilePath+          -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                         -- See Note [Deterministic Uniques in the CG]+          -> CgStream RawCmmGroup a+          -> IO a+outputAsm logger dflags this_mod location filenm dus cmm_stream = do+  -- Update tag of uniques in Stream+  debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)+  let ncg_config = initNCGConfig dflags this_mod+  {-# SCC "OutputAsm" #-} doOutput filenm $+    \h -> {-# SCC "NativeCodeGen" #-}+      fmap fst $+      runUDSMT dus $ setTagUDSMT 'n' $+      nativeCodeGen logger (toolSettings dflags) ncg_config location h cmm_stream++{-+************************************************************************+*                                                                      *+\subsection{LLVM}+*                                                                      *+************************************************************************+-}++outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath+           -> DUniqSupply -- ^ The deterministic uniq supply to run the CgStream+                          -- See Note [Deterministic Uniques in the CG]+           -> CgStream RawCmmGroup a -> IO a+outputLlvm logger llvm_config dflags filenm dus cmm_stream = do+  lcg_config <- initLlvmCgConfig logger llvm_config dflags+  {-# SCC "llvm_output" #-} doOutput filenm $+    \f -> {-# SCC "llvm_CodeGen" #-}+      llvmCodeGen logger lcg_config f dus cmm_stream++{-+************************************************************************+*                                                                      *+\subsection{JavaScript}+*                                                                      *+************************************************************************+-}+outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> CgStream 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+   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++        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 \"rts/ghc_ffi.h\"\n"+              | otherwise = ""++        -- The header path is computed from the module source path, which+        -- does not exist when loading interface core bindings for Template+        -- Haskell for non-home modules (e.g. when compiling in separate+        -- invocations of oneshot mode).+        -- Stub headers are only generated for foreign exports.+        -- Since those aren't supported for TH with bytecode at the moment,+        -- it doesn't make much of a difference.+        -- In any case, if a stub dir was specified explicitly by the user, it+        -- would be used nonetheless.+        stub_h_file_exists <-+          case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of+            Nothing -> pure False+            Just path -> do+              let stub_h = unsafeDecodeUtf path+              createDirectoryIfMissing True (takeDirectory stub_h)+              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 ";"
+ GHC/Driver/Config.hs view
@@ -0,0 +1,57 @@+-- | Subsystem configuration+module GHC.Driver.Config+   ( initOptCoercionOpts+   , initSimpleOpts+   , initEvalOpts+   , EvalStep(..)+   )+where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Core.SimpleOpt+import GHC.Core.Coercion.Opt+import GHCi.Message (EvalOpts(..))++-- | Initialise coercion optimiser configuration from DynFlags+initOptCoercionOpts :: DynFlags -> OptCoercionOpts+initOptCoercionOpts dflags = OptCoercionOpts+   { optCoercionEnabled = not (hasNoOptCoercion dflags)+   }++-- | Initialise Simple optimiser configuration from DynFlags+initSimpleOpts :: DynFlags -> SimpleOpts+initSimpleOpts dflags = SimpleOpts+   { so_uf_opts = unfoldingOpts dflags+   , so_co_opts = initOptCoercionOpts dflags+   , so_eta_red = gopt Opt_DoEtaReduction dflags+   , so_inline  = True+   }++-- | Instruct the interpreter evaluation to break...+data EvalStep+  -- | ... at every breakpoint tick+  = EvalStepSingle+  -- | ... after any evaluation to WHNF+  -- (See Note [Debugger: Step-out])+  | EvalStepOut+  -- | ... only on explicit breakpoints+  | EvalStepNone++-- | Extract GHCi options from DynFlags and step+initEvalOpts :: DynFlags -> EvalStep -> EvalOpts+initEvalOpts dflags step =+  EvalOpts+    { useSandboxThread = gopt Opt_GhciSandbox dflags+    , singleStep       = singleStep+    , stepOut          = stepOut+    , breakOnException = gopt Opt_BreakOnException dflags+    , breakOnError     = gopt Opt_BreakOnError dflags+    }+  where+    (singleStep, stepOut) = case step of+      EvalStepSingle -> (True,  False)+      EvalStepOut    -> (False, True)+      EvalStepNone   -> (False, False)+
+ GHC/Driver/Config/Cmm.hs view
@@ -0,0 +1,28 @@+module GHC.Driver.Config.Cmm+  ( initCmmConfig+  ) where++import GHC.Cmm.Config++import GHC.Driver.DynFlags+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+  , cmmOptThreadSanitizer  = gopt Opt_CmmThreadSanitizer dflags+  , cmmGenStackUnwindInstr = debugLevel dflags > 0+  , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+  , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))+  , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))+                             || not (platformTablesNextToCode platform)+  }+  where platform                = targetPlatform dflags
+ GHC/Driver/Config/Cmm/Parser.hs view
@@ -0,0 +1,25 @@+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.DynFlags++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")+  }+
+ GHC/Driver/Config/CmmToAsm.hs view
@@ -0,0 +1,79 @@+module GHC.Driver.Config.CmmToAsm+  ( initNCGConfig+  )+where++import GHC.Prelude++import GHC.Driver.DynFlags++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+   , ncgAvxEnabled = isAvxEnabled dflags+   , ncgAvx2Enabled = isAvx2Enabled dflags+   , ncgAvx512fEnabled = isAvx512fEnabled dflags++   , 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+   , ncgEnableInterModuleFarJumps = gopt Opt_InterModuleFarJumps 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+   }
+ GHC/Driver/Config/CmmToLlvm.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.CmmToLlvm+  ( initLlvmCgConfig+  )+where++import GHC.Prelude+import GHC.Driver.DynFlags+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+    , llvmCgAvxEnabled           = isAvxEnabled 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+    }
+ GHC/Driver/Config/Core/Lint.hs view
@@ -0,0 +1,181 @@+module GHC.Driver.Config.Core.Lint+  ( endPass+  , endPassHscEnvIO+  , lintCoreBindings+  , initEndPassConfig+  , initLintPassResultConfig+  , initLintConfig+  ) where++import GHC.Prelude++import qualified GHC.LanguageExtensions as LangExt++import GHC.Driver.Env+import GHC.Driver.DynFlags+import GHC.Driver.Config.Diagnostic++import GHC.Core+import GHC.Core.Lint+import GHC.Core.Lint.Interactive+import GHC.Core.Opt.Pipeline.Types+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )+import GHC.Core.Opt.Simplify.Env ( SimplMode(..) )+import GHC.Core.Opt.Monad+import GHC.Core.Coercion++import GHC.Types.Basic ( CompilerPhase(..) )++import GHC.Utils.Outputable as Outputable++{-+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+       ; name_ppr_ctx <- getNamePprCtx+       ; liftIO $ endPassHscEnvIO hsc_env+           name_ppr_ctx pass binds rules+       }++endPassHscEnvIO :: HscEnv -> NamePprCtx+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()+endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules+  = do { let dflags  = hsc_dflags hsc_env+       ; endPassIO+           (hsc_logger hsc_env)+           (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass)+           binds rules+       }++-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs+lintCoreBindings dflags coreToDo vars -- binds+  = lintCoreBindings' $ LintConfig+      { l_diagOpts = initDiagOpts dflags+      , l_platform = targetPlatform dflags+      , l_flags    = perPassFlags dflags coreToDo+      , l_vars     = vars+      }++initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig+initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig+  { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags)+  , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags+      then Just $ initLintPassResultConfig dflags extra_vars pass+      else Nothing+  , ep_namePprCtx = name_ppr_ctx+  , ep_dumpFlag = coreDumpFlag pass+  , ep_prettyPass = ppr pass+  , ep_passDetails = pprPassDetails pass+  }++coreDumpFlag :: CoreToDo -> Maybe DumpFlag+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_dump_float_in+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out+coreDumpFlag CoreLiberateCase         = Just Opt_D_dump_liberate_case+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_dump_static_argument_transformation+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify+coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_dmdanal+coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec_constr+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 CoreAddCallerCcs         = Nothing+coreDumpFlag CoreAddLateCcs           = Nothing+coreDumpFlag CoreDoPrintCore          = Nothing+coreDumpFlag (CoreDoRuleCheck {})     = Nothing+coreDumpFlag CoreDoNothing            = Nothing+coreDumpFlag (CoreDoPasses {})        = Nothing++initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig+initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig+  { lpr_diagOpts      = initDiagOpts dflags+  , lpr_platform      = targetPlatform dflags+  , lpr_makeLintFlags = perPassFlags dflags pass+  , lpr_showLintWarnings = showLintWarnings pass+  , lpr_passPpr = ppr pass+  , lpr_localsInScope = extra_vars+  }++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 cfg) = case sm_phase (so_mode cfg) of+  InitialPhase -> False+  _ -> True+showLintWarnings _ = True++perPassFlags :: DynFlags -> CoreToDo -> LintFlags+perPassFlags dflags pass+  = (defaultLintFlags dflags)+               { lf_check_global_ids = check_globals+               , lf_check_inline_loop_breakers = check_lbs+               , lf_check_static_ptrs = check_static_ptrs+               , lf_check_linearity = check_linearity+               , lf_check_fixed_rep = check_fixed_rep }+  where+    -- In the output of the desugarer, before optimisation,+    -- we have eta-expanded data constructors with representation-polymorphic+    -- bindings; so we switch off the representation-polymorphism checks.+    -- The very simple optimiser will beta-reduce them away.+    -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete+    check_fixed_rep = case pass of+                        CoreDesugar -> False+                        _           -> True++    -- 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++    -- See Note [Linting linearity]+    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (+                        case pass of+                          CoreDesugar -> True+                          _ -> False)++initLintConfig :: DynFlags -> [Var] -> LintConfig+initLintConfig dflags vars =LintConfig+  { l_diagOpts = initDiagOpts dflags+  , l_platform = targetPlatform dflags+  , l_flags    = defaultLintFlags dflags+  , l_vars     = vars+  }++defaultLintFlags :: DynFlags -> LintFlags+defaultLintFlags dflags = LF { lf_check_global_ids = False+                             , lf_check_inline_loop_breakers = True+                             , lf_check_static_ptrs = AllowAnywhere+                             , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags+                             , lf_report_unsat_syns = True+                             , lf_check_fixed_rep = True+                             }
+ GHC/Driver/Config/Core/Lint/Interactive.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.Core.Lint.Interactive+  ( lintInteractiveExpr+  ) where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.DynFlags+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
+ GHC/Driver/Config/Core/Opt/Arity.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.Arity+  ( initArityOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.DynFlags++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+  }
+ GHC/Driver/Config/Core/Opt/LiberateCase.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.LiberateCase+  ( initLiberateCaseOpts+  ) where++import GHC.Driver.DynFlags++import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) )++-- | Initialize configuration for the liberate case Core optimization+-- pass.+initLiberateCaseOpts :: DynFlags -> LibCaseOpts+initLiberateCaseOpts dflags = LibCaseOpts+  { lco_threshold = liberateCaseThreshold dflags+  , lco_unfolding_opts = unfoldingOpts dflags+  }
+ GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -0,0 +1,126 @@+module GHC.Driver.Config.Core.Opt.Simplify+  ( initSimplifyExprOpts+  , initSimplifyOpts+  , initSimplMode+  , initGentleSimplMode+  ) 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.DynFlags ( 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 InitialPhase "GHCi")+    { sm_inline = False+      -- 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 -> CompilerPhase -> String -> SimplMode+initSimplMode dflags phase name = SimplMode+  { sm_names = [name]+  , sm_phase = phase+  , sm_rules = gopt Opt_EnableRewriteRules dflags+  , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags+  , sm_cast_swizzle = True+  , sm_inline = True+  , sm_uf_opts = unfoldingOpts dflags+  , sm_case_case = True+  , sm_pre_inline = gopt Opt_SimplPreInlining dflags+  , sm_float_enable = floatEnable dflags+  , sm_do_eta_reduction = gopt Opt_DoEtaReduction 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+  }++initGentleSimplMode :: DynFlags -> SimplMode+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")+  { -- Don't do case-of-case transformations.+    -- This makes full laziness work better+    -- See Note [Case-of-case and full laziness]+    sm_case_case = False+  }++floatEnable :: DynFlags -> FloatEnable+floatEnable dflags =+  case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of+    (True, True) -> FloatEnabled+    (True, False)-> FloatNestedOnly+    (False, _)   -> FloatDisabled+++{- Note [Case-of-case and full laziness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case-of-case can hide opportunities for let-floating (full laziness).+For example+   rec { f = \y. case (expensive x) of (a,b) -> blah }+We might hope to float the (expensive x) out of the \y-loop.+But if we inline `expensive` we might get+   \y. case (case x of I# x' -> body) of (a,b) -> blah+Now if we do case-of-case we get+   \y. case x if I# x2 ->+       case body of (a,b) -> blah++Sadly, at this point `body` mentions `x2`, so we can't float it out of the+\y-loop.++Solution: don't do case-of-case in the "gentle" simplification phase that+precedes the first float-out transformation.  Implementation:++  * `sm_case_case` field in SimplMode++  * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case+    in GHC.Core.Opt.Simplify.Iteration.rebuildCall.++Wrinkles++* This applies equally to the case-of-runRW# transformation:+    case (runRW# (\s. body)) of (a,b) -> blah+    --->+    runRW# (\s. case body of (a,b) -> blah)+  Again, don't do this when `sm_case_case` is off.  See #25055 for+  a motivating example.+-}
+ GHC/Driver/Config/Core/Opt/WorkWrap.hs view
@@ -0,0 +1,21 @@+module GHC.Driver.Config.Core.Opt.WorkWrap+  ( initWorkWrapOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.Config (initSimpleOpts)+import GHC.Driver.DynFlags++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+  }
+ GHC/Driver/Config/Core/Rules.hs view
@@ -0,0 +1,19 @@+module GHC.Driver.Config.Core.Rules+  ( initRuleOpts+  ) where++import GHC.Prelude++import GHC.Driver.Flags+import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform )++import GHC.Core.Rules.Config++-- | Initialize RuleOpts from DynFlags+initRuleOpts :: DynFlags -> RuleOpts+initRuleOpts dflags = RuleOpts+  { roPlatform                = targetPlatform dflags+  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags+  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+  , roBignumRules             = True+  }
+ GHC/Driver/Config/CoreToStg.hs view
@@ -0,0 +1,16 @@+module GHC.Driver.Config.CoreToStg where++import GHC.Driver.Config.Stg.Debug+import GHC.Driver.DynFlags++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+  }
+ GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -0,0 +1,35 @@+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.Driver.Config.Core.Opt.Arity+import GHC.Types.Var+import GHC.Utils.Outputable ( alwaysQualify )++import GHC.CoreToStg.Prep++initCorePrepConfig :: HscEnv -> IO CorePrepConfig+initCorePrepConfig hsc_env = do+   let dflags = hsc_dflags hsc_env+   return $ CorePrepConfig+      { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags+      , cp_platform  = targetPlatform dflags+      , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags+                       then Just (initArityOpts dflags)+                       else Nothing+      , cp_specEval  = gopt Opt_SpecEval dflags+      , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags+      }++initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig+initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig+  { cpPgm_endPassConfig     = initEndPassConfig dflags extra_vars alwaysQualify CorePrep+  , cpPgm_generateDebugInfo = needSourceNotes dflags+  }
+ GHC/Driver/Config/Diagnostic.hs view
@@ -0,0 +1,69 @@++-- | Functions for initialising error message printing configuration from the+-- GHC session flags.+module GHC.Driver.Config.Diagnostic+  ( initDiagOpts+  , initPrintConfig+  , initPsMessageOpts+  , initDsMessageOpts+  , initTcMessageOpts+  , initDriverMessageOpts+  , initIfaceMessageOpts+  )+where++import GHC.Driver.Flags+import GHC.Driver.DynFlags+import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Utils.Error (DiagOpts (..))+import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage)+import GHC.Driver.Errors.Ppr () -- Diagnostic instances+import GHC.Tc.Errors.Types+import GHC.HsToCore.Errors.Types+import GHC.Types.Error+import GHC.Iface.Errors.Types++-- | Initialise the general configuration for printing diagnostic messages+-- For example, this configuration controls things like whether warnings are+-- treated like errors.+initDiagOpts :: DynFlags -> DiagOpts+initDiagOpts dflags = DiagOpts+  { diag_warning_flags       = warningFlags dflags+  , diag_fatal_warning_flags = fatalWarningFlags dflags+  , diag_custom_warning_categories = customWarningCategories dflags+  , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags+  , diag_warn_is_error       = gopt Opt_WarnIsError dflags+  , diag_reverse_errors      = reverseErrors dflags+  , diag_max_errors          = maxErrors dflags+  , diag_ppr_ctx             = initSDocContext dflags defaultErrStyle+  }++-- | Initialise the configuration for printing specific diagnostic messages+initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage+initPrintConfig dflags =+  GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags+                 , tcMessageOpts = initTcMessageOpts dflags+                 , dsMessageOpts = initDsMessageOpts dflags+                 , driverMessageOpts= initDriverMessageOpts dflags }++initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage+initPsMessageOpts _ = NoDiagnosticOpts++initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage+initTcMessageOpts dflags =+  TcRnMessageOpts { tcOptsShowContext    = gopt Opt_ShowErrorContext dflags+                  , tcOptsIfaceOpts      = initIfaceMessageOpts dflags }++initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage+initDsMessageOpts _ = NoDiagnosticOpts++initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage+initIfaceMessageOpts dflags =+                  IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3+                                   , ifaceBuildingCabalPackage = checkBuildingCabalPackage dflags }++initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage+initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags)+
+ GHC/Driver/Config/Finder.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.Finder (+    FinderOpts(..),+    initFinderOpts+  ) where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Unit.Finder.Types+import GHC.Data.FastString+import GHC.Data.OsPath+import qualified Data.Map as Map++-- | Create a new 'FinderOpts' from DynFlags.+initFinderOpts :: DynFlags -> FinderOpts+initFinderOpts flags = FinderOpts+  { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags+  , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)+  , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)+  , finder_ways = ways flags+  , finder_enableSuggestions = gopt Opt_HelpfulErrors flags+  , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags+  , finder_thisPackageName  = mkFastString <$> thisPackageName flags+  , finder_hiddenModules = hiddenModules flags+  , finder_reexportedModules = Map.fromList [(known_as, is_as) | ReexportedModule is_as known_as <- reverse (reexportedModules flags)]+  , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags+  , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags+  , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags+  , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags+  , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags+  , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags+  , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags+  , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags+  , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags+  }
+ GHC/Driver/Config/HsToCore.hs view
@@ -0,0 +1,19 @@+module GHC.Driver.Config.HsToCore+  ( initBangOpts+  )+where++import GHC.Types.Id.Make+import GHC.Driver.DynFlags+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-interface-pragmas as the indication+  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags+  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags+  }+
+ GHC/Driver/Config/HsToCore/Ticks.hs view
@@ -0,0 +1,34 @@+module GHC.Driver.Config.HsToCore.Ticks+  ( initTicksConfig+  , breakpointsAllowed+  )+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+  }++breakpointsAllowed :: DynFlags -> Bool+breakpointsAllowed dflags =+  gopt Opt_InsertBreakpoints dflags &&+  backendSupportsBreakpoints (backend dflags)++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags = catMaybes+  [ ifA Breakpoints $ breakpointsAllowed 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
+ GHC/Driver/Config/HsToCore/Usage.hs view
@@ -0,0 +1,14 @@+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)+  }
+ GHC/Driver/Config/Linker.hs view
@@ -0,0 +1,92 @@+module GHC.Driver.Config.Linker+  ( initFrameworkOpts+  , initLinkerConfig+  )+where++import GHC.Prelude+import GHC.Platform+import GHC.Linker.Config++import GHC.Driver.DynFlags+import GHC.Driver.Session++import Data.List (isPrefixOf)++initFrameworkOpts :: DynFlags -> FrameworkOpts+initFrameworkOpts dflags = FrameworkOpts+  { foFrameworkPaths    = frameworkPaths    dflags+  , foCmdlineFrameworks = cmdlineFrameworks dflags+  }++-- | Initialize linker configuration from DynFlags+initLinkerConfig :: DynFlags -> LinkerConfig+initLinkerConfig dflags =+  let+    -- see Note [Solaris linker]+    ld_filter = case platformOS (targetPlatform dflags) of+                  OSSolaris2 -> sunos_ld_filter+                  _          -> id+    sunos_ld_filter :: [String] -> [String]+    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++    -- program and arguments+    --+    -- `-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`.+    (p,pre_args) = pgm_l dflags+    post_args    = map Option (getOpts dflags opt_l)++  in LinkerConfig+    { linkerProgram     = p+    , linkerOptionsPre  = pre_args+    , linkerOptionsPost = post_args+    , linkerTempDir     = tmpDir dflags+    , linkerFilter      = ld_filter+    }++{- Note [Solaris linker]+   ~~~~~~~~~~~~~~~~~~~~~+  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.+-}+
+ GHC/Driver/Config/Logger.hs view
@@ -0,0 +1,32 @@+module GHC.Driver.Config.Logger+  ( initLogFlags+  )+where++import GHC.Prelude++import GHC.Driver.DynFlags++import GHC.Utils.Logger (LogFlags (..))+import GHC.Utils.Outputable++-- | Initialize LogFlags from DynFlags+initLogFlags :: DynFlags -> LogFlags+initLogFlags dflags = LogFlags+  { log_default_user_context = initSDocContext dflags defaultUserStyle+  , log_default_dump_context = initSDocContext dflags defaultDumpStyle+  , log_dump_flags           = dumpFlags dflags+  , log_show_caret           = gopt Opt_DiagnosticsShowCaret dflags+  , log_diagnostics_as_json  = gopt Opt_DiagnosticsAsJSON dflags+  , log_show_warn_groups     = gopt Opt_ShowWarnGroups dflags+  , log_enable_timestamps    = not (gopt Opt_SuppressTimestamps dflags)+  , log_dump_to_file         = gopt Opt_DumpToFile dflags+  , log_dump_dir             = dumpDir dflags+  , log_dump_prefix          = dumpPrefix dflags+  , log_dump_prefix_override = dumpPrefixForce dflags+  , log_with_ways            = gopt Opt_DumpWithWays dflags+  , log_enable_debug         = not (hasNoDebugOutput dflags)+  , log_verbosity            = verbosity dflags+  , log_ways                 = Just $ ways dflags+  }+
+ GHC/Driver/Config/Parser.hs view
@@ -0,0 +1,27 @@+module GHC.Driver.Config.Parser+  ( initParserOpts+  , supportedLanguagePragmas+  )+where++import GHC.Prelude+import GHC.Platform++import GHC.Driver.Session+import GHC.Driver.Config.Diagnostic++import GHC.Parser.Lexer++-- | Extracts the flags needed for parsing+initParserOpts :: DynFlags -> ParserOpts+initParserOpts =+  mkParserOpts+    <$> extensionFlags+    <*> initDiagOpts+    <*> safeImportsOn+    <*> gopt Opt_Haddock+    <*> gopt Opt_KeepRawTokenStream+    <*> const True -- use LINE/COLUMN to update the internal location++supportedLanguagePragmas :: DynFlags -> [String]+supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform
+ GHC/Driver/Config/Stg/Debug.hs view
@@ -0,0 +1,14 @@+module GHC.Driver.Config.Stg.Debug+  ( initStgDebugOpts+  ) where++import GHC.Stg.Debug++import GHC.Driver.DynFlags++-- | 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+  }
+ GHC/Driver/Config/Stg/Lift.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Stg.Lift+  ( initStgLiftConfig+  ) where++import GHC.Stg.Lift.Config++import GHC.Driver.DynFlags++initStgLiftConfig :: DynFlags -> StgLiftConfig+initStgLiftConfig dflags = StgLiftConfig+    { c_targetProfile      = targetProfile dflags+    , c_liftLamsRecArgs    = liftLamsRecArgs dflags+    , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags+    , c_liftLamsKnown      = liftLamsKnown dflags+    }
+ GHC/Driver/Config/Stg/Pipeline.hs view
@@ -0,0 +1,53 @@+module GHC.Driver.Config.Stg.Pipeline+  ( initStgPipelineOpts+  ) where++import GHC.Prelude++import Control.Monad (guard)++import GHC.Stg.Pipeline+import GHC.Stg.Utils++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Stg.Lift+import GHC.Driver.Config.Stg.Ppr+import GHC.Driver.DynFlags++-- | Initialize STG pretty-printing options from DynFlags+initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts+initStgPipelineOpts dflags for_bytecode =+  let !platform = targetPlatform dflags+      !ext_dyn_refs = gopt Opt_ExternalDynamicRefs dflags+  in StgPipelineOpts+    { stgPipeline_lint = do+        guard $ gopt Opt_DoStgLinting dflags+        Just $ initDiagOpts dflags+    , stgPipeline_pprOpts = initStgPprOpts dflags+    , stgPipeline_phases = getStgToDo for_bytecode dflags+    , stgPlatform = platform+    , stgPipeline_forBytecode = for_bytecode+    , stgPipeline_allowTopLevelConApp = allowTopLevelConApp platform ext_dyn_refs+    }++-- | 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
+ GHC/Driver/Config/Stg/Ppr.hs view
@@ -0,0 +1,13 @@+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+   }
+ GHC/Driver/Config/StgToCmm.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}++module GHC.Driver.Config.StgToCmm+  ( initStgToCmmConfig+  ) where++import GHC.Prelude.Basic++import GHC.StgToCmm.Config++import GHC.Cmm.MachOp ( FMASign(..))+import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Platform+import GHC.Platform.Profile+import GHC.Platform.Regs+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+  , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags+  , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags+  , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags+  , stgToCmmOrigThunkInfo = gopt Opt_OrigThunkInfo         dflags+  , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags+  , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags+  , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack 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+  , stgToCmmObjectDeterminism = gopt Opt_ObjectDeterminism dflags++  -- backend flags:++    -- LLVM, C, and some 32-bit NCG backends can also handle some 64-bit primops+  , stgToCmmAllowArith64              = w64 || not ncg || platformArch platform == ArchWasm32 || platformArch platform == ArchX86+  , stgToCmmAllowQuot64               = w64 || not ncg || platformArch platform == ArchWasm32+  , stgToCmmAllowQuotRemInstr         = ncg  && (x86ish || ppc)+  , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm+  , stgToCmmAllowFMAInstr =+      if+        | not (isFmaEnabled dflags)+        || not (ncg || llvm)+        -- If we're not using the native code generator or LLVM,+        -- fall back to the generic implementation.+        || platformArch platform == ArchWasm32+        -- WASM doesn't support native FMA instructions (at the time of writing).+        -> const False++        -- FNMSub and FNMAdd have different semantics on PowerPC,+        -- so we avoid using them.+        | ppc+        -> \ case { FMAdd -> True; FMSub -> True; _ -> False }++        | otherwise+        -> const True++  , stgToCmmAllowIntMul2Instr         = (ncg && (x86ish || aarch64)) || llvm+  , stgToCmmAllowWordMul2Instr        = (ncg && (x86ish || ppc || aarch64)) || llvm+  , stgToCmmAllowIntWord64X2MinMax    = (ncg && x86ish && isSse4_2Enabled dflags) || llvm+  -- SIMD flags+  , stgToCmmVecInstrsErr  = vec_err+  , stgToCmmAvx           = isAvxEnabled                   dflags+  , stgToCmmAvx2          = isAvx2Enabled                  dflags+  , stgToCmmAvx512f       = isAvx512fEnabled               dflags+  , stgToCmmTickyAP       = gopt Opt_Ticky_AP dflags+  -- See Note [Saving foreign call target to local]+  , stgToCmmSaveFCallTargetToLocal = any (callerSaves platform) $ activeStgRegs platform+  } where profile  = targetProfile dflags+          platform = profilePlatform profile+          bk_end  = backend dflags+          w64 = platformWordSize platform == PW8+          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)+          aarch64 = case platformArch platform of+                      ArchAArch64  -> True+                      _            -> False+          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
+ GHC/Driver/Config/StgToJS.hs view
@@ -0,0 +1,52 @@+module GHC.Driver.Config.StgToJS+  ( initStgToJSConfig+  , initJSLinkConfig+  )+where++import GHC.StgToJS.Types+import GHC.StgToJS.Linker.Types++import GHC.Driver.DynFlags+import GHC.Driver.Config.Linker++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+  , csPrettyRender    = gopt Opt_DisableJsMinifier dflags+  , 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+  , csLinkerConfig    = initLinkerConfig dflags+  }++-- | Default linker configuration+initJSLinkConfig :: DynFlags -> JSLinkConfig+initJSLinkConfig dflags = JSLinkConfig+  { lcNoJSExecutables = False+  , lcNoHsMain        = False+  , lcNoRts           = False+  , lcNoStats         = False+  , lcCombineAll      = True+  , lcForeignRefs     = True+  , lcForceEmccRts    = False+  , lcLinkCsources    = not (gopt Opt_DisableJsCsources dflags)+  }+
+ GHC/Driver/Config/Tidy.hs view
@@ -0,0 +1,64 @@+{-# 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.DynFlags+import GHC.Driver.Env+import GHC.Driver.Backend++import GHC.Core.Make (getMkStringIds)+import GHC.Builtin.Names+import GHC.Tc.Utils.Env (lookupGlobal)+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+                                 | gopt Opt_ExposeOverloadedUnfoldings dflags  -> ExposeOverloaded+                                 | otherwise                            -> ExposeSome+    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)+    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags+    , opt_static_ptr_opts   = static_ptr_opts+    , opt_keep_auto_rules   = gopt Opt_KeepAutoRules dflags+    }++initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts+initStaticPtrOpts hsc_env = do+  let dflags = hsc_dflags hsc_env++  mk_string <- getMkStringIds (fmap tyThingId . lookupGlobal hsc_env )+  static_ptr_info_datacon <- tyThingDataCon <$> lookupGlobal hsc_env staticPtrInfoDataConName+  static_ptr_datacon      <- tyThingDataCon <$> lookupGlobal hsc_env 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+    }
+ GHC/Driver/Downsweep.hs view
@@ -0,0 +1,1547 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Driver.Downsweep+  ( downsweep+  , downsweepThunk+  , downsweepInstalledModules+  , downsweepFromRootNodes+  , downsweepInteractiveImports+  , DownsweepMode(..)+   -- * Summary functions+  , summariseModule+  , summariseFile+  , summariseModuleInterface+  , SummariseResult(..)+  -- * Helper functions+  , instantiationNodes+  , checkHomeUnitsClosed+  ) where++import GHC.Prelude++import GHC.Platform.Ways++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Phases+import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess)+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.Messager+import GHC.Driver.MakeSem+import GHC.Driver.MakeAction+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Ppr++import GHC.Iface.Load++import GHC.Parser.Header+import GHC.Rename.Names+import GHC.Tc.Utils.Backpack+import GHC.Runtime.Context++import Language.Haskell.Syntax.ImpExp++import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import qualified GHC.Data.Maybe as M+import GHC.Data.OsPath     ( unsafeEncodeUtf )+import GHC.Data.StringBuffer+import GHC.Data.Graph.Directed.Reachability+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs+import GHC.Utils.Constants++import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.Map+import GHC.Types.PkgQual+import GHC.Types.Basic+++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.Module.Deps+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Module.Stage++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.Maybe+import Data.List (partition)+import Data.Time+import Data.List (unfoldr)+import Data.Bifunctor (first, bimap)+import System.Directory+import System.FilePath++import Control.Monad.Trans.Reader+import qualified Data.Map.Strict as M+import Control.Monad.Trans.Class+import System.IO.Unsafe (unsafeInterleaveIO)++{-+Note [Downsweep and the ModuleGraph]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModuleGraph stores the relationship between all the modules, units, and+instantiations in the current session.++When we do downsweep, we build up a new ModuleGraph, starting from the root+modules. By following all the dependencies we construct a graph which allows+us to answer questions about the transitive closure of the imports.++The module graph is accessible in the HscEnv.++When is this graph constructed?++1. In `--make` mode, we construct the graph before starting to do any compilation.++2. In `-c` (oneshot) mode, we construct the graph when we have calculated the+   ModSummary for the module we are compiling. The `ModuleGraph` is stored in a+   thunk, so it is only constructed when it is needed. This avoids reading+   the interface files of the whole transitive closure unless they are needed.++3. In some situations (such as loading plugins) we may need to construct the+   graph without having a ModSummary. In this case we use the `downsweepInstalledModules`+   function.++The result is having a uniform graph available for the whole compilation pipeline.++-}++-- 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 ModuleNodeInfo]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis) for --make mode+--+-- 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 ModuleGraph 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.+--+-- This function is intendned for use by --make mode and will also insert+-- LinkNodes and InstantiationNodes for any home units.+--+-- It will also turn on code generation for any modules that need it by calling+-- 'enableCodeGenForTH'.+downsweep :: HscEnv+          -> (GhcMessage -> AnyGhcDiagnostic)+          -> Maybe Messager+          -> [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], ModuleGraph)+                -- 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 diag_wrapper msg old_summaries excl_mods allow_dup_roots = do+  n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)+  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary+  let closure_errs = checkHomeUnitsClosed unit_env+      unit_env = hsc_unit_env hsc_env++      all_errs = closure_errs ++ root_errs++  case all_errs of+    [] -> do+       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []++       let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)++       let all_nodes = downsweep_nodes ++ unit_nodes+       let all_errs = downsweep_errs ++ other_errs++       let logger = hsc_logger hsc_env+           tmpfs = hsc_tmpfs hsc_env+       -- 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_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes++       return (all_errs, th_configured_nodes)+    _  -> return (all_errs, emptyMG)+  where+    summary = getRootSummary excl_mods old_summary_map++    -- A cache from file paths to the already summarised modules. The same file+    -- can be used in multiple units so the map is also keyed by which unit the+    -- file was used in.+    -- Reuse these if we can because the most expensive part of downsweep is+    -- reading the headers.+    old_summary_map :: M.Map (UnitId, FilePath) ModSummary+    old_summary_map =+      M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]++    -- Dependencies arising on a unit (backpack and module linking deps)+    unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+    unitModuleNodes summaries uid hue =+      maybeToList (linkNodes summaries uid hue)++-- | Calculate the module graph starting from a single ModSummary. The result is a+-- thunk, which when forced will perform the downsweep. This is useful in oneshot+-- mode where the module graph may never be needed.+-- If downsweep fails, then the resulting errors are just thrown.+downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph+downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."+  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []+  let dflags = hsc_dflags hsc_env+  liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                   (initPrintConfig dflags)+                                   (initDiagOpts dflags)+                                   (GhcDriverMessage <$> unionManyMessages errs)+  return (mkModuleGraph mg)++-- | Construct a module graph starting from the interactive context.+-- Produces, a thunk, which when forced will perform the downsweep.+-- This graph contains the current interactive module, and its dependencies.+--+--  Invariant: The hsc_mod_graph already contains the relevant home modules which+--  might be imported by the interactive imports.+--+-- This is a first approximation for this function. There probably should also+-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6+-- and so on)+-- See Note [runTcInteractive module graph]+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")+  let imps = ic_imports (hsc_IC hsc_env)++  let interactive_mn = icInteractiveModule ic+  -- No sensible value for ModLocation.. if you hit this panic then you probably+  -- need to add proper support for modules without any source files to the driver.+  let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)+  let key = moduleToMnk interactive_mn NotBoot+  let node_type = ModuleNodeFixed key ml++  -- The existing nodes in the module graph. This will be populated when GHCi runs+  -- :load. Any home package modules need to already be in here.+  let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]++  (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes+  let interactive_node = ModuleNode module_edges node_type++  let all_nodes  = M.elems graph+  return $ mkModuleGraph (interactive_node : all_nodes)++  where+ --+    mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))+    -- A simple edge to a module from the same home unit+    mkEdge (IIModule n) =+      let+        mod_node_key = ModNodeKeyWithUid+          { mnkModuleName = GWIB (moduleName n) NotBoot+          , mnkUnitId =+              -- 'toUnitId' is safe here, as we can't import modules that+              -- don't have a 'UnitId'.+              toUnitId (moduleUnit n)+          }+        mod_node_edge =+          ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key)+      in Left mod_node_edge+    -- A complete import statement+    mkEdge (IIDecl i) =+      let lvl = convImportLevel (ideclLevelSpec i)+          wanted_mod = unLoc (ideclName i)+          is_boot = ideclSource i+          mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)+          unitId = homeUnitId $ hsc_home_unit hsc_env+      in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)++loopFromInteractive :: HscEnv+                    -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+                    -> M.Map NodeKey ModuleGraphNode+                    -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)+loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)+loopFromInteractive hsc_env (edge:edges) cached_nodes =+  case edge of+    Left edge -> do+        (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+        return (edge : edges, cached_nodes')+    Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do+      let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)+      let k _ loc mod =+            let key = moduleToMnk mod is_boot+            in return $ FoundHome (ModuleNodeFixed key loc)+      found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []+      case found of+        -- Case 1: Home modules have to already be in the cache.+        FoundHome (ModuleNodeFixed mod _) -> do+          let edge = ModuleNodeEdge lvl (NodeKey_Module mod)+          -- Note: Does not perform any further downsweep as the module must already be in the cache.+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+          return (edge : edges, cached_nodes')+        -- Case 2: External units may not be in the cache, if we haven't already initialised the+        -- module graph. We can construct the module graph for those here by calling loopUnit.+        External uid -> do+          let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+              cached_nodes' = loopUnit hsc_env' cached_nodes [uid]+              edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'+          return (edge : edges, cached_nodes')+        -- And if it's not found.. just carry on and hope.+        _ -> loopFromInteractive hsc_env edges cached_nodes+++-- | Create a module graph from a list of installed modules.+-- This is used by the loader when we need to load modules but there+-- isn't already an existing module graph. For example, when loading plugins+-- during initialisation.+--+-- If you call this function, then if the `Module` you request to downsweep can't+-- be found then this function will throw errors.+-- If you need to use this function elsewhere, then it would make sense to make it+-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit.+-- At the moment, it is overfitted for what `get_reachable_nodes` needs.+downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph+downsweepInstalledModules hsc_env mods = do+    let+        (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods+        installed_mods = map (fst . getModuleInstantiation) home_mods+        external_uids = map moduleUnitId external_mods++        process :: InstalledModule -> IO ModuleNodeInfo+        process i = do+          res <- findExactModule hsc_env i NotBoot+          case res of+            InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc+            -- It is an internal-ish error if this happens, since we any call to this function should+            -- already know that we can find the modules we need to load.+            _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i++    nodes <- mapM process installed_mods+    (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids++    -- Similarly here, we should really not get any errors, but print them out if we do.+    let dflags = hsc_dflags hsc_env+    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                     (initPrintConfig dflags)+                                     (initDiagOpts dflags)+                                     (GhcDriverMessage <$> unionManyMessages errs)++    return (mkModuleGraph mg)++++-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used+-- by --make mode, and fixed nodes by oneshot mode.+--+-- See Note [Module Types in the ModuleGraph] for the difference between the two.+data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed++-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root+-- 'UnitId's.+-- This function will start at the given roots, and traverse downwards to find+-- all the dependencies, all the way to the leaf units.+downsweepFromRootNodes :: HscEnv+                  -> M.Map (UnitId, FilePath) ModSummary+                  -> [ModuleName]+                  -> Bool+                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies+                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo+                  -> [UnitId] -- ^ The starting units+                  -> IO ([DriverMessages], [ModuleGraphNode])+downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids+   = do+       let root_map = mkRootMap root_nodes+       checkDuplicates root_map+       let env = DownsweepEnv hsc_env mode old_summaries excl_mods+       (deps', map0) <- runDownsweepM env  $ do+                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)+                    let all_deps = loopUnit hsc_env module_deps root_uids+                    let all_instantiations =  getHomeUnitInstantiations hsc_env+                    deps' <- loopInstantiations all_instantiations all_deps+                    return (deps', map0)+++       let downsweep_errs = lefts $ concat $ M.elems map0+           downsweep_nodes = M.elems deps'++       return (downsweep_errs, downsweep_nodes)+     where+        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]+        getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++  instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)++        -- 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+           | not allow_dup_roots+           , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root+           | otherwise = pure ()+           where+             dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)+++calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+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, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++  [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]+++type DownsweepM a = ReaderT DownsweepEnv IO a+data DownsweepEnv = DownsweepEnv {+      downsweep_hsc_env :: HscEnv+    , _downsweep_mode :: DownsweepMode+    , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary+    , _downsweep_excl_mods :: [ModuleName]+}++runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a+runDownsweepM env act = runReaderT act env+++loopInstantiations :: [(UnitId, InstantiatedUnit)]+                   -> M.Map NodeKey ModuleGraphNode+                   -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopInstantiations [] done = pure done+loopInstantiations ((home_uid, iud) :xs) done = do+  hsc_env <- asks downsweep_hsc_env+  let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+  let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+      done' = loopUnit hsc_env' done [instUnitInstanceOf iud]+      payload = InstantiationNode home_uid iud+  loopInstantiations xs (M.insert (mkNodeKey payload) payload done')+++-- 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,+            DownsweepCache)+      -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)+loopSummaries [] done = pure done+loopSummaries (ms:next) (done, summarised)+  | Just {} <- M.lookup k done+  = loopSummaries next (done, summarised)+  -- Didn't work out what the imports mean yet, now do that.+  | otherwise = do+     (final_deps, 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 (ModuleNodeCompile ms)) done'', summarised'')+  where+    k = NodeKey_Module (msKey ms)++    hs_file_for_boot+      | HsBootFile <- ms_hsc_src ms+      = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+      | otherwise+      = Nothing++loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is++loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfo mod_node_info (done, summarised) = do+  case mod_node_info of+    ModuleNodeCompile ms -> do+      loopSummaries [ms] (done, summarised)+    ModuleNodeFixed mod ml -> do+      done' <- loopFixedModule mod ml done+      return (done', summarised)++-- NB: loopFixedModule does not take a downsweep cache, because if you+-- ever reach a Fixed node, everything under that also must be fixed.+loopFixedModule :: ModNodeKeyWithUid -> ModLocation+                -> M.Map NodeKey ModuleGraphNode+                -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedModule key loc done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> return done+    Nothing -> do+      -- MP: TODO, we should just read the dependency info from the interface rather than either+      -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)+      -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)+      read_result <- liftIO $+        -- 1. Check if the interface is already loaded into the EPS by some other+        -- part of the compiler.+        lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case+          Just iface -> return (M.Succeeded iface)+          Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)+      case read_result of+        M.Succeeded iface -> do+          -- Computer information about this node+          let node_deps = ifaceDeps (mi_deps iface)+              edges = map mkFixedEdge node_deps+              node = ModuleNode edges (ModuleNodeFixed key loc)+          foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)+        -- Ignore any failure, we might try to read a .hi-boot file for+        -- example, even if there is not one.+        M.Failed {} ->+          return done++loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM  (M.Map NodeKey ModuleGraphNode)+loopFixedNodeKey _ done (Left key) = do+  loopFixedImports [key] done+loopFixedNodeKey home_uid done (Right uid) = do+  -- Set active unit so that looking loopUnit finds the correct+  -- -package flags in the unit state.+  hsc_env <- asks downsweep_hsc_env+  let hsc_env' = hscSetActiveUnitId home_uid hsc_env+  return $ loopUnit hsc_env' done [uid]++mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)++ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]+ifaceDeps deps =+  [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)+  | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)+  ] +++  [ Right (tcImportLevel lvl, uid)+  | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)+  ]++-- Like loopImports, but we already know exactly which module we are looking for.+loopFixedImports :: [ModNodeKeyWithUid]+                 -> M.Map NodeKey ModuleGraphNode+                 -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedImports [] done = pure done+loopFixedImports (key:keys) done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> loopFixedImports keys done+    Nothing -> do+      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)+      case read_result of+        InstalledFound loc -> do+          done' <- loopFixedModule key loc done+          loopFixedImports keys done'+        _otherwise ->+          -- If the finder fails, just keep going, there will be another+          -- error later.+          loopFixedImports keys done++downsweepSummarise :: HomeUnit+                   -> IsBootInterface+                   -> Located ModuleName+                   -> PkgQual+                   -> Maybe (StringBuffer, UTCTime)+                   -> DownsweepM SummariseResult+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do+  DownsweepEnv hsc_env mode old_summaries excl_mods <- ask+  case mode of+    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods+    DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+++-- 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, ImportLevel, 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+     -> DownsweepM ([ModuleNodeEdge],+          M.Map NodeKey ModuleGraphNode, DownsweepCache)+                -- The result is the completed NodeMap+loopImports [] done summarised = return ([], done, summarised)+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised+  | Just summs <- M.lookup cache_key summarised+  = case summs of+      [Right ms] -> do+        let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))+        (rest, summarised', done') <- loopImports ss done summarised+        return (nk: rest, summarised', done')+      [Left _err] ->+        loopImports ss done summarised+      _errs ->  do+        loopImports ss done summarised+  | otherwise+  = do+       hsc_env <- asks downsweep_hsc_env+       let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+       mb_s <- downsweepSummarise home_unit+                               is_boot wanted_mod mb_pkg+                               Nothing+       case mb_s of+           NotThere -> loopImports ss done summarised+           External uid -> do+            -- Pass an updated hsc_env to loopUnit, as each unit might+            -- have a different visible package database.+            let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+            let done' = loopUnit hsc_env' done [uid]+            (other_deps, done'', summarised') <- loopImports ss done' summarised+            return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')+           FoundInstantiation iud -> do+            (other_deps, done', summarised') <- loopImports ss done summarised+            return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')+           FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)+           FoundHome s -> do+             (done', summarised') <-+               loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)+             (other_deps, 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 (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)+  where+    cache_key = (home_uid, mb_pkg, unLoc <$> gwib)+    GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib+    wanted_mod = L loc mod++loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode+loopUnit _ cache [] = cache+loopUnit lcl_hsc_env cache (u:uxs) = do+   let nk = (NodeKey_ExternalUnit u)+   case Map.lookup nk cache of+     Just {} -> loopUnit lcl_hsc_env cache uxs+     Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of+                 Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs+                 Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)++multiRootsErr :: [ModuleNodeInfo] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+  where+    mod = moduleNodeInfoModule summ1+    files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs++moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages+moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod)++-- | 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.+instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]+instantiationNodes uid unit_state = map (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) . mgNodeUnitId) 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++getRootSummary ::+  [ModuleName] ->+  M.Map (UnitId, FilePath) ModSummary ->+  HscEnv ->+  Target ->+  IO (Either DriverMessages ModSummary)+getRootSummary excl_mods old_summary_map hsc_env target+  | TargetFile file mb_phase <- targetId+  = do+    let offset_file = augmentByWorkingDirectory dflags file+    exists <- liftIO $ doesFileExist offset_file+    if exists || isJust maybe_buf+    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+         maybe_buf+    else+      return $ Left $ singleMessage $+      mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+  | TargetModule modl <- targetId+  = do+    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+                     (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+                     maybe_buf excl_mods+    pure case maybe_summary of+      FoundHome (ModuleNodeCompile s)  -> Right s+      FoundHomeWithError err -> Left (snd err)+      _ -> Left (moduleNotFoundErr uid modl)+    where+      Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target+      home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+      rootLoc = mkGeneralSrcSpan (fsLit "<command line>")+      dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))++-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline+-- system.+-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses+-- 'withAbstractSem' to wait for a free slot, limiting the number of+-- concurrently computed summaries to the value of the @-j@ option or the slots+-- allocated by the job server, if that is used.+--+-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because+-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the+-- result won't be read anyway here.+--+-- To emulate the current behavior, we funnel exceptions past the concurrency+-- barrier and rethrow the first one afterwards.+rootSummariesParallel ::+  WorkerLimit ->+  HscEnv ->+  (GhcMessage -> AnyGhcDiagnostic) ->+  Maybe Messager ->+  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->+  IO ([DriverMessages], [ModSummary])+rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do+  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)+  runPipelines n_jobs hsc_env diag_wrapper msg actions+  (sequence . catMaybes <$> sequence get_results) >>= \case+    Right results -> pure (partitionEithers (concat results))+    Left exc -> throwIO exc+  where+    bundles = mk_bundles targets++    mk_bundles = unfoldr \case+      [] -> Nothing+      ts -> Just (splitAt bundle_size ts)++    bundle_size = 20++    targets = hsc_targets hsc_env++    action_and_result (log_queue_id, ts) = do+      res_var <- liftIO newEmptyMVar+      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)++    action log_queue_id target_bundle = do+      env@MakeEnv {compile_sem} <- ask+      lift $ lift $+        withAbstractSem compile_sem $+        withLoggerHsc log_queue_id env \ lcl_hsc_env ->+          MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case+            Left e | Just (_ :: SomeAsyncException) <- fromException e ->+              throwIO e+            a -> pure a++-- | 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.+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+    | Set.null bad_unit_ids = []+    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]+  where+    home_id_set = HUG.allUnits $ ue_home_unit_graph ue+    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}+    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++    downwards_closure :: Graph (Node UnitId UnitId)+    downwards_closure = graphFromEdgedVerticesUniq graphNodes++    inverse_closure = graphReachability $ transposeG downwards_closure++    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+    all_unit_direct_deps+      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C Set.union+             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)+             this_units = homeUnitEnv_units this_uis+             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go Set.empty home_id_set+      where+        go done todo+          = case Set.minView todo of+              Nothing -> []+              Just (uid, todo')+                | Set.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends Set.\\ done) `Set.union` todo'+                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''++-- | 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 ModuleGraph+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 ModuleGraph+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do+  mgMapM enable_code_gen mg+  where+    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)++    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo+    enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms+    enable_code_gen m@(ModuleNodeFixed {}) = return m++    -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.+    -- It would be good to consider how to make these checks more uniform and not duplicated.+    enable_code_gen_ms :: ModSummary -> IO ModSummary+    enable_code_gen_ms ms+      | ModSummary+        { ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , Just enable_spec <- needs_codegen_map ms =+      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 (unsafeEncodeUtf tn, unsafeEncodeUtf 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_ospath ms_location, ml_dyn_hi_file_ospath ms_location)+                               , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath 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_ospath = hi_file+                                     , ml_obj_file_ospath = o_file+                                     , ml_dyn_hi_file_ospath = dyn_hi_file+                                     , ml_dyn_obj_file_ospath = dyn_o_file }+                     , ms_hspp_opts = updOptLevel 0 $ new_dflags+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms 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_ms 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_ms 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_ms ms'++         | needs_full_ways dflags -> do+               let ms' = ms { ms_hspp_opts = set_full_ways dflags }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         | otherwise -> return ms++    enable_code_gen_ms 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.+    -- FIXME: Duplicated from makeDynFlagsConsistent+    dynamic_too_enable enable_spec ms+      | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags =+          not isDynWay && not dyn_too_enabled+            && enable_object+      | otherwise =+          hostIsDynamic && not hostIsProfiled && 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 = mkModuleGraph mod_graph++    (td_map, lookup_node) = mkStageDeps mod_graph++    queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns)++    -- NB: Do not inline these, it is very important to share them across all calls+    -- to needs_obj_set and needs_bc_set.+    !query_obj =+      let !deps = queryReachable need_obj_set+      in \k -> deps (expectJust $ lookup_node k)++    !query_bc  =+      let !deps = queryReachable need_bc_set+      in \k -> deps (expectJust $ lookup_node k)++    -- The direct dependencies of modules which require object code+    need_obj_set =++        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only+        -- it's dependencies.+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile 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 =+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)+        ]++    needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool+    needs_obj_set k = query_obj (NodeKey_Module k, CompileStage)++    needs_bc_set k = query_bc  (NodeKey_Module k, CompileStage)++    -- A map which tells us how to enable code generation for a NodeKey+    needs_codegen_map :: ModSummary -> Maybe CodeGenEnable+    needs_codegen_map ms =+      let nk = msKey ms+++      -- Another option here would be to just produce object code, rather than both object and+      -- byte code+      in case (needs_obj_set nk, needs_bc_set nk) of+        (True, True)   -> Just EnableByteCodeAndObject+        (True, False)  -> Just EnableObject+        (False, True)  -> Just EnableByteCode+        (False, False) -> Nothing++    -- FIXME: Duplicated from makeDynFlagsConsistent+    needs_full_ways dflags+      = ghcLink dflags == LinkInMemory &&+        not (gopt Opt_ExternalInterpreter dflags) &&+        targetWays_ dflags /= hostFullWays+    set_full_ways dflags =+        let platform = targetPlatform dflags+            dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++{- 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, there would be no need for -fwrite-interface as it+would 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.++Explicit Level Imports+~~~~~~~~~~~~~~~~~~~~~~+When `-XExplicitLevelImports` is enabled, code is only generated for modules+needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers+the question, if I compile a module for a specific stage, then which modules at+other stages do I need. The roots of this query are the modules which use `TemplateHaskell`+at the runtime stage, and modules we need code generation for are those which+are needed at the compile time stage. All the logic about how ExplicitLevelImports+and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps.++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 (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays')+* 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.+-}++-- | Populate the Downsweep cache with the root modules.+mkRootMap+  :: [ModuleNodeInfo]+  -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+  [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib 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 (UnitId, 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,+   | Just old_summary <- M.lookup (homeUnitId home_unit, 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)+            (basename, extension) = splitExtension src_fn++            hsc_src+              | isHaskellSigSuffix (drop 1 extension) = HsigFile+              | isHaskellBootSuffix (drop 1 extension) = HsBootFile+              | otherwise = HsSrcFile++            -- Make a ModLocation for this file, adding the @-boot@ suffix to+            -- all paths if the original was a boot file.+            location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src++        -- 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 hsc_src++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_hsc_src = hsc_src+            , 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.+           let fc      = hsc_FC hsc_env+               mod     = ms_mod old_summary+               hsc_src = ms_hsc_src old_summary+           addModuleToFinder fc mod location hsc_src++           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 ModuleNodeInfo+      | External UnitId+      | NotThere++-- | summariseModule finds the location of the source file for the given module.+-- This version always returns a ModuleNodeCompile node, it is useful for+-- --make mode.+summariseModule :: HscEnv+                -> HomeUnit+                -> M.Map (UnitId, FilePath) ModSummary+                -> IsBootInterface+                -> Located ModuleName+                -> PkgQual+                -> Maybe (StringBuffer, UTCTime)+                -> [ModuleName]+                -> IO SummariseResult+summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf+++-- | Like summariseModule but for interface files that we don't want to compile.+-- This version always returns a ModuleNodeFixed node.+summariseModuleInterface :: HscEnv+                        -> HomeUnit+                        -> IsBootInterface+                        -> Located ModuleName+                        -> PkgQual+                        -> [ModuleName]+                        -> IO SummariseResult+summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k _hsc_env loc mod = do+      -- The finder will return a path to the .hi-boot even if it doesn't actually+      -- exist. So check if it exists first before concluding it's there.+      does_exist <- doesFileExist (ml_hi_file loc)+      if does_exist+        then let key = moduleToMnk mod is_boot+             in return $ FoundHome (ModuleNodeFixed key loc)+        else return NotThere++++-- Summarise a module, and pick up source and timestamp.+summariseModuleDispatch+          :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.+          -> HscEnv+          -> HomeUnit+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> PkgQual+          -> [ModuleName]               -- Modules to exclude+          -> IO SummariseResult+++summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg 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'++    find_it :: IO SummariseResult++    find_it = do+        found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg+        case found of+             Found location mod+                | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->+                        -- Home package+                         k hsc_env 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)+++-- | The continuation to summarise a home module if we want to find the source file+-- for it and potentially compile it.+summariseModuleWithSource+          :: HomeUnit+          -> M.Map (UnitId, FilePath) ModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Maybe (StringBuffer, UTCTime)+          -> HscEnv+          -> ModLocation+          -> Module+          -> IO SummariseResult+summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do+        -- Adjust location to point to the hs-boot source file,+        -- hi file, object file, when is_boot says so+        let src_fn = expectJust (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 (ModuleNodeCompile ms)++  where+    dflags    = hsc_dflags hsc_env+    new_summary_cache_check loc mod src_fn h+      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), 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 /= moduleName mod) $+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName 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_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_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_textual_imps =+            ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) +++            ((,,) NormalLevel 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  :: [Located ModuleName]+      , pi_theimps  :: [(ImportLevel, PkgQual, Located ModuleName)]+      , 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', 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 (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))+  let pi_srcimps = pi_srcimps'+  let pi_theimps = rn_imps pi_theimps'+  return PreprocessedImports {..}
+ GHC/Driver/DynFlags.hs view
@@ -0,0 +1,1581 @@+{-# LANGUAGE LambdaCase #-}+module GHC.Driver.DynFlags (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset,+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        ways,+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        positionIndependent,+        optimisationFlags,++        targetProfile,++        ReexportedModule(..),++        -- ** Manipulating DynFlags+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        optLevelFlags,+        languageExtensions,++        TurnOnFlag,+        turnOn,+        turnOff,++        -- ** System tool settings and locations+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir, toolDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,++        --+        baseUnitId,+++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,++        -- * Platform features+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,+        isBmiEnabled,+        isBmi2Enabled+) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile++import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Unfold+import GHC.Data.Bool+import GHC.Data.EnumSet (EnumSet)+import GHC.Data.Maybe+import GHC.Builtin.Names ( mAIN_NAME )+import GHC.Driver.Backend+import GHC.Driver.Flags+import GHC.Driver.IncludeSpecs+import GHC.Driver.Phases ( Phase(..), phaseInputExt )+import GHC.Driver.Plugins.External+import GHC.Settings+import GHC.Settings.Constants+import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )+import GHC.Types.Error (DiagnosticReason(..))+import GHC.Types.ProfAuto+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Utils.CliOption+import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )+import GHC.UniqueSubdir (uniqueSubdir)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.TmpFs++import qualified GHC.Types.FieldLabel as FieldLabel+import qualified GHC.Utils.Ppr.Colour as Col+import qualified GHC.Data.EnumSet as EnumSet++import GHC.Core.Opt.CallerCC.Types++import Control.Monad (msum, (<=<))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Writer (WriterT)+import Data.Word+import System.IO+import System.IO.Error (catchIOError)+import System.Environment (lookupEnv)+import System.FilePath (normalise, (</>))+import System.Directory+import GHC.Foreign (withCString, peekCString)++import qualified Data.Set as Set++import qualified GHC.LanguageExtensions as LangExt++-- -----------------------------------------------------------------------------+-- DynFlags++-- | Contains not only a collection of 'GeneralFlag's but also a plethora of+-- information relating to the compilation of a single file or GHC session+data DynFlags = DynFlags {+  ghcMode               :: GhcMode,+  ghcLink               :: GhcLink,+  backend               :: !Backend,+   -- ^ The backend to use (if any).+   --+   -- Whenever you change the backend, also make sure to set 'ghcLink' to+   -- something sensible.+   --+   -- 'NoBackend' can be used to avoid generating any output, however, note that:+   --+   --  * If a program uses Template Haskell the typechecker may need to run code+   --    from an imported module.  To facilitate this, code generation is enabled+   --    for modules imported by modules that use template haskell, using the+   --    default backend for the platform.+   --    See Note [-fno-code mode].+++  -- formerly Settings+  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,+  fileSettings      :: {-# UNPACK #-} !FileSettings,+  unitSettings      :: {-# UNPACK #-} !UnitSettings,++  targetPlatform    :: Platform,       -- Filled in by SysTools+  toolSettings      :: {-# UNPACK #-} !ToolSettings,+  platformMisc      :: {-# UNPACK #-} !PlatformMisc,+  rawSettings       :: [(String, String)],+  tmpDir            :: TempDir,++  llvmOptLevel          :: Int,         -- ^ LLVM optimisation level+  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]+  debugLevel            :: Int,         -- ^ How much debug information to produce+  simplPhases           :: Int,         -- ^ Number of simplifier phases+  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations+  ruleCheck             :: Maybe String,+  strictnessBefore      :: [Int],       -- ^ Additional demand analysis++  parMakeCount          :: Maybe ParMakeCount,+    -- ^ The number of modules to compile in parallel+    --   If unspecified, compile with a single job.++  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?+  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.++  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt+                                        --   to show in type error messages+  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show+                                        --   in typed hole error messages+  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole+                                        --   fits to show in typed hole error+                                        --   messages+  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for+                                        --   refinement hole fits in typed hole+                                        --   error messages+  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show+                                        --   in non-exhaustiveness warnings+  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models+                                        --   the pattern match checker checks+                                        --   a pattern against. A safe guard+                                        --   against exponential blow-up.+  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks+  dmdUnboxWidth         :: !Int,        -- ^ Whether DmdAnal should optimistically put an+                                        --   Unboxed demand on returned products with at most+                                        --   this number of fields+  ifCompression         :: Int,+  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr+  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function+  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types+                                        --   Not optional; otherwise ForceSpecConstr can diverge.+  binBlobThreshold      :: Maybe Word,  -- ^ Binary literals (e.g. strings) whose size is above+                                        --   this threshold will be dumped in a binary file+                                        --   by the assembler code generator. 0 and Nothing disables+                                        --   this feature. See 'GHC.StgToCmm.Config'.+  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase+  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating+                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'++  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   recursive function.+  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   non-recursive function.+  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call+                                        --   into an unknown call.++  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.++  historySize           :: Int,         -- ^ Simplification history size++  importPaths           :: [FilePath],+  mainModuleNameIs      :: ModuleName,+  mainFunIs             :: Maybe String,+  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth+  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver+                                         --   Typically only 1 is needed+  givensFuel            :: Int,          -- ^ Number of layers of superclass expansion for givens+                                         --   Should be < solverIterations+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  wantedsFuel           :: Int,          -- ^ Number of layers of superclass expansion for wanteds+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  qcsFuel                :: Int,          -- ^ Number of layers of superclass expansion for quantified constraints+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  homeUnitId_             :: UnitId,                 -- ^ Target home unit-id+  homeUnitInstanceOf_     :: Maybe UnitId,           -- ^ Id of the unit to instantiate+  homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations++  -- Note [Filepaths and Multiple Home Units]+  workingDirectory      :: Maybe FilePath,+  thisPackageName       :: Maybe String, -- ^ What the package is called, use with multiple home units+  hiddenModules         :: Set.Set ModuleName,+  reexportedModules     :: [ReexportedModule],++  -- ways+  targetWays_           :: Ways,         -- ^ Target way flags from the command line++  -- For object splitting+  splitInfo             :: Maybe (String,Int),++  -- paths etc.+  objectDir             :: Maybe String,+  dylibInstallName      :: Maybe String,+  hiDir                 :: Maybe String,+  hieDir                :: Maybe String,+  stubDir               :: Maybe String,+  dumpDir               :: Maybe String,++  objectSuf_            :: String,+  hcSuf                 :: String,+  hiSuf_                :: String,+  hieSuf                :: String,++  dynObjectSuf_         :: String,+  dynHiSuf_             :: String,++  outputFile_           :: Maybe String,+  dynOutputFile_        :: Maybe String,+  outputHi              :: Maybe String,+  dynOutputHi           :: Maybe String,+  dynLibLoader          :: DynLibLoader,++  dynamicNow            :: !Bool, -- ^ Indicate if we are now generating dynamic output+                                  -- because of -dynamic-too. This predicate is+                                  -- used to query the appropriate fields+                                  -- (outputFile/dynOutputFile, ways, etc.)++  -- | This defaults to 'non-module'. It can be set by+  -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on+  -- where its output is going.+  dumpPrefix            :: FilePath,++  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix'+  --    or 'ghc.GHCi.UI.runStmt'.+  --    Set by @-ddump-file-prefix@+  dumpPrefixForce       :: Maybe FilePath,++  ldInputs              :: [Option],++  includePaths          :: IncludeSpecs,+  libraryPaths          :: [String],+  frameworkPaths        :: [String],    -- used on darwin only+  cmdlineFrameworks     :: [String],    -- ditto++  rtsOpts               :: Maybe String,+  rtsOptsEnabled        :: RtsOptsEnabled,+  rtsOptsSuggestions    :: Bool,++  hpcDir                :: String,      -- ^ Path to store the .mix files++  -- Plugins+  pluginModNames        :: [ModuleName],+    -- ^ the @-fplugin@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.+  pluginModNameOpts     :: [(ModuleName,String)],+  frontendPluginOpts    :: [String],+    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.++  externalPluginSpecs   :: [ExternalPluginSpec],+    -- ^ External plugins loaded from shared libraries++  --  For ghc -M+  depMakefile           :: FilePath,+  depIncludePkgDeps     :: Bool,+  depIncludeCppDeps     :: Bool,+  depExcludeMods        :: [ModuleName],+  depSuffixes           :: [String],++  --  Package flags+  packageDBFlags        :: [PackageDBFlag],+        -- ^ The @-package-db@ flags given on the command line, In+        -- *reverse* order that they're specified on the command line.+        -- This is intended to be applied with the list of "initial"+        -- package databases derived from @GHC_PACKAGE_PATH@; see+        -- 'getUnitDbRefs'.++  ignorePackageFlags    :: [IgnorePackageFlag],+        -- ^ The @-ignore-package@ flags from the command line.+        -- In *reverse* order that they're specified on the command line.+  packageFlags          :: [PackageFlag],+        -- ^ The @-package@ and @-hide-package@ flags from the command-line.+        -- In *reverse* order that they're specified on the command line.+  pluginPackageFlags    :: [PackageFlag],+        -- ^ The @-plugin-package-id@ flags from command line.+        -- In *reverse* order that they're specified on the command line.+  trustFlags            :: [TrustFlag],+        -- ^ The @-trust@ and @-distrust@ flags.+        -- In *reverse* order that they're specified on the command line.+  packageEnv            :: Maybe FilePath,+        -- ^ Filepath to the package environment file (if overriding default)+++  -- hsc dynamic flags+  dumpFlags             :: EnumSet DumpFlag,+  generalFlags          :: EnumSet GeneralFlag,+  warningFlags          :: EnumSet WarningFlag,+  fatalWarningFlags     :: EnumSet WarningFlag,+  customWarningCategories      :: WarningCategorySet, -- See Note [Warning categories]+  fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings+  -- Don't change this without updating extensionFlags:+  language              :: Maybe Language,+  -- | Safe Haskell mode+  safeHaskell           :: SafeHaskellMode,+  safeInfer             :: Bool,+  safeInferred          :: Bool,+  -- We store the location of where some extension and flags were turned on so+  -- we can produce accurate error messages when Safe Haskell fails due to+  -- them.+  thOnLoc               :: SrcSpan,+  newDerivOnLoc         :: SrcSpan,+  deriveViaOnLoc        :: SrcSpan,+  overlapInstLoc        :: SrcSpan,+  incoherentOnLoc       :: SrcSpan,+  pkgTrustOnLoc         :: SrcSpan,+  warnSafeOnLoc         :: SrcSpan,+  warnUnsafeOnLoc       :: SrcSpan,+  trustworthyOnLoc      :: SrcSpan,+  -- Don't change this without updating extensionFlags:+  -- Here we collect the settings of the language extensions+  -- from the command line, the ghci config file and+  -- from interactive :set / :seti commands.+  extensions            :: [OnOff LangExt.Extension],+  -- extensionFlags should always be equal to+  --     flattenExtensionFlags language extensions+  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used+  -- by template-haskell+  extensionFlags        :: EnumSet LangExt.Extension,++  -- | Unfolding control+  -- See Note [Discounts and thresholds] in GHC.Core.Unfold+  unfoldingOpts         :: !UnfoldingOpts,++  maxWorkerArgs         :: Int,+  maxForcedSpecArgs     :: Int,++  ghciHistSize          :: Int,++  -- wasm ghci browser mode+  ghciBrowserHost                  :: !String,+  ghciBrowserPort                  :: !Int,+  ghciBrowserPuppeteerLaunchOpts   :: !(Maybe String),+  ghciBrowserPlaywrightBrowserType :: !(Maybe String),+  ghciBrowserPlaywrightLaunchOpts  :: !(Maybe String),++  flushOut              :: FlushOut,++  ghcVersionFile        :: Maybe FilePath,+  haddockOptions        :: Maybe String,++  -- | GHCi scripts specified by -ghci-script, in reverse order+  ghciScripts           :: [String],++  -- Output style options+  pprUserLength         :: Int,+  pprCols               :: Int,++  useUnicode            :: Bool,+  useColor              :: OverridingBool,+  canUseColor           :: Bool,+  useErrorLinks         :: OverridingBool,+  canUseErrorLinks      :: Bool,+  colScheme             :: Col.Scheme,++  -- | what kind of {-# SCC #-} to add automatically+  profAuto              :: ProfAuto,+  callerCcFilters       :: [CallerCcFilter],++  interactivePrint      :: Maybe String,++  -- | Machine dependent flags (-m\<blah> stuff)+  sseVersion            :: Maybe SseVersion,+  bmiVersion            :: Maybe BmiVersion,+  avx                   :: Bool,+  avx2                  :: Bool,+  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.+  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.+  avx512f               :: Bool, -- Enable AVX-512 instructions.+  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.+  fma                   :: Bool, -- ^ Enable FMA instructions.++  -- Constants used to control the amount of optimization done.++  -- | Max size, in bytes, of inline array allocations.+  maxInlineAllocSize    :: Int,++  -- | Only inline memcpy if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemcpyInsns  :: Int,++  -- | Only inline memset if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemsetInsns  :: Int,++  -- | Reverse the order of error messages in GHC/GHCi+  reverseErrors         :: Bool,++  -- | Limit the maximum number of errors to show+  maxErrors             :: Maybe Int,++  -- | Unique supply configuration for testing build determinism+  initialUnique         :: Word64,+  uniqueIncrement       :: Int,+    -- 'Int' because it can be used to test uniques in decreasing order.++  -- | Temporary: CFG Edge weights for fast iterations+  cfgWeights            :: Weights+}++class HasDynFlags m where+    getDynFlags :: m DynFlags++{- It would be desirable to have the more generalised++  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where+      getDynFlags = lift getDynFlags++instance definition. However, that definition would overlap with the+`HasDynFlags (GhcT m)` instance. Instead we define instances for a+couple of common Monad transformers explicitly. -}++instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where+    getDynFlags = lift getDynFlags++class ContainsDynFlags t where+    extractDynFlags :: t -> DynFlags++-----------------------------------------------------------------------------++-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value+initDynFlags :: DynFlags -> IO DynFlags+initDynFlags dflags = do+ let+ -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable,+ -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough.+ canUseUnicode <- do let enc = localeEncoding+                         str = "‘’"+                     (withCString enc str $ \cstr ->+                          do str' <- peekCString enc cstr+                             return (str == str'))+                         `catchIOError` \_ -> return False+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"+ let adjustCols (Just env) = Col.parseScheme env+     adjustCols Nothing    = id+ let (useColor', colScheme') =+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)+       (useColor dflags, colScheme dflags)+ tmp_dir <- normalise <$> getTemporaryDirectory+ return dflags{+        useUnicode    = useUnicode',+        useColor      = useColor',+        canUseColor   = stderrSupportsAnsiColors,+        -- if the terminal supports color, we assume it supports links as well+        canUseErrorLinks = stderrSupportsAnsiColors,+        colScheme     = colScheme',+        tmpDir        = TempDir tmp_dir+        }++-- | The normal 'DynFlags'. Note that they are not suitable for use in this form+-- and must be fully initialized by 'GHC.runGhc' first.+defaultDynFlags :: Settings -> DynFlags+defaultDynFlags mySettings =+-- See Note [Updating flag description in the User's Guide]+     DynFlags {+        ghcMode                 = CompManager,+        ghcLink                 = LinkBinary,+        backend                 = platformDefaultBackend (sTargetPlatform mySettings),+        verbosity               = 0,+        debugLevel              = 0,+        simplPhases             = 2,+        maxSimplIterations      = 4,+        ruleCheck               = Nothing,+        binBlobThreshold        = Just 500000, -- 500K is a good default (see #16190)+        maxRelevantBinds        = Just 6,+        maxValidHoleFits   = Just 6,+        maxRefHoleFits     = Just 6,+        refLevelHoleFits   = Nothing,+        maxUncoveredPatterns    = 4,+        maxPmCheckModels        = 30,+        simplTickFactor         = 100,+        dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple+        ifCompression           = 2,      -- Default: Apply safe compressions+        specConstrThreshold     = Just 2000,+        specConstrCount         = Just 3,+        specConstrRecursive     = 3,+        liberateCaseThreshold   = Just 2000,+        floatLamArgs            = Just 0, -- Default: float only if no fvs+        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones+        cmmProcAlignment        = Nothing,++        historySize             = 20,+        strictnessBefore        = [],++        parMakeCount            = Nothing,++        enableTimeStats         = False,+        ghcHeapSize             = Nothing,++        importPaths             = ["."],+        mainModuleNameIs        = mAIN_NAME,+        mainFunIs               = Nothing,+        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,+        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,+        givensFuel              = mAX_GIVENS_FUEL,+        wantedsFuel             = mAX_WANTEDS_FUEL,+        qcsFuel                 = mAX_QC_FUEL,++        homeUnitId_             = mainUnitId,+        homeUnitInstanceOf_     = Nothing,+        homeUnitInstantiations_ = [],++        workingDirectory        = Nothing,+        thisPackageName         = Nothing,+        hiddenModules           = Set.empty,+        reexportedModules       = [],++        objectDir               = Nothing,+        dylibInstallName        = Nothing,+        hiDir                   = Nothing,+        hieDir                  = Nothing,+        stubDir                 = Nothing,+        dumpDir                 = Nothing,++        objectSuf_              = phaseInputExt StopLn,+        hcSuf                   = phaseInputExt HCc,+        hiSuf_                  = "hi",+        hieSuf                  = "hie",++        dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,+        dynHiSuf_               = "dyn_hi",+        dynamicNow              = False,++        pluginModNames          = [],+        pluginModNameOpts       = [],+        frontendPluginOpts      = [],++        externalPluginSpecs     = [],++        outputFile_             = Nothing,+        dynOutputFile_          = Nothing,+        outputHi                = Nothing,+        dynOutputHi             = Nothing,+        dynLibLoader            = SystemDependent,+        dumpPrefix              = "non-module.",+        dumpPrefixForce         = Nothing,+        ldInputs                = [],+        includePaths            = IncludeSpecs [] [] [],+        libraryPaths            = [],+        frameworkPaths          = [],+        cmdlineFrameworks       = [],+        rtsOpts                 = Nothing,+        rtsOptsEnabled          = RtsOptsSafeOnly,+        rtsOptsSuggestions      = True,++        hpcDir                  = ".hpc",++        packageDBFlags          = [],+        packageFlags            = [],+        pluginPackageFlags      = [],+        ignorePackageFlags      = [],+        trustFlags              = [],+        packageEnv              = Nothing,+        targetWays_             = Set.empty,+        splitInfo               = Nothing,++        ghcNameVersion = sGhcNameVersion mySettings,+        unitSettings   = sUnitSettings mySettings,+        fileSettings = sFileSettings mySettings,+        toolSettings = sToolSettings mySettings,+        targetPlatform = sTargetPlatform mySettings,+        platformMisc = sPlatformMisc mySettings,+        rawSettings = sRawSettings mySettings,++        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",++        llvmOptLevel            = 0,++        -- ghc -M values+        depMakefile       = "Makefile",+        depIncludePkgDeps = False,+        depIncludeCppDeps = False,+        depExcludeMods    = [],+        depSuffixes       = [],+        -- end of ghc -M values+        ghcVersionFile = Nothing,+        haddockOptions = Nothing,+        dumpFlags = EnumSet.empty,+        generalFlags = EnumSet.fromList (defaultFlags mySettings),+        warningFlags = EnumSet.fromList standardWarnings,+        fatalWarningFlags = EnumSet.empty,+        customWarningCategories = completeWarningCategorySet,+        fatalCustomWarningCategories = emptyWarningCategorySet,+        ghciScripts = [],+        language = Nothing,+        safeHaskell = Sf_None,+        safeInfer   = True,+        safeInferred = True,+        thOnLoc = noSrcSpan,+        newDerivOnLoc = noSrcSpan,+        deriveViaOnLoc = noSrcSpan,+        overlapInstLoc = noSrcSpan,+        incoherentOnLoc = noSrcSpan,+        pkgTrustOnLoc = noSrcSpan,+        warnSafeOnLoc = noSrcSpan,+        warnUnsafeOnLoc = noSrcSpan,+        trustworthyOnLoc = noSrcSpan,+        extensions = [],+        extensionFlags = flattenExtensionFlags Nothing [],++        unfoldingOpts = defaultUnfoldingOpts,+        maxWorkerArgs = 10,+        maxForcedSpecArgs = 333,+        -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5++        ghciHistSize = 50, -- keep a log of length 50 by default++        ghciBrowserHost = "127.0.0.1",+        ghciBrowserPort = 0,+        ghciBrowserPuppeteerLaunchOpts = Nothing,+        ghciBrowserPlaywrightBrowserType = Nothing,+        ghciBrowserPlaywrightLaunchOpts = Nothing,++        flushOut = defaultFlushOut,+        pprUserLength = 5,+        pprCols = 100,+        useUnicode = False,+        useColor = Auto,+        canUseColor = False,+        useErrorLinks = Auto,+        canUseErrorLinks = False,+        colScheme = Col.defaultScheme,+        profAuto = NoProfAuto,+        callerCcFilters = [],+        interactivePrint = Nothing,+        sseVersion = Nothing,+        bmiVersion = Nothing,+        avx = False,+        avx2 = False,+        avx512cd = False,+        avx512er = False,+        avx512f = False,+        avx512pf = False,+        -- Use FMA by default on AArch64+        fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64,++        maxInlineAllocSize = 128,+        maxInlineMemcpyInsns = 32,+        maxInlineMemsetInsns = 32,++        initialUnique = 0,+        uniqueIncrement = 1,++        reverseErrors = False,+        maxErrors     = Nothing,+        cfgWeights    = defaultWeights+      }++type FatalMessager = String -> IO ()++defaultFatalMessager :: FatalMessager+defaultFatalMessager = hPutStrLn stderr+++newtype FlushOut = FlushOut (IO ())++defaultFlushOut :: FlushOut+defaultFlushOut = FlushOut $ hFlush stdout++-- OnOffs accumulate in reverse order, so we use foldr in order to+-- process them in the right order+flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension+flattenExtensionFlags ml = foldr g defaultExtensionFlags+    where g (On f)  flags = EnumSet.insert f flags+          g (Off f) flags = EnumSet.delete f flags+          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)++-- -----------------------------------------------------------------------------+-- -jN++-- | The type for the -jN argument, specifying that -j on its own represents+-- using the number of machine processors.+data ParMakeCount+  -- | Use this many processors (@-j<n>@ flag).+  = ParMakeThisMany Int+  -- | Use parallelism with as many processors as possible (@-j@ flag without an argument).+  | ParMakeNumProcessors+  -- | Use the specific semaphore @<sem>@ to control parallelism (@-jsem <sem>@ flag).+  | ParMakeSemaphore FilePath++-- | The 'GhcMode' tells us whether we're doing multi-module+-- compilation (controlled via the "GHC" API) or one-shot+-- (single-module) compilation.  This makes a difference primarily to+-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for+-- imported modules, but in multi-module mode we look for source files+-- in order to check whether they need to be recompiled.+data GhcMode+  = CompManager         -- ^ @\-\-make@, GHCi, etc.+  | OneShot             -- ^ @ghc -c Foo.hs@+  | MkDepend            -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this+  deriving Eq++instance Outputable GhcMode where+  ppr CompManager = text "CompManager"+  ppr OneShot     = text "OneShot"+  ppr MkDepend    = text "MkDepend"++isOneShot :: GhcMode -> Bool+isOneShot OneShot = True+isOneShot _other  = False++-- | What to do in the link step, if there is one.+data GhcLink+  = NoLink              -- ^ Don't link at all+  | LinkBinary          -- ^ Link object code into a binary+  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both+                        --   bytecode and object code).+  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)+  | LinkStaticLib       -- ^ Link objects into a static lib+  | LinkMergedObj       -- ^ Link objects into a merged "GHCi object"+  deriving (Eq, Show)++isNoLink :: GhcLink -> Bool+isNoLink NoLink = True+isNoLink _      = False++-- | We accept flags which make packages visible, but how they select+-- the package varies; this data type reflects what selection criterion+-- is used.+data PackageArg =+      PackageArg String    -- ^ @-package@, by 'PackageName'+    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'+  deriving (Eq, Show)++instance Outputable PackageArg where+    ppr (PackageArg pn) = text "package" <+> text pn+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid++-- | Represents the renaming that may be associated with an exposed+-- package, e.g. the @rns@ part of @-package "foo (rns)"@.+--+-- Here are some example parsings of the package flags (where+-- a string literal is punned to be a 'ModuleName':+--+--      * @-package foo@ is @ModRenaming True []@+--      * @-package foo ()@ is @ModRenaming False []@+--      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@+--      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@+--      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@+data ModRenaming = ModRenaming {+    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?+    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope+                                               --   under name @n@.+  } deriving (Eq)+instance Outputable ModRenaming where+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)++-- | Flags for manipulating the set of non-broken packages.+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@+  deriving (Eq)++-- | Flags for manipulating package trust.+data TrustFlag+  = TrustPackage    String -- ^ @-trust@+  | DistrustPackage String -- ^ @-distrust@+  deriving (Eq)++-- | Flags for manipulating packages visibility.+data PackageFlag+  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@+  | HidePackage     String -- ^ @-hide-package@+  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged++data PackageDBFlag+  = PackageDB PkgDbRef+  | NoUserPackageDB+  | NoGlobalPackageDB+  | ClearPackageDBs+  deriving (Eq)++packageFlagsChanged :: DynFlags -> DynFlags -> Bool+packageFlagsChanged idflags1 idflags0 =+  packageFlags idflags1 /= packageFlags idflags0 ||+  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||+  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||+  trustFlags idflags1 /= trustFlags idflags0 ||+  packageDBFlags idflags1 /= packageDBFlags idflags0 ||+  packageGFlags idflags1 /= packageGFlags idflags0+ where+   packageGFlags dflags = map (`gopt` dflags)+     [ Opt_HideAllPackages+     , Opt_HideAllPluginPackages+     , Opt_AutoLinkPackages ]++instance Outputable PackageFlag where+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)+    ppr (HidePackage str) = text "-hide-package" <+> text str++data DynLibLoader+  = Deployable+  | SystemDependent+  deriving Eq++data RtsOptsEnabled+  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly+  | RtsOptsAll+  deriving (Show)++-- | Are we building with @-fPIE@ or @-fPIC@ enabled?+positionIndependent :: DynFlags -> Bool+positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags++-- Note [-dynamic-too business]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic+-- objects in a single run of the compiler: the pipeline is the same down to+-- Core optimisation, then the backend (from Core to object code) is executed+-- twice.+--+-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic+-- and dynamic loaded interfaces (#9176).+--+-- To make matters worse, we automatically enable -dynamic-too when some modules+-- need Template-Haskell and GHC is dynamically linked (cf+-- GHC.Driver.Pipeline.compileOne').+--+-- We used to try and fall back from a dynamic-too failure but this feature+-- didn't work as expected (#20446) so it was removed to simplify the+-- implementation and not obscure latent bugs.++data DynamicTooState+   = DT_Dont    -- ^ Don't try to build dynamic objects too+   | DT_OK      -- ^ Will still try to generate dynamic objects+   | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)+   deriving (Eq,Show,Ord)++dynamicTooState :: DynFlags -> DynamicTooState+dynamicTooState dflags+   | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont+   | dynamicNow dflags = DT_Dyn+   | otherwise = DT_OK++setDynamicNow :: DynFlags -> DynFlags+setDynamicNow dflags0 =+   dflags0+      { dynamicNow = True+      }++data PkgDbRef+  = GlobalPkgDb+  | UserPkgDb+  | PkgDbPath FilePath+  deriving Eq++++-- An argument to --reexported-module which can optionally specify a module renaming.+data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName+                                         , reexportTo   :: ModuleName+                                         }++instance Outputable ReexportedModule where+  ppr (ReexportedModule from to) =+    if from == to then ppr from+                  else ppr from <+> text "as" <+> ppr to++{- Note [Implicit include paths]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The compile driver adds the path to the folder containing the source file being+  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'+  that are used later to compute the interface file. Because of this,+  the flags fingerprint derived from these 'DynFlags' and recorded in the+  interface file will end up containing the absolute path to the source folder.++  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)+  store the build artifacts produced by a build BA for reuse in subsequent builds.++  Embedding source paths in interface fingerprints will thwart these attempts and+  lead to unnecessary recompilations when the source paths in BA differ from the+  source paths in subsequent builds.+ -}++hasPprDebug :: DynFlags -> Bool+hasPprDebug = dopt Opt_D_ppr_debug++hasNoDebugOutput :: DynFlags -> Bool+hasNoDebugOutput = dopt Opt_D_no_debug_output++hasNoStateHack :: DynFlags -> Bool+hasNoStateHack = gopt Opt_G_NoStateHack++hasNoOptCoercion :: DynFlags -> Bool+hasNoOptCoercion = gopt Opt_G_NoOptCoercion++-- | Test whether a 'DumpFlag' is set+dopt :: DumpFlag -> DynFlags -> Bool+dopt = getDumpFlagFrom verbosity dumpFlags++-- | Set a 'DumpFlag'+dopt_set :: DynFlags -> DumpFlag -> DynFlags+dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }++-- | Unset a 'DumpFlag'+dopt_unset :: DynFlags -> DumpFlag -> DynFlags+dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }++-- | Test whether a 'GeneralFlag' is set+--+-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)+-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables+-- Opt_SplitSections.+--+gopt :: GeneralFlag -> DynFlags -> Bool+gopt Opt_PIC dflags+   | dynamicNow dflags = True+gopt Opt_ExternalDynamicRefs dflags+   | dynamicNow dflags = True+gopt Opt_SplitSections dflags+   | dynamicNow dflags = False+gopt f dflags = f `EnumSet.member` generalFlags dflags++-- | Set a 'GeneralFlag'+gopt_set :: DynFlags -> GeneralFlag -> DynFlags+gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }++-- | Unset a 'GeneralFlag'+gopt_unset :: DynFlags -> GeneralFlag -> DynFlags+gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }++-- | Test whether a 'WarningFlag' is set+wopt :: WarningFlag -> DynFlags -> Bool+wopt f dflags  = f `EnumSet.member` warningFlags dflags++-- | Set a 'WarningFlag'+wopt_set :: DynFlags -> WarningFlag -> DynFlags+wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }++-- | Unset a 'WarningFlag'+wopt_unset :: DynFlags -> WarningFlag -> DynFlags+wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }++-- | Test whether a 'WarningFlag' is set as fatal+wopt_fatal :: WarningFlag -> DynFlags -> Bool+wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags++-- | Mark a 'WarningFlag' as fatal (do not set the flag)+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_set_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }++-- | Mark a 'WarningFlag' as not fatal+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }+++-- | Enable all custom warning categories.+wopt_set_all_custom :: DynFlags -> DynFlags+wopt_set_all_custom dfs+    = dfs{ customWarningCategories = completeWarningCategorySet }++-- | Disable all custom warning categories.+wopt_unset_all_custom :: DynFlags -> DynFlags+wopt_unset_all_custom dfs+    = dfs{ customWarningCategories = emptyWarningCategorySet }++-- | Mark all custom warning categories as fatal (do not set the flags).+wopt_set_all_fatal_custom :: DynFlags -> DynFlags+wopt_set_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = completeWarningCategorySet }++-- | Mark all custom warning categories as non-fatal.+wopt_unset_all_fatal_custom :: DynFlags -> DynFlags+wopt_unset_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = emptyWarningCategorySet }++-- | Set a custom 'WarningCategory'+wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) }++-- | Unset a custom 'WarningCategory'+wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as fatal (do not set the flag)+wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as not fatal+wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Are there any custom warning categories enabled?+wopt_any_custom :: DynFlags -> Bool+wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs))+++-- | Test whether a 'LangExt.Extension' is set+xopt :: LangExt.Extension -> DynFlags -> Bool+xopt f dflags = f `EnumSet.member` extensionFlags dflags++-- | Set a 'LangExt.Extension'+xopt_set :: DynFlags -> LangExt.Extension -> DynFlags+xopt_set dfs f+    = let onoffs = On f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Unset a 'LangExt.Extension'+xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags+xopt_unset dfs f+    = let onoffs = Off f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Set or unset a 'LangExt.Extension', unless it has been explicitly+--   set or unset before.+xopt_set_unlessExplSpec+        :: LangExt.Extension+        -> (DynFlags -> LangExt.Extension -> DynFlags)+        -> DynFlags -> DynFlags+xopt_set_unlessExplSpec ext setUnset dflags =+    let referedExts = stripOnOff <$> extensions dflags+        stripOnOff (On x)  = x+        stripOnOff (Off x) = x+    in+        if ext `elem` referedExts then dflags else setUnset dflags ext++xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields+xopt_DuplicateRecordFields dfs+  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields+  | otherwise                              = FieldLabel.NoDuplicateRecordFields++xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors+xopt_FieldSelectors dfs+  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors+  | otherwise                       = FieldLabel.NoFieldSelectors++lang_set :: DynFlags -> Maybe Language -> DynFlags+lang_set dflags lang =+   dflags {+            language = lang,+            extensionFlags = flattenExtensionFlags lang (extensions dflags)+          }++defaultFlags :: Settings -> [GeneralFlag]+defaultFlags settings+-- See Note [Updating flag description in the User's Guide]+  = [ Opt_AutoLinkPackages,+      Opt_DiagnosticsShowCaret,+      Opt_EmbedManifest,+      Opt_FamAppCache,+      Opt_GenManifest,+      Opt_GhciHistory,+      Opt_GhciSandbox,+      Opt_GhciDoLoadTargets,+      Opt_HelpfulErrors,+      Opt_KeepHiFiles,+      Opt_KeepOFiles,+      Opt_OmitYields,+      Opt_PrintBindContents,+      Opt_ProfCountEntries,+      Opt_SharedImplib,+      Opt_SimplPreInlining,+      Opt_VersionMacros,+      Opt_RPath,+      Opt_DumpWithWays,+      Opt_CompactUnwind,+      Opt_ShowErrorContext,+      Opt_SuppressStgReps,+      Opt_UnoptimizedCoreForInterpreter,+      Opt_SpecialiseIncoherents,+      Opt_WriteSelfRecompInfo+    ]++    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]+             -- The default -O0 options++    -- Default floating flags (see Note [RHS Floating])+    ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]++    ++ default_PIC platform++    ++ validHoleFitDefaults++    where platform = sTargetPlatform settings++-- | These are the default settings for the display and sorting of valid hole+--  fits in typed-hole error messages. See Note [Valid hole fits include ...]+ -- in the "GHC.Tc.Errors.Hole" module.+validHoleFitDefaults :: [GeneralFlag]+validHoleFitDefaults+  =  [ Opt_ShowTypeAppOfHoleFits+     , Opt_ShowTypeOfHoleFits+     , Opt_ShowProvOfHoleFits+     , Opt_ShowMatchesOfHoleFits+     , Opt_ShowValidHoleFits+     , Opt_SortValidHoleFits+     , Opt_SortBySizeHoleFits+     , Opt_ShowHoleConstraints ]++-- Note [When is StarIsType enabled]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The StarIsType extension determines whether to treat '*' as a regular type+-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType+-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is+-- enabled.+--+-- Programs that use TypeOperators might expect to repurpose '*' for+-- multiplication or another binary operation, but making TypeOperators imply+-- NoStarIsType caused too much breakage on Hackage.+--++--+-- Note [Documenting optimisation flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of flags enabled for particular optimisation levels+-- please remember to update the User's Guide. The relevant file is:+--+--   docs/users_guide/using-optimisation.rst+--+-- Make sure to note whether a flag is implied by -O0, -O or -O2.++optLevelFlags :: [([Int], GeneralFlag)]+-- Default settings of flags, before any command-line overrides+optLevelFlags -- see Note [Documenting optimisation flags]+  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)+    , ([1,2],   Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep]+    , ([0,1,2], Opt_DoEtaReduction)          -- See Note [Eta-reduction in -O0]+    , ([0,1,2], Opt_ProfManualCcs )+    , ([2], Opt_DictsStrict)++    , ([0],     Opt_IgnoreInterfacePragmas)+    , ([0],     Opt_OmitInterfacePragmas)++    , ([1,2],   Opt_CoreConstantFolding)++    , ([1,2],   Opt_CallArity)+    , ([1,2],   Opt_Exitification)+    , ([1,2],   Opt_CaseMerge)+    , ([1,2],   Opt_CaseFolding)+    , ([1,2],   Opt_CmmElimCommonBlocks)+    , ([2],     Opt_AsmShortcutting)+    , ([1,2],   Opt_CmmSink)+    , ([1,2],   Opt_CmmStaticPred)+    , ([1,2],   Opt_CSE)+    , ([1,2],   Opt_StgCSE)+    , ([2],     Opt_StgLiftLams)+    , ([1,2],   Opt_CmmControlFlow)++    , ([1,2],   Opt_EnableRewriteRules)+          -- Off for -O0.   Otherwise we desugar list literals+          -- to 'build' but don't run the simplifier passes that+          -- would rewrite them back to cons cells!  This seems+          -- silly, and matters for the GHCi debugger.++    , ([1,2],   Opt_FloatIn)+    , ([1,2],   Opt_FullLaziness)+    , ([1,2],   Opt_IgnoreAsserts)+    , ([1,2],   Opt_Loopification)+    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental++    , ([1,2],   Opt_Specialise)+    , ([1,2],   Opt_CrossModuleSpecialise)+    , ([1,2],   Opt_InlineGenerics)+    , ([1,2],   Opt_Strictness)+    , ([1,2],   Opt_UnboxSmallStrictFields)+    , ([1,2],   Opt_CprAnal)+    , ([1,2],   Opt_WorkerWrapper)+    , ([1,2],   Opt_SolveConstantDicts)+    , ([1,2],   Opt_NumConstantFolding)++    , ([2],     Opt_LiberateCase)+    , ([2],     Opt_SpecConstr)+    , ([2],     Opt_FastPAPCalls)+--  , ([2],     Opt_RegsGraph)+--   RegsGraph suffers performance regression. See #7679+--  , ([2],     Opt_StaticArgumentTransformation)+--   Static Argument Transformation needs investigation. See #9374+    , ([0,1,2], Opt_SpecEval)+    , ([],      Opt_SpecEvalDictFun)+    ]+++default_PIC :: Platform -> [GeneralFlag]+default_PIC platform =+  case (platformOS platform, platformArch platform) of+    -- Darwin always requires PIC.  Especially on more recent macOS releases+    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses+    -- while we could work around this on x86_64 (like WINE does), we won't be+    -- able on aarch64, where this is enforced.+    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]+    -- For AArch64, we need to always have PIC enabled.  The relocation model+    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't+    -- control much how far apart symbols are in memory for our in-memory static+    -- linker;  and thus need to ensure we get sufficiently capable relocations.+    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top+    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to+    -- be built with -fPIC.+    (OSDarwin,  ArchAArch64) -> [Opt_PIC]+    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSOpenBSD, ArchX86_64)  -> [Opt_PIC] -- Due to PIE support in+                                         -- OpenBSD since 5.3 release+                                         -- (1 May 2013) we need to+                                         -- always generate PIC. See+                                         -- #10597 for more+                                         -- information.+    (OSLinux,   ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    _                      -> []++-- | The language extensions implied by the various language variants.+-- When updating this be sure to update the flag documentation in+-- @docs/users_guide/exts@.+languageExtensions :: Maybe Language -> [LangExt.Extension]++-- Nothing: the default case+languageExtensions Nothing = languageExtensions (Just defaultLanguage)++languageExtensions (Just Haskell98)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.NPlusKPatterns,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.FieldSelectors,+       LangExt.NondecreasingIndentation,+           -- strictly speaking non-standard, but we always had this+           -- on implicitly before the option was added in 7.1, and+           -- turning it off breaks code, so we're keeping it on for+           -- backwards compatibility.  Cabal uses -XHaskell98 by+           -- default unless you specify another language.+       LangExt.DeepSubsumption,+       -- Non-standard but enabled for backwards compatability (see GHC proposal #511)+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+      ]++languageExtensions (Just Haskell2010)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.DeepSubsumption,+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2021)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.MonomorphismRestriction,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.ListTuplePuns,+       -- Now the new extensions (not in Haskell2010)+       LangExt.BangPatterns,+       LangExt.BinaryLiterals,+       LangExt.ConstrainedClassMethods,+       LangExt.ConstraintKinds,+       LangExt.DeriveDataTypeable,+       LangExt.DeriveFoldable,+       LangExt.DeriveFunctor,+       LangExt.DeriveGeneric,+       LangExt.DeriveLift,+       LangExt.DeriveTraversable,+       LangExt.EmptyCase,+       LangExt.EmptyDataDeriving,+       LangExt.ExistentialQuantification,+       LangExt.ExplicitForAll,+       LangExt.FlexibleContexts,+       LangExt.FlexibleInstances,+       LangExt.GADTSyntax,+       LangExt.GeneralizedNewtypeDeriving,+       LangExt.HexFloatLiterals,+       LangExt.ImportQualifiedPost,+       LangExt.InstanceSigs,+       LangExt.KindSignatures,+       LangExt.MultiParamTypeClasses,+       LangExt.NamedFieldPuns,+       LangExt.NamedWildCards,+       LangExt.NumericUnderscores,+       LangExt.PolyKinds,+       LangExt.PostfixOperators,+       LangExt.RankNTypes,+       LangExt.ScopedTypeVariables,+       LangExt.StandaloneDeriving,+       LangExt.StandaloneKindSignatures,+       LangExt.TupleSections,+       LangExt.TypeApplications,+       LangExt.TypeOperators,+       LangExt.TypeSynonymInstances,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2024)+    = languageExtensions (Just GHC2021) +++      [LangExt.DataKinds,+       LangExt.DerivingStrategies,+       LangExt.DisambiguateRecordFields,+       LangExt.ExplicitNamespaces,+       LangExt.GADTs,+       LangExt.MonoLocalBinds,+       LangExt.LambdaCase,+       LangExt.RoleAnnotations]++ways :: DynFlags -> Ways+ways dflags+   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)+   | otherwise         = targetWays_ dflags++-- | Get target profile+targetProfile :: DynFlags -> Profile+targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)++--+-- System tool settings and locations++programName :: DynFlags -> String+programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags+projectVersion :: DynFlags -> String+projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)+ghcUsagePath          :: DynFlags -> FilePath+ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags+ghciUsagePath         :: DynFlags -> FilePath+ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags+topDir                :: DynFlags -> FilePath+topDir dflags = fileSettings_topDir $ fileSettings dflags+toolDir               :: DynFlags -> Maybe FilePath+toolDir dflags = fileSettings_toolDir $ fileSettings dflags+extraGccViaCFlags     :: DynFlags -> [String]+extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags+globalPackageDatabasePath   :: DynFlags -> FilePath+globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags++-- | The directory for this version of ghc in the user's app directory+-- The appdir used to be in ~/.ghc but to respect the XDG specification+-- we want to move it under $XDG_DATA_HOME/+-- However, old tooling (like cabal) might still write package environments+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc+-- with the correct target and GHC version suffix exists.+--+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR+--+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version+versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath+versionedAppDir appname platform = do+  -- Make sure we handle the case the HOME isn't set (see #11678)+  -- We need to fallback to the old scheme if the subdirectory exists.+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/+       ]+  where+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case+      True -> pure dir+      False -> MaybeT (pure Nothing)++versionedFilePath :: ArchOS -> FilePath+versionedFilePath platform = uniqueSubdir platform++-- | Access the unit-id of the version of `base` which we will automatically link+-- against.+baseUnitId :: DynFlags -> UnitId+baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)++-- SDoc+-------------------------------------------+-- | Initialize the pretty-printing options+initSDocContext :: DynFlags -> PprStyle -> SDocContext+initSDocContext dflags style = SDC+  { sdocStyle                       = style+  , sdocColScheme                   = colScheme dflags+  , sdocLastColour                  = Col.colReset+  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)+  , sdocDefaultDepth                = pprUserLength dflags+  , sdocLineLength                  = pprCols dflags+  , sdocCanUseUnicode               = useUnicode dflags+  , sdocPrintErrIndexLinks          = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags)+  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags+  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags+  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags+  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags+  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags+  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags+  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags+  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags+  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags+  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags+  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags+  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags+  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags+  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags+  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags+  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags+  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags+  , sdocSuppressCoercionTypes       = gopt Opt_SuppressCoercionTypes dflags+  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags+  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags+  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags+  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags+  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags+  , sdocSuppressStgReps             = gopt Opt_SuppressStgReps dflags+  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags+  , sdocStarIsType                  = xopt LangExt.StarIsType dflags+  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags+  , sdocListTuplePuns               = xopt LangExt.ListTuplePuns dflags+  , sdocPrintTypeAbbreviations      = True+  , sdocUnitIdForUser               = ftext+  }++-- | Initialize the pretty-printing options using the default user style+initDefaultSDocContext :: DynFlags -> SDocContext+initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle++initPromotionTickContext :: DynFlags -> PromotionTickContext+initPromotionTickContext dflags =+  PromTickCtx {+    ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags,+    ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags+  }++-- -----------------------------------------------------------------------------+-- SSE, AVX, FMA++isSse3Enabled :: DynFlags -> Bool+isSse3Enabled dflags = sseVersion dflags >= Just SSE3++isSsse3Enabled :: DynFlags -> Bool+isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3++isSse4_1Enabled :: DynFlags -> Bool+isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++isFmaEnabled :: DynFlags -> Bool+isFmaEnabled dflags = fma dflags++-- -----------------------------------------------------------------------------+-- BMI2++isBmiEnabled :: DynFlags -> Bool+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI1+    ArchX86    -> bmiVersion dflags >= Just BMI1+    _          -> False++isBmi2Enabled :: DynFlags -> Bool+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI2+    ArchX86    -> bmiVersion dflags >= Just BMI2+    _          -> False
+ GHC/Driver/Env.hs view
@@ -0,0 +1,453 @@+{-# LANGUAGE LambdaCase #-}+module GHC.Driver.Env+   ( Hsc(..)+   , HscEnv (..)+   , hsc_mod_graph+   , setModuleGraph+   , hscUpdateFlags+   , hscSetFlags+   , hsc_home_unit+   , hsc_home_unit_maybe+   , hsc_units+   , hsc_HPT+   , hsc_HUE+   , hsc_HUG+   , hsc_all_home_unit_ids+   , hscUpdateLoggerFlags+   , hscUpdateHUG+   , hscInsertHPT+   , hscSetActiveHomeUnit+   , hscSetActiveUnitId+   , hscActiveUnitId+   , runHsc+   , runHsc'+   , mkInteractiveHscEnv+   , runInteractiveHsc+   , hscEPS+   , hscInterp+   , prepareAnnotations+   , discardIC+   , lookupType+   , lookupIfaceByModule+   , lookupIfaceByModuleHsc+   , mainModIs++   , hugRulesBelow+   , hugInstancesBelow+   , hugAnnsBelow+   , hugCompleteSigsBelow++    -- * Legacy API+   , hscUpdateHPT+   )+where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Driver.Errors ( printOrThrowDiagnostics )+import GHC.Driver.Errors.Types ( GhcMessage )+import GHC.Driver.Config.Logger (initLogFlags)+import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig)+import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )++import GHC.Runtime.Context+import GHC.Runtime.Interpreter.Types (Interp)++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable+import GHC.Unit.Home.Graph+import GHC.Unit.Module.Graph+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Env as UnitEnv+import GHC.Unit.External++import GHC.Types.Error ( emptyMessages, Messages )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.TyThing++import GHC.Data.Maybe++import GHC.Utils.Exception as Ex+import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Core.Rules+import GHC.Types.Annotations+import GHC.Types.CompleteMatch+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Builtin.Names++import Data.IORef+import qualified Data.Set as Set++runHsc :: HscEnv -> Hsc a -> IO a+runHsc hsc_env hsc = do+    (a, w) <- runHsc' hsc_env hsc+    let dflags = hsc_dflags hsc_env+    let !diag_opts = initDiagOpts dflags+        !print_config = initPrintConfig dflags+    printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w+    return a++runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)+runHsc' hsc_env (Hsc hsc) = hsc hsc_env emptyMessages++-- | Switches in the DynFlags and Plugins from the InteractiveContext+mkInteractiveHscEnv :: HscEnv -> HscEnv+mkInteractiveHscEnv hsc_env =+    let ic = hsc_IC hsc_env+    in hscSetFlags (ic_dflags ic) $+       hsc_env { hsc_plugins = ic_plugins ic }++-- | A variant of runHsc that switches in the DynFlags and Plugins from the+-- InteractiveContext before running the Hsc computation.+runInteractiveHsc :: HscEnv -> Hsc a -> IO a+runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)++hsc_home_unit :: HscEnv -> HomeUnit+hsc_home_unit = ue_unsafeHomeUnit . hsc_unit_env++hsc_home_unit_maybe :: HscEnv -> Maybe HomeUnit+hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env++hsc_units :: HasDebugCallStack => HscEnv -> UnitState+hsc_units = ue_homeUnitState . hsc_unit_env++hsc_HPT :: HscEnv -> HomePackageTable+hsc_HPT = ue_hpt . hsc_unit_env++hsc_HUE :: HscEnv -> HomeUnitEnv+hsc_HUE = ue_currentHomeUnitEnv . hsc_unit_env++hsc_HUG :: HscEnv -> HomeUnitGraph+hsc_HUG = ue_home_unit_graph . hsc_unit_env++hsc_mod_graph :: HscEnv -> ModuleGraph+hsc_mod_graph = ue_module_graph . hsc_unit_env++hsc_all_home_unit_ids :: HscEnv -> Set.Set UnitId+hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG++hscInsertHPT :: HomeModInfo -> HscEnv -> IO ()+hscInsertHPT hmi hsc_env = UnitEnv.insertHpt hmi (hsc_unit_env hsc_env)++hscUpdateHUG :: (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv+hscUpdateHUG f hsc_env = hsc_env { hsc_unit_env = updateHug f (hsc_unit_env hsc_env) }++setModuleGraph :: ModuleGraph -> HscEnv -> HscEnv+setModuleGraph mod_graph hsc_env = hsc_env { hsc_unit_env = (hsc_unit_env hsc_env) { ue_module_graph = mod_graph } }++{-++Note [Target code interpreter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Template Haskell and GHCi use an interpreter to execute code that is built for+the compiler target platform (= code host platform) on the compiler host+platform (= code build platform).++The internal interpreter can be used when both platforms are the same and when+the built code is compatible with the compiler itself (same way, etc.). This+interpreter is not always available: for instance stage1 compiler doesn't have+it because there might be an ABI mismatch between the code objects (built by+stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).++In most cases, an external interpreter can be used instead: it runs in a+separate process and it communicates with the compiler via a two-way message+passing channel. The process is lazily spawned to avoid overhead when it is not+used.++The target code interpreter to use can be selected per session via the+`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in+which case Template Haskell and GHCi will fail to run. The interpreter to use is+configured via command-line flags (in `GHC.setTopSessionDynFlags`).+++-}++-- Note [hsc_type_env_var hack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- hsc_type_env_var is used to initialize tcg_type_env_var, and+-- eventually it is the mutable variable that is queried from+-- if_rec_types to get a TypeEnv.  So, clearly, it's something+-- related to knot-tying (see Note [Tying the knot]).+-- hsc_type_env_var is used in two places: initTcRn (where+-- it initializes tcg_type_env_var) and initIfaceCheck+-- (where it initializes if_rec_types).+--+-- But why do we need a way to feed a mutable variable in?  Why+-- can't we just initialize tcg_type_env_var when we start+-- typechecking?  The problem is we need to knot-tie the+-- EPS, and we may start adding things to the EPS before type+-- checking starts.+--+-- Here is a concrete example. Suppose we are running+-- "ghc -c A.hs", and we have this file system state:+--+--  A.hs-boot   A.hi-boot **up to date**+--  B.hs        B.hi      **up to date**+--  A.hs        A.hi      **stale**+--+-- The first thing we do is run checkOldIface on A.hi.+-- checkOldIface will call loadInterface on B.hi so it can+-- get its hands on the fingerprints, to find out if A.hi+-- needs recompilation.  But loadInterface also populates+-- the EPS!  And so if compilation turns out to be necessary,+-- as it is in this case, the thunks we put into the EPS for+-- B.hi need to have the correct if_rec_types mutable variable+-- to query.+--+-- If the mutable variable is only allocated WHEN we start+-- typechecking, then that's too late: we can't get the+-- information to the thunks.  So we need to pre-commit+-- to a type variable in 'hscIncrementalCompile' BEFORE we+-- check the old interface.+--+-- This is all a massive hack because arguably checkOldIface+-- should not populate the EPS. But that's a refactor for+-- another day.++-- | Retrieve the ExternalPackageState cache.+hscEPS :: HscEnv -> IO ExternalPackageState+hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env)))++--------------------------------------------------------------------------------+-- * Queries on Transitive Closure+--------------------------------------------------------------------------------++-- | Find all rules in modules that are in the transitive closure of the given+-- module.+hugRulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO RuleBase+hugRulesBelow hsc_env uid mn = foldr (flip extendRuleBaseList) emptyRuleBase <$>+  hugSomeThingsBelowUs (md_rules . hm_details) False hsc_env uid mn++-- | Get annotations from all modules "below" this one (in the dependency+-- sense) within the home units. If the module is @Nothing@, returns /all/+-- annotations in the home units.+hugAnnsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO AnnEnv+hugAnnsBelow hsc_env uid mn = foldr (flip extendAnnEnvList) emptyAnnEnv <$>+  hugSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn++-- | Find all COMPLETE pragmas in modules that are in the transitive closure of the+-- given module.+hugCompleteSigsBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO CompleteMatches+hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$>+  hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn++-- | Find instances visible from the given set of imports+hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [FamInst])+hugInstancesBelow hsc_env uid mnwib = do+ let mn = gwib_mod mnwib+ (insts, famInsts) <-+     unzip . concat <$>+       hugSomeThingsBelowUs (\mod_info ->+                                  let details = hm_details mod_info+                                  -- Don't include instances for the current module+                                  in if moduleName (mi_module (hm_iface mod_info)) == mn+                                       then []+                                       else [(md_insts details, md_fam_insts details)])+                          True -- Include -hi-boot+                          hsc_env+                          uid+                          mnwib+ return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)++-- | Get things from modules in the transitive closure of the given module.+--+-- Note: Don't expose this function. This is a footgun if exposed!+hugSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO [[a]]+-- An explicit check to see if we are in one-shot mode to avoid poking the ModuleGraph thunk+-- These things are currently stored in the EPS for home packages. (See #25795 for+-- progress in removing these kind of checks; and making these functions of+-- `UnitEnv` rather than `HscEnv`)+-- See Note [Downsweep and the ModuleGraph]+hugSomeThingsBelowUs _ _ hsc_env _ _ | isOneShot (ghcMode (hsc_dflags hsc_env)) = return []+hugSomeThingsBelowUs extract include_hi_boot hsc_env uid mn+  = let hug = hsc_HUG hsc_env+        mg  = hsc_mod_graph hsc_env+    in+    sequence+    [ things+      -- "Finding each non-hi-boot module below me" maybe could be cached (well,+      -- the inverse) in the module graph to avoid filtering the boots out of+      -- the transitive closure out every time this is called+    | (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid)+          <- Set.toList (moduleGraphModulesBelow mg uid mn)+    , include_hi_boot || (is_boot == NotBoot)++        -- unsavoury: when compiling the base package with --make, we+        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't+        -- be in the HPT, because we never compile it; it's in the EPT+        -- instead. ToDo: clean up, and remove this slightly bogus filter:+    , mod /= moduleName gHC_PRIM+    , not (mod == gwib_mod mn && uid == mod_uid)++        -- Look it up in the HUG+    , let things = lookupHug hug mod_uid mod >>= \case+                    Just info -> return $ extract info+                    Nothing -> pprTrace "WARNING in hugSomeThingsBelowUs" msg mempty+          msg = vcat [text "missing module" <+> ppr mod,+                     text "When starting from"  <+> ppr mn,+                     text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),+                      text "Probable cause: out-of-date interface files"]+                        -- This really shouldn't happen, but see #962+    ]++-- | Deal with gathering annotations in from all possible places+--   and combining them into a single 'AnnEnv'+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv+prepareAnnotations hsc_env mb_guts = do+    eps <- hscEPS hsc_env+    let -- Extract annotations from the module being compiled if supplied one+        mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts+        -- Extract dependencies of the module if we are supplied one,+        -- otherwise load annotations from all home package table+        -- entries regardless of dependency ordering.+        get_mod mg = (moduleUnitId (mg_module mg), GWIB (moduleName (mg_module mg)) NotBoot)+    home_pkg_anns  <- fromMaybe (hugAllAnns (hsc_unit_env hsc_env))+                      $ uncurry (hugAnnsBelow hsc_env)+                      . get_mod <$> mb_guts+    let+        other_pkg_anns = eps_ann_env eps+        !ann_env       = maybe id plusAnnEnv mb_this_module_anns $!+            plusAnnEnv home_pkg_anns other_pkg_anns+    return ann_env++-- | Find the 'TyThing' for the given 'Name' by using all the resources+-- at our disposal: the compiled modules in the 'HomePackageTable' and the+-- compiled modules in other packages that live in 'PackageTypeEnv'. Note+-- that this does NOT look up the 'TyThing' in the module being compiled: you+-- have to do that yourself, if desired+lookupType :: HscEnv -> Name -> IO (Maybe TyThing)+lookupType hsc_env name = do+   eps <- liftIO $ hscEPS hsc_env+   let pte = eps_PTE eps+   lookupTypeInPTE hsc_env pte name++lookupTypeInPTE :: HscEnv -> PackageTypeEnv -> Name -> IO (Maybe TyThing)+lookupTypeInPTE hsc_env pte name = ty+  where+    hpt = hsc_HUG hsc_env+    mod = assertPpr (isExternalName name) (ppr name) $+          if isHoleName name+            then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))+            else nameModule name++    ty = if isOneShot (ghcMode (hsc_dflags hsc_env))+            -- in one-shot, we don't use the HPT+            then return $! lookupNameEnv pte name+            else HUG.lookupHugByModule mod hpt >>= \case+             Just hm -> pure $! lookupNameEnv (md_types (hm_details hm)) name+             Nothing -> pure $! lookupNameEnv pte name++-- | Find the 'ModIface' for a 'Module', searching in both the loaded home+-- and external package module information+lookupIfaceByModule+        :: HomeUnitGraph+        -> PackageIfaceTable+        -> Module+        -> IO (Maybe ModIface)+lookupIfaceByModule hug pit mod+  = HUG.lookupHugByModule mod hug >>= pure . \case+       Just hm -> Just (hm_iface hm)+       Nothing -> lookupModuleEnv pit mod+   -- If the module does come from the home package, why do we look in the PIT as well?+   -- (a) In OneShot mode, even home-package modules accumulate in the PIT+   -- (b) Even in Batch (--make) mode, there is *one* case where a home-package+   --     module is in the PIT, namely GHC.Prim when compiling the base package.+   -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package+   -- of its own, but it doesn't seem worth the bother.++lookupIfaceByModuleHsc :: HscEnv -> Module -> IO (Maybe ModIface)+lookupIfaceByModuleHsc hsc_env mod = do+  eps <- hscEPS hsc_env+  lookupIfaceByModule (hsc_HUG hsc_env) (eps_PIT eps) mod++mainModIs :: HomeUnitEnv -> Module+mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))++-- | Retrieve the target code interpreter+--+-- Fails if no target code interpreter is available+hscInterp :: HscEnv -> Interp+hscInterp hsc_env = case hsc_interp hsc_env of+   Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")+   Just i  -> i++-- | Update the LogFlags of the Log in hsc_logger from the DynFlags in+-- hsc_dflags. You need to call this when DynFlags are modified.+hscUpdateLoggerFlags :: HscEnv -> HscEnv+hscUpdateLoggerFlags h = h+  { hsc_logger = setLogFlags (hsc_logger h) (initLogFlags (hsc_dflags h)) }++-- | Update Flags+hscUpdateFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv+hscUpdateFlags f h = hscSetFlags (f (hsc_dflags h)) h++-- | Set Flags+hscSetFlags :: HasDebugCallStack => DynFlags -> HscEnv -> HscEnv+hscSetFlags dflags h =+  hscUpdateLoggerFlags $ h { hsc_dflags = dflags+                           , hsc_unit_env = ue_setFlags dflags (hsc_unit_env h) }++-- See Note [Multiple Home Units]+hscSetActiveHomeUnit :: HasDebugCallStack => HomeUnit -> HscEnv -> HscEnv+hscSetActiveHomeUnit home_unit = hscSetActiveUnitId (homeUnitId home_unit)++hscSetActiveUnitId :: HasDebugCallStack => UnitId -> HscEnv -> HscEnv+hscSetActiveUnitId uid e = e+  { hsc_unit_env = ue_setActiveUnit uid (hsc_unit_env e)+  , hsc_dflags = ue_unitFlags uid (hsc_unit_env e)  }++hscActiveUnitId :: HscEnv -> UnitId+hscActiveUnitId e = ue_currentUnit (hsc_unit_env e)++-- | Discard the contents of the InteractiveContext, but keep the DynFlags and+-- the loaded plugins.  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+                                , ic_plugins   = old_plugins+                                } }+  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+  !old_plugins = ic_plugins old_ic+  dflags = ic_dflags old_ic+  old_ic = hsc_IC hsc_env+  empty_ic = emptyInteractiveContext dflags+  keep_external_name ic_name+    | nameIsFromExternalPackage home_unit old_name = old_name+    | otherwise = ic_name empty_ic+    where+    home_unit = hsc_home_unit hsc_env+    old_name = ic_name old_ic+++--------------------------------------------------------------------------------+-- * The Legacy API, should be removed after enough deprecation cycles+--------------------------------------------------------------------------------++{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \+   \ operation. Instead, the HPT is an insert-only data structure. If you want to \+   \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \+   \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-}+hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv+hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue }+  where+    ue = hsc_unit_env hsc_env+    upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) }+
+ GHC/Driver/Env/KnotVars.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveFunctor #-}+-- | This data structure holds an updateable environment which is used+-- when compiling module loops.+module GHC.Driver.Env.KnotVars( KnotVars(..)+                              , emptyKnotVars+                              , knotVarsFromModuleEnv+                              , knotVarElems+                              , lookupKnotVars+                              , knotVarsWithout+                              ) where++import GHC.Prelude+import GHC.Unit.Types ( Module )+import GHC.Unit.Module.Env+import Data.Maybe+import GHC.Utils.Outputable++-- See Note [Why is KnotVars not a ModuleEnv]+-- See Note [KnotVars invariants]+data KnotVars a = KnotVars { kv_domain :: [Module] -- Domain of the function , Note [KnotVars: Why store the domain?]+                           -- Invariant: kv_lookup is surjective relative to kv_domain+                           , kv_lookup :: Module -> Maybe a -- Lookup function+                           }+                | NoKnotVars+                           deriving Functor++instance Outputable (KnotVars a) where+  ppr NoKnotVars = text "NoKnot"+  ppr (KnotVars dom _lookup) = text "Knotty:" <+> ppr dom++emptyKnotVars :: KnotVars a+emptyKnotVars = NoKnotVars++knotVarsFromModuleEnv :: ModuleEnv a -> KnotVars a+knotVarsFromModuleEnv me | isEmptyModuleEnv me = NoKnotVars+knotVarsFromModuleEnv me = KnotVars (moduleEnvKeys me) (lookupModuleEnv me)++knotVarElems :: KnotVars a -> [a]+knotVarElems (KnotVars keys lookup) = mapMaybe lookup keys+knotVarElems NoKnotVars = []++lookupKnotVars :: KnotVars a -> Module -> Maybe a+lookupKnotVars (KnotVars _ lookup) x = lookup x+lookupKnotVars NoKnotVars _ = Nothing++knotVarsWithout :: Module -> KnotVars a -> KnotVars a+knotVarsWithout this_mod (KnotVars loop_mods lkup) = KnotVars+  (filter (/= this_mod) loop_mods)+  (\that_mod -> if that_mod == this_mod then Nothing else lkup that_mod)+knotVarsWithout _ NoKnotVars = NoKnotVars++{-+Note [Why is KnotVars not a ModuleEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Initially 'KnotVars' was just a 'ModuleEnv a' but there is one tricky use of+the data structure in 'mkDsEnvs' which required this generalised structure.++In interactive mode the TypeEnvs from all the previous statements are merged+together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal+lookup functions either look in the HPT or EPS but there is no entry for the `Ghci<N>` modules+in either, so the whole merged TypeEnv for all previous Ghci* is stored in the+`if_rec_types` variable and then lookup checks there in the case of any interactive module.++This is a misuse of the `if_rec_types` variable which might be fixed in future if the+Ghci<N> modules are just placed into the HPT like normal modules with implicit imports+between them.++Note [KnotVars: Why store the domain?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate+at a particular time, apart from one case, when constructing the in-scope set+when linting an unfolding. In this case the whole environment is needed to tell us+everything that's in-scope at top-level in the loop because whilst we are linting unfoldings+the top-level identifiers from modules in the cycle might not be globalised properly yet.++This could be refactored so that the lint functions knew about 'KnotVars' and delayed+this check until deciding whether a variable was local or not.+++Note [KnotVars invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~++There is a simple invariant which should hold for the KnotVars constructor:++* At the end of upsweep, there should be no live KnotVars++This invariant is difficult to test but easy to check using ghc-debug. The usage of+NoKnotVars is intended to make this invariant easier to check.++The most common situation where a KnotVars is retained accidentally is if a HscEnv+which contains reference to a KnotVars is used during interface file loading. The+thunks created during this process will retain a reference to the KnotVars. In theory,+all these references should be removed by 'maybeRehydrateAfter' as that rehydrates all+interface files in the loop without using KnotVars.++At the time of writing (MP: Oct 21) the invariant doesn't actually hold but also+doesn't seem to have too much of a negative consequence on compiler residency.+In theory it could be quite bad as each KnotVars may retain a stale reference to an entire TypeEnv.++See #20491+-}+
+ GHC/Driver/Env/Types.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DerivingVia #-}++module GHC.Driver.Env.Types+  ( Hsc(..)+  , HscEnv(..)+  ) where++import GHC.Driver.Errors.Types ( GhcMessage )+import {-# SOURCE #-} GHC.Driver.Hooks+import GHC.Driver.DynFlags ( ContainsDynFlags(..), HasDynFlags(..), DynFlags )+import GHC.Driver.LlvmConfigCache (LlvmConfigCache)++import GHC.Prelude+import GHC.Runtime.Context+import GHC.Runtime.Interpreter.Types ( Interp )+import GHC.Types.Error ( Messages )+import GHC.Types.Name.Cache+import GHC.Types.Target+import GHC.Types.TypeEnv+import GHC.Unit.Finder.Types+import GHC.Unit.Env+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import {-# SOURCE #-} GHC.Driver.Plugins++import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Data.IORef+import GHC.Driver.Env.KnotVars++-- | The Hsc monad: Passing an environment and diagnostic state+newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))+    deriving (Functor, Applicative, Monad, MonadIO)+      via ReaderT HscEnv (StateT (Messages GhcMessage) IO)++instance HasDynFlags Hsc where+    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)++instance ContainsDynFlags HscEnv where+    extractDynFlags h = hsc_dflags h++instance HasLogger Hsc where+    getLogger = Hsc $ \e w -> return (hsc_logger e, w)+++-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.+-- An HscEnv is used to compile a single module from plain Haskell source+-- code (after preprocessing) to either C, assembly or C--. It's also used+-- to store the dynamic linker state to allow for multiple linkers in the+-- same address space.+-- Things like the module graph don't change during a single compilation.+--+-- Historical note: \"hsc\" used to be the name of the compiler binary,+-- when there was a separate driver and compiler.  To compile a single+-- module, the driver would invoke hsc on the source code... so nowadays+-- we think of hsc as the layer of the compiler that deals with compiling+-- a single module.+data HscEnv+  = HscEnv {+        hsc_dflags :: DynFlags,+                -- ^ The dynamic flag settings++        hsc_targets :: [Target],+                -- ^ The targets (or roots) of the current session++        hsc_IC :: InteractiveContext,+                -- ^ The context for evaluating interactive statements++        hsc_NC  :: {-# UNPACK #-} !NameCache,+                -- ^ Global Name cache so that each Name gets a single Unique.+                -- Also track the origin of the Names.++        hsc_FC   :: {-# UNPACK #-} !FinderCache,+                -- ^ The cached result of performing finding in the file system++        hsc_type_env_vars :: KnotVars (IORef TypeEnv)+                -- ^ Used for one-shot compilation only, to initialise+                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for+                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]++        , hsc_interp :: Maybe Interp+                -- ^ target code interpreter (if any) to use for TH and GHCi.+                -- See Note [Target code interpreter]++        , hsc_plugins :: !Plugins+                -- ^ Plugins++        , hsc_unit_env :: UnitEnv+                -- ^ Unit environment (unit state, home unit, etc.).+                --+                -- Initialized from the databases cached in 'hsc_unit_dbs' and+                -- from the DynFlags.++        , hsc_logger :: !Logger+                -- ^ Logger with its flags.+                --+                -- Don't forget to update the logger flags if the logging+                -- related DynFlags change. Or better, use hscSetFlags setter+                -- which does it.++        , hsc_hooks :: !Hooks+                -- ^ Hooks++        , hsc_tmpfs :: !TmpFs+                -- ^ Temporary files++        , hsc_llvm_config :: !LlvmConfigCache+                -- ^ LLVM configuration cache.+ }+
+ GHC/Driver/Errors.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}+module GHC.Driver.Errors (+    printOrThrowDiagnostics+  , printMessages+  , mkDriverPsHeaderMessage+  ) where++import GHC.Driver.Errors.Types+import GHC.Prelude+import GHC.Types.SourceError+import GHC.Types.Error+import GHC.Utils.Error+import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext )+import GHC.Utils.Logger++printMessages :: forall a. (Diagnostic a) => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()+printMessages logger msg_opts opts msgs+  = sequence_ [ let style = mkErrStyle name_ppr_ctx+                    ctx   = (diag_ppr_ctx opts) { sdocStyle = style }+                in (if log_diags_as_json+                    then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg+                    else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $+                  updSDocContext (\_ -> ctx) (messageWithHints dia))+              | msg@MsgEnvelope { errMsgSpan       = s,+                                  errMsgDiagnostic = dia,+                                  errMsgSeverity   = sev,+                                  errMsgReason     = reason,+                                  errMsgContext    = name_ppr_ctx }+                  <- sortMsgBag (Just opts) (getMessages msgs) ]+  where+    messageWithHints :: a -> SDoc+    messageWithHints e =+      let main_msg = formatBulleted $ diagnosticMessage msg_opts e+          in case diagnosticHints e of+               []  -> main_msg+               [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)+               hs  -> main_msg $$ hang (text "Suggested fixes:") 2+                                       (formatBulleted  $ mkDecorated . map ppr $ hs)+    log_diags_as_json = log_diagnostics_as_json (logFlags logger)++-- | Given a bag of diagnostics, turn them into an exception if+-- any has 'SevError', or print them out otherwise.+printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()+printOrThrowDiagnostics logger print_config opts msgs+  | errorsOrFatalWarningsFound msgs+  = throwErrors msgs+  | otherwise+  = printMessages logger print_config opts msgs++-- | Convert a 'PsError' into a wrapped 'DriverMessage'; use it+-- for dealing with parse errors when the driver is doing dependency analysis.+-- Defined here to avoid module loops between GHC.Driver.Error.Types and+-- GHC.Driver.Error.Ppr+mkDriverPsHeaderMessage :: MsgEnvelope PsMessage -> MsgEnvelope DriverMessage+mkDriverPsHeaderMessage = fmap DriverPsHeaderMessage
+ GHC/Driver/Errors/Ppr.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage}++module GHC.Driver.Errors.Ppr (+  -- This module only exports Diagnostic instances.+  ) where++import GHC.Prelude++import GHC.Driver.Errors.Types+import GHC.Driver.Flags+import GHC.Driver.DynFlags+import GHC.HsToCore.Errors.Ppr () -- instance Diagnostic DsMessage+import GHC.Parser.Errors.Ppr () -- instance Diagnostic PsMessage+import GHC.Types.Error+import GHC.Types.Error.Codes+import GHC.Unit.Types+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Unit.Module+import GHC.Unit.Module.Graph+import GHC.Unit.State+import GHC.Types.Hint+import GHC.Types.SrcLoc+import Data.Version++import Language.Haskell.Syntax.Decls (RuleDecl(..))+import GHC.Tc.Errors.Types (TcRnMessage)+import GHC.HsToCore.Errors.Types (DsMessage)+import GHC.Iface.Errors.Types+import GHC.Tc.Errors.Ppr () -- instance Diagnostic TcRnMessage+import GHC.Iface.Errors.Ppr () -- instance Diagnostic IfaceMessage+import GHC.CmmToLlvm.Version (llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound)++--+-- Suggestions+--++-- | Suggests a list of 'InstantiationSuggestion' for the '.hsig' file to the user.+suggestInstantiatedWith :: ModuleName -> GenInstantiations UnitId -> [InstantiationSuggestion]+suggestInstantiatedWith pi_mod_name insts =+  [ InstantiationSuggestion k v | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : insts) ]++instance HasDefaultDiagnosticOpts GhcMessageOpts where+  defaultOpts = GhcMessageOpts (defaultDiagnosticOpts @PsMessage)+                                         (defaultDiagnosticOpts @TcRnMessage)+                                         (defaultDiagnosticOpts @DsMessage)+                                         (defaultDiagnosticOpts @DriverMessage)++instance Diagnostic GhcMessage where+  type DiagnosticOpts GhcMessage = GhcMessageOpts+  diagnosticMessage opts = \case+    GhcPsMessage m+      -> diagnosticMessage (psMessageOpts opts) m+    GhcTcRnMessage m+      -> diagnosticMessage (tcMessageOpts opts) m+    GhcDsMessage m+      -> diagnosticMessage (dsMessageOpts opts) m+    GhcDriverMessage m+      -> diagnosticMessage (driverMessageOpts opts) m+    GhcUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m++  diagnosticReason = \case+    GhcPsMessage m+      -> diagnosticReason m+    GhcTcRnMessage m+      -> diagnosticReason m+    GhcDsMessage m+      -> diagnosticReason m+    GhcDriverMessage m+      -> diagnosticReason m+    GhcUnknownMessage m+      -> diagnosticReason m++  diagnosticHints = \case+    GhcPsMessage m+      -> diagnosticHints m+    GhcTcRnMessage m+      -> diagnosticHints m+    GhcDsMessage m+      -> diagnosticHints m+    GhcDriverMessage m+      -> diagnosticHints m+    GhcUnknownMessage m+      -> diagnosticHints m++  diagnosticCode = constructorCode @GHC++instance HasDefaultDiagnosticOpts DriverMessageOpts where+  defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)++instance Diagnostic DriverMessage where+  type DiagnosticOpts DriverMessage = DriverMessageOpts+  diagnosticMessage opts = \case+    DriverUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m+    DriverPsHeaderMessage m+      -> diagnosticMessage (psDiagnosticOpts opts) m+    DriverMissingHomeModules uid missing buildingCabalPackage+      -> let msg | buildingCabalPackage == YesBuildingCabalPackage+                 = hang+                     (text "These modules are needed for compilation but not listed in your .cabal file's other-modules for" <+> quotes (ppr uid) <+> text ":")+                     4+                     (sep (map ppr missing))+                 | otherwise+                 =+                   hang+                     (text "Modules are not listed in options for"+                        <+> quotes (ppr uid) <+> text "but needed for compilation:")+                     4+                     (sep (map ppr missing))+         in mkSimpleDecorated msg+    DriverUnknownHiddenModules uid missing+      -> let msg = hang+                     (text "Modules are listed as hidden in options for" <+> quotes (ppr uid) <+> text "but not part of the unit:")+                     4+                     (sep (map ppr missing))+         in mkSimpleDecorated msg+    DriverUnknownReexportedModules uid missing+      -> let msg = hang+                     (text "Modules are listed as reexported in options for" <+> quotes (ppr uid) <+> text "but can't be found in any dependency:")+                     4+                     (sep (map ppr missing))+         in mkSimpleDecorated msg+    DriverUnusedPackages unusedArgs+      -> let msg = vcat [ text "The following packages were specified" <+>+                          text "via -package or -package-id flags,"+                        , text "but were not needed for compilation:"+                        , nest 2 (vcat (map (withDash . displayOneUnused) unusedArgs))+                        ]+         in mkSimpleDecorated msg+         where+            withDash :: SDoc -> SDoc+            withDash = (<+>) (text "-")++            displayOneUnused (_uid, pn , v, f) =+              ppr pn <> text "-"  <> text (showVersion v)+                     <+> parens (suffix f)++            suffix f = text "exposed by flag" <+> pprUnusedArg f++            pprUnusedArg :: PackageArg -> SDoc+            pprUnusedArg (PackageArg str) = text "-package" <+> text str+            pprUnusedArg (UnitIdArg uid) = text "-package-id" <+> ppr uid++    DriverUnnecessarySourceImports mod+      -> mkSimpleDecorated (text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod))+    DriverDuplicatedModuleDeclaration mod files+      -> mkSimpleDecorated $+           text "module" <+> quotes (ppr mod) <+>+           text "is defined in multiple files:" <+>+           sep (map text files)+    DriverModuleNotFound _uid mod+      -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally")+    DriverFileModuleNameMismatch actual expected+      -> mkSimpleDecorated $+           text "File name does not match module name:"+           $$ text "Saw     :" <+> quotes (ppr actual)+           $$ text "Expected:" <+> quotes (ppr expected)++    DriverUnexpectedSignature pi_mod_name _buildingCabalPackage _instantiations+      -> mkSimpleDecorated $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name)+    DriverFileNotFound hsFilePath+      -> mkSimpleDecorated (text "Can't find" <+> text hsFilePath)+    DriverStaticPointersNotSupported+      -> mkSimpleDecorated (text "StaticPointers is not supported in GHCi interactive expressions.")+    DriverBackpackModuleNotFound modname+      -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found")+    DriverUserDefinedRuleIgnored (HsRule { rd_name = n })+      -> mkSimpleDecorated $+            text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$+            text "Defining user rules is disabled under Safe Haskell"+    DriverMixedSafetyImport modName+      -> mkSimpleDecorated $+           text "Module" <+> ppr modName <+> text ("is imported both as a safe and unsafe import!")+    DriverCannotLoadInterfaceFile m+      -> mkSimpleDecorated $+           text "Can't load the interface file for" <+> ppr m+           <> text ", to check that it can be safely imported"+    DriverInferredSafeModule m+      -> mkSimpleDecorated $+           quotes (ppr $ moduleName m) <+> text "has been inferred as safe!"+    DriverInferredSafeImport m+      -> mkSimpleDecorated $+           sep+             [ text "Importing Safe-Inferred module "+                 <> ppr (moduleName m)+                 <> text " from explicitly Safe module"+             ]+    DriverMarkedTrustworthyButInferredSafe m+      -> mkSimpleDecorated $+           quotes (ppr $ moduleName m) <+> text "is marked as Trustworthy but has been inferred as safe!"+    DriverCannotImportUnsafeModule m+      -> mkSimpleDecorated $+           sep [ ppr (moduleName m)+                   <> text ": Can't be safely imported!"+               , text "The module itself isn't safe." ]+    DriverMissingSafeHaskellMode modName+      -> mkSimpleDecorated $+           ppr modName <+> text "is missing Safe Haskell mode"+    DriverPackageNotTrusted state pkg+      -> mkSimpleDecorated $+           pprWithUnitState state+             $ text "The package ("+                <> ppr pkg+                <> text ") is required to be trusted but it isn't!"+    DriverCannotImportFromUntrustedPackage state m+      -> mkSimpleDecorated $+           sep [ ppr (moduleName m)+                   <> text ": Can't be safely imported!"+               , text "The package ("+                   <> (pprWithUnitState state $ ppr (moduleUnit m))+                   <> text ") the module resides in isn't trusted."+               ]+    DriverRedirectedNoMain mod_name+      -> mkSimpleDecorated $ (text+                       ("Output was redirected with -o, " +++                       "but no output will be generated.") $$+                       (text "There is no module named" <+>+                       quotes (ppr mod_name) <> text "."))+    DriverHomePackagesNotClosed needed_unit_ids+      -> mkSimpleDecorated $ vcat ([text "Home units are not closed."+                                  , text "It is necessary to also load the following units:" ]+                                  ++ map (\uid -> text "-" <+> ppr uid) needed_unit_ids)+    DriverInterfaceError reason -> diagnosticMessage (ifaceDiagnosticOpts opts) reason++    DriverInconsistentDynFlags msg+      -> mkSimpleDecorated $ text msg+    DriverSafeHaskellIgnoredExtension ext+      -> let arg = text "-X" <> ppr ext+         in mkSimpleDecorated $ arg <+> text "is not allowed in Safe Haskell; ignoring" <+> arg+    DriverPackageTrustIgnored+      -> mkSimpleDecorated $ text "-fpackage-trust ignored; must be specified with a Safe Haskell flag"++    DriverUnrecognisedFlag arg+      -> mkSimpleDecorated $ text $ "unrecognised warning flag: -" ++ arg+    DriverDeprecatedFlag arg msg+      -> mkSimpleDecorated $ text $ arg ++ " is deprecated: " ++ msg+    DriverModuleGraphCycle path+      -> mkSimpleDecorated $ vcat+        [ text "Module graph contains a cycle:"+        , nest 2 (show_path path) ]+      where+        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 14 (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_node (UnitNode uid _) = pprPanic "UnitNode should not be in a cycle" (ppr uid)++        ppr_ms :: ModuleNodeInfo -> SDoc+        ppr_ms ms = quotes (ppr (moduleNodeInfoModule ms)) <+>+                    (parens (text (node_path ms)))++        node_path :: ModuleNodeInfo -> FilePath+        node_path ms = case ml_hs_file (moduleNodeInfoLocation ms) of+          Just f -> f+          Nothing -> ml_hi_file (moduleNodeInfoLocation ms)+    DriverInstantiationNodeInDependencyGeneration node ->+      mkSimpleDecorated $+        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"+             , nest 2 $ ppr node ]+    DriverNoConfiguredLLVMToolchain ->+      mkSimpleDecorated $+        text "GHC was not configured with a supported LLVM toolchain" $$+          text ("Make sure you have installed LLVM between ["+            ++ llvmVersionStr supportedLlvmVersionLowerBound+            ++ " and "+            ++ llvmVersionStr supportedLlvmVersionUpperBound+            ++ ") and reinstall GHC to ensure -fllvm works")++  diagnosticReason = \case+    DriverUnknownMessage m+      -> diagnosticReason m+    DriverPsHeaderMessage {}+      -> ErrorWithoutFlag+    DriverMissingHomeModules{}+      -> WarningWithFlag Opt_WarnMissingHomeModules+    DriverUnknownHiddenModules {}+      -> ErrorWithoutFlag+    DriverUnknownReexportedModules {}+      -> ErrorWithoutFlag+    DriverUnusedPackages{}+      -> WarningWithFlag Opt_WarnUnusedPackages+    DriverUnnecessarySourceImports{}+      -> WarningWithFlag Opt_WarnUnusedImports+    DriverDuplicatedModuleDeclaration{}+      -> ErrorWithoutFlag+    DriverModuleNotFound{}+      -> ErrorWithoutFlag+    DriverFileModuleNameMismatch{}+      -> ErrorWithoutFlag+    DriverUnexpectedSignature{}+      -> ErrorWithoutFlag+    DriverFileNotFound{}+      -> ErrorWithoutFlag+    DriverStaticPointersNotSupported+      -> WarningWithoutFlag+    DriverBackpackModuleNotFound{}+      -> ErrorWithoutFlag+    DriverUserDefinedRuleIgnored{}+      -> WarningWithoutFlag+    DriverMixedSafetyImport{}+      -> ErrorWithoutFlag+    DriverCannotLoadInterfaceFile{}+      -> ErrorWithoutFlag+    DriverInferredSafeModule{}+      -> WarningWithFlag Opt_WarnSafe+    DriverMarkedTrustworthyButInferredSafe{}+      ->WarningWithFlag Opt_WarnTrustworthySafe+    DriverInferredSafeImport{}+      -> WarningWithFlag Opt_WarnInferredSafeImports+    DriverCannotImportUnsafeModule{}+      -> ErrorWithoutFlag+    DriverMissingSafeHaskellMode{}+      -> WarningWithFlag Opt_WarnMissingSafeHaskellMode+    DriverPackageNotTrusted{}+      -> ErrorWithoutFlag+    DriverCannotImportFromUntrustedPackage{}+      -> ErrorWithoutFlag+    DriverRedirectedNoMain {}+      -> ErrorWithoutFlag+    DriverHomePackagesNotClosed {}+      -> ErrorWithoutFlag+    DriverInterfaceError reason -> diagnosticReason reason+    DriverInconsistentDynFlags {}+      -> WarningWithFlag Opt_WarnInconsistentFlags+    DriverSafeHaskellIgnoredExtension {}+      -> WarningWithoutFlag+    DriverPackageTrustIgnored {}+      -> WarningWithoutFlag+    DriverUnrecognisedFlag {}+      -> WarningWithFlag Opt_WarnUnrecognisedWarningFlags+    DriverDeprecatedFlag {}+      -> WarningWithFlag Opt_WarnDeprecatedFlags+    DriverModuleGraphCycle {}+      -> ErrorWithoutFlag+    DriverInstantiationNodeInDependencyGeneration {}+      -> ErrorWithoutFlag+    DriverNoConfiguredLLVMToolchain+      -> WarningWithoutFlag++  diagnosticHints = \case+    DriverUnknownMessage m+      -> diagnosticHints m+    DriverPsHeaderMessage psMsg+      -> diagnosticHints psMsg+    DriverMissingHomeModules{}+      -> noHints+    DriverUnknownHiddenModules {}+      -> noHints+    DriverUnknownReexportedModules {}+      -> noHints+    DriverUnusedPackages{}+      -> noHints+    DriverUnnecessarySourceImports{}+      -> noHints+    DriverDuplicatedModuleDeclaration{}+      -> noHints+    DriverModuleNotFound{}+      -> noHints+    DriverFileModuleNameMismatch{}+      -> noHints+    DriverUnexpectedSignature pi_mod_name buildingCabalPackage instantiations+      -> if buildingCabalPackage == YesBuildingCabalPackage+           then [SuggestAddSignatureCabalFile pi_mod_name]+           else [SuggestSignatureInstantiations pi_mod_name (suggestInstantiatedWith pi_mod_name instantiations)]+    DriverFileNotFound{}+      -> noHints+    DriverStaticPointersNotSupported+      -> noHints+    DriverBackpackModuleNotFound{}+      -> noHints+    DriverUserDefinedRuleIgnored{}+      -> noHints+    DriverMixedSafetyImport{}+      -> noHints+    DriverCannotLoadInterfaceFile{}+      -> noHints+    DriverInferredSafeModule{}+      -> noHints+    DriverInferredSafeImport{}+      -> noHints+    DriverCannotImportUnsafeModule{}+      -> noHints+    DriverMissingSafeHaskellMode{}+      -> noHints+    DriverPackageNotTrusted{}+      -> noHints+    DriverMarkedTrustworthyButInferredSafe{}+      -> noHints+    DriverCannotImportFromUntrustedPackage{}+      -> noHints+    DriverRedirectedNoMain {}+      -> noHints+    DriverHomePackagesNotClosed {}+      -> noHints+    DriverInterfaceError reason -> diagnosticHints reason+    DriverInconsistentDynFlags {}+      -> noHints+    DriverSafeHaskellIgnoredExtension {}+      -> noHints+    DriverPackageTrustIgnored {}+      -> noHints+    DriverUnrecognisedFlag {}+      -> noHints+    DriverDeprecatedFlag {}+      -> noHints+    DriverModuleGraphCycle {}+      -> noHints+    DriverInstantiationNodeInDependencyGeneration {}+      -> noHints+    DriverNoConfiguredLLVMToolchain+      -> noHints++  diagnosticCode = constructorCode @GHC
+ GHC/Driver/Errors/Types.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}++module GHC.Driver.Errors.Types (+    GhcMessage(..)+  , AnyGhcDiagnostic+  , GhcMessageOpts(..)+  , DriverMessage(..)+  , DriverMessageOpts(..)+  , DriverMessages, PsMessage(PsHeaderMessage)+  , WarningMessages+  , ErrorMessages+  , WarnMsg+  -- * Constructors+  , ghcUnknownMessage+  -- * Utility functions+  , hoistTcRnMessage+  , hoistDsMessage+  , checkBuildingCabalPackage+  ) where++import GHC.Prelude++import Data.Bifunctor+import Data.Typeable++import GHC.Driver.DynFlags (DynFlags, PackageArg, gopt, ReexportedModule)+import GHC.Driver.Flags (GeneralFlag (Opt_BuildingCabalPackage))+import GHC.Types.Error+import GHC.Unit.Module+import GHC.Unit.Module.Graph+import GHC.Unit.State++import GHC.Parser.Errors.Types ( PsMessage(PsHeaderMessage) )+import GHC.HsToCore.Errors.Types ( DsMessage )+import GHC.Hs.Extension          (GhcTc)++import Language.Haskell.Syntax.Decls (RuleDecl)+import qualified GHC.LanguageExtensions as LangExt++import GHC.Generics ( Generic )++import GHC.Tc.Errors.Types+import GHC.Iface.Errors.Types++-- | A collection of warning messages.+-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevWarning' severity.+type WarningMessages = Messages GhcMessage++-- | A collection of error messages.+-- /INVARIANT/: Each 'GhcMessage' in the collection should have 'SevError' severity.+type ErrorMessages   = Messages GhcMessage++-- | A single warning message.+-- /INVARIANT/: It must have 'SevWarning' severity.+type WarnMsg         = MsgEnvelope GhcMessage+++{- Note [GhcMessage]+~~~~~~~~~~~~~~~~~~~~++We might need to report diagnostics (error and/or warnings) to the users. The+'GhcMessage' type is the root of the diagnostic hierarchy.++It's useful to have a separate type constructor for the different stages of+the compilation pipeline. This is not just helpful for tools, as it gives a+clear indication on where the error occurred exactly. Furthermore it increases+the modularity amongst the different components of GHC (i.e. to avoid having+"everything depend on everything else") and allows us to write separate+functions that renders the different kind of messages.++-}++-- | The umbrella type that encompasses all the different messages that GHC+-- might output during the different compilation stages. See+-- Note [GhcMessage].+data GhcMessage where+  -- | A message from the parsing phase.+  GhcPsMessage      :: PsMessage -> GhcMessage+  -- | A message from typecheck/renaming phase.+  GhcTcRnMessage    :: TcRnMessage -> GhcMessage+  -- | A message from the desugaring (HsToCore) phase.+  GhcDsMessage      :: DsMessage -> GhcMessage+  -- | A message from the driver.+  GhcDriverMessage  :: DriverMessage -> GhcMessage++  -- | An \"escape\" hatch which can be used when we don't know the source of+  -- the message or if the message is not one of the typed ones. The+  -- 'Diagnostic' and 'Typeable' constraints ensure that if we /know/, at+  -- pattern-matching time, the originating type, we can attempt a cast and+  -- access the fully-structured error. This would be the case for a GHC+  -- plugin that offers a domain-specific error type but that doesn't want to+  -- place the burden on IDEs/application code to \"know\" it. The+  -- 'Diagnostic' constraint ensures that worst case scenario we can still+  -- render this into something which can be eventually converted into a+  -- 'DecoratedSDoc'.+  GhcUnknownMessage :: (UnknownDiagnosticFor GhcMessage) -> GhcMessage++  deriving Generic++type AnyGhcDiagnostic = UnknownDiagnosticFor GhcMessage++data GhcMessageOpts = GhcMessageOpts { psMessageOpts :: DiagnosticOpts PsMessage+                                     , tcMessageOpts :: DiagnosticOpts TcRnMessage+                                     , dsMessageOpts :: DiagnosticOpts DsMessage+                                     , driverMessageOpts :: DiagnosticOpts DriverMessage+                                     }++-- | Creates a new 'GhcMessage' out of any diagnostic. This function is also+-- provided to ease the integration of #18516 by allowing diagnostics to be+-- wrapped into the general (but structured) 'GhcMessage' type, so that the+-- conversion can happen gradually. This function should not be needed within+-- GHC, as it would typically be used by plugin or library authors (see+-- comment for the 'GhcUnknownMessage' type constructor)+ghcUnknownMessage :: (DiagnosticOpts a ~ NoDiagnosticOpts, DiagnosticHint a ~ DiagnosticHint GhcMessage, Diagnostic a, Typeable a) => a -> GhcMessage+ghcUnknownMessage = GhcUnknownMessage . mkSimpleUnknownDiagnostic++-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on+-- the result of 'IO (Messages TcRnMessage, a)'.+hoistTcRnMessage :: Monad m => m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)+hoistTcRnMessage = fmap (first (fmap GhcTcRnMessage))++-- | Abstracts away the frequent pattern where we are calling 'ioMsgMaybe' on+-- the result of 'IO (Messages DsMessage, a)'.+hoistDsMessage :: Monad m => m (Messages DsMessage, a) -> m (Messages GhcMessage, a)+hoistDsMessage = fmap (first (fmap GhcDsMessage))++-- | A collection of driver messages+type DriverMessages = Messages DriverMessage++-- | A message from the driver.+data DriverMessage where+  -- | Simply wraps a generic 'Diagnostic' message @a@.+  DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage++  -- | A parse error in parsing a Haskell file header during dependency+  -- analysis+  DriverPsHeaderMessage :: !PsMessage -> DriverMessage++  {-| DriverMissingHomeModules is a warning (controlled with -Wmissing-home-modules) that+      arises when running GHC in --make mode when some modules needed for compilation+      are not included on the command line. For example, if A imports B, `ghc --make+      A.hs` will cause this warning, while `ghc --make A.hs B.hs` will not.++      Useful for cabal to ensure GHC won't pick up modules listed neither in+      'exposed-modules' nor in 'other-modules'.++      Test case: warnings/should_compile/MissingMod++  -}+  DriverMissingHomeModules :: UnitId -> [ModuleName] -> !BuildingCabalPackage -> DriverMessage++  {-| DriverUnknown is a warning that arises when a user tries to+      reexport a module which isn't part of that unit.+  -}+  DriverUnknownReexportedModules :: UnitId -> [ReexportedModule] -> DriverMessage++  {-| DriverUnknownHiddenModules is a warning that arises when a user tries to+      hide a module which isn't part of that unit.+  -}+  DriverUnknownHiddenModules :: UnitId -> [ModuleName] -> DriverMessage++  {-| DriverUnusedPackages occurs when when package is requested on command line,+      but was never needed during compilation. Activated by -Wunused-packages.++     Test cases: warnings/should_compile/UnusedPackages+  -}+  DriverUnusedPackages :: [(UnitId, PackageName, Version, PackageArg)] -> DriverMessage++  {-| DriverUnnecessarySourceImports (controlled with -Wunused-imports) occurs if there+      are {-# SOURCE #-} imports which are not necessary. See 'warnUnnecessarySourceImports'+      in 'GHC.Driver.Make'.++     Test cases: warnings/should_compile/T10637+  -}+  DriverUnnecessarySourceImports :: !ModuleName -> DriverMessage++  {-| DriverDuplicatedModuleDeclaration occurs if a module 'A' is declared in+       multiple files.++     Test cases: None.+  -}+  DriverDuplicatedModuleDeclaration :: !Module -> [FilePath] -> DriverMessage++  {-| DriverModuleNotFound occurs if a module 'A' can't be found.++     Test cases: None.+  -}+  DriverModuleNotFound :: !UnitId -> !ModuleName -> DriverMessage++  {-| DriverFileModuleNameMismatch occurs if a module 'A' is defined in a file with a different name.+      The first field is the name written in the source code; the second argument is the name extracted+      from the filename.++     Test cases: module/mod178, /driver/bug1677+  -}+  DriverFileModuleNameMismatch :: !ModuleName -> !ModuleName -> DriverMessage++  {-| DriverUnexpectedSignature occurs when GHC encounters a module 'A' that imports a signature+      file which is neither in the 'signatures' section of a '.cabal' file nor in any package in+      the home modules.++      Example:++      -- MyStr.hsig is defined, but not added to 'signatures' in the '.cabal' file.+      signature MyStr where+          data Str++      -- A.hs, which tries to import the signature.+      module A where+      import MyStr+++     Test cases: driver/T12955+  -}+  DriverUnexpectedSignature :: !ModuleName -> !BuildingCabalPackage -> GenInstantiations UnitId -> DriverMessage++  {-| DriverFileNotFound occurs when the input file (e.g. given on the command line) can't be found.++     Test cases: None.+  -}+  DriverFileNotFound :: !FilePath -> DriverMessage++  {-| DriverStaticPointersNotSupported occurs when the 'StaticPointers' extension is used+       in an interactive GHCi context.++     Test cases: ghci/scripts/StaticPtr+  -}+  DriverStaticPointersNotSupported :: DriverMessage++  {-| DriverBackpackModuleNotFound occurs when Backpack can't find a particular module+      during its dependency analysis.++     Test cases: -+  -}+  DriverBackpackModuleNotFound :: !ModuleName -> DriverMessage++  {-| DriverUserDefinedRuleIgnored is a warning that occurs when user-defined rules+      are ignored. This typically happens when Safe Haskell.++     Test cases:++       tests/safeHaskell/safeInfered/UnsafeWarn05+       tests/safeHaskell/safeInfered/UnsafeWarn06+       tests/safeHaskell/safeInfered/UnsafeWarn07+       tests/safeHaskell/safeInfered/UnsafeInfered11+       tests/safeHaskell/safeLanguage/SafeLang03+  -}+  DriverUserDefinedRuleIgnored :: !(RuleDecl GhcTc) -> DriverMessage++  {-| DriverMixedSafetyImport is an error that occurs when a module is imported+      both as safe and unsafe.++    Test cases:++      tests/safeHaskell/safeInfered/Mixed03+      tests/safeHaskell/safeInfered/Mixed02++  -}+  DriverMixedSafetyImport :: !ModuleName -> DriverMessage++  {-| DriverCannotLoadInterfaceFile is an error that occurs when we cannot load the interface+      file for a particular module. This can happen for example in the context of Safe Haskell,+      when we have to load a module to check if it can be safely imported.++    Test cases: None.++  -}+  DriverCannotLoadInterfaceFile :: !Module -> DriverMessage++  {-| DriverInferredSafeImport is a warning (controlled by the Opt_WarnSafe flag)+      that occurs when a module is inferred safe.++    Test cases: None.++  -}+  DriverInferredSafeModule :: !Module -> DriverMessage++  {-| DriverMarkedTrustworthyButInferredSafe is a warning (controlled by the Opt_WarnTrustworthySafe flag)+      that occurs when a module is marked trustworthy in SafeHaskell but it has been inferred safe.++    Test cases:+      tests/safeHaskell/safeInfered/TrustworthySafe02+      tests/safeHaskell/safeInfered/TrustworthySafe03++  -}+  DriverMarkedTrustworthyButInferredSafe :: !Module -> DriverMessage++  {-| DriverInferredSafeImport is a warning (controlled by the Opt_WarnInferredSafeImports flag)+      that occurs when a safe-inferred module is imported from a safe module.++    Test cases: None.++  -}+  DriverInferredSafeImport :: !Module -> DriverMessage++  {-| DriverCannotImportUnsafeModule is an error that occurs when an usafe module+      is being imported from a safe one.++    Test cases: None.++  -}+  DriverCannotImportUnsafeModule :: !Module -> DriverMessage++  {-| DriverMissingSafeHaskellMode is a warning (controlled by the Opt_WarnMissingSafeHaskellMode flag)+      that occurs when a module is using SafeHaskell features but SafeHaskell mode is not enabled.++    Test cases: None.++  -}+  DriverMissingSafeHaskellMode :: !Module -> DriverMessage++  {-| DriverPackageNotTrusted is an error that occurs when a package is required to be trusted+      but it isn't.++    Test cases:+      tests/safeHaskell/check/Check01+      tests/safeHaskell/check/Check08+      tests/safeHaskell/check/Check06+      tests/safeHaskell/check/pkg01/ImpSafeOnly09+      tests/safeHaskell/check/pkg01/ImpSafe03+      tests/safeHaskell/check/pkg01/ImpSafeOnly07+      tests/safeHaskell/check/pkg01/ImpSafeOnly08++  -}+  DriverPackageNotTrusted :: !UnitState -> !UnitId -> DriverMessage++  {-| DriverCannotImportFromUntrustedPackage is an error that occurs in the context of+      Safe Haskell when trying to import a module coming from an untrusted package.++    Test cases:+      tests/safeHaskell/check/Check09+      tests/safeHaskell/check/pkg01/ImpSafe01+      tests/safeHaskell/check/pkg01/ImpSafe04+      tests/safeHaskell/check/pkg01/ImpSafeOnly03+      tests/safeHaskell/check/pkg01/ImpSafeOnly05+      tests/safeHaskell/flags/SafeFlags17+      tests/safeHaskell/flags/SafeFlags22+      tests/safeHaskell/flags/SafeFlags23+      tests/safeHaskell/ghci/p11+      tests/safeHaskell/ghci/p12+      tests/safeHaskell/ghci/p17+      tests/safeHaskell/ghci/p3+      tests/safeHaskell/safeInfered/UnsafeInfered01+      tests/safeHaskell/safeInfered/UnsafeInfered02+      tests/safeHaskell/safeInfered/UnsafeInfered02+      tests/safeHaskell/safeInfered/UnsafeInfered03+      tests/safeHaskell/safeInfered/UnsafeInfered05+      tests/safeHaskell/safeInfered/UnsafeInfered06+      tests/safeHaskell/safeInfered/UnsafeInfered09+      tests/safeHaskell/safeInfered/UnsafeInfered10+      tests/safeHaskell/safeInfered/UnsafeInfered11+      tests/safeHaskell/safeInfered/UnsafeWarn01+      tests/safeHaskell/safeInfered/UnsafeWarn03+      tests/safeHaskell/safeInfered/UnsafeWarn04+      tests/safeHaskell/safeInfered/UnsafeWarn05+      tests/safeHaskell/unsafeLibs/BadImport01+      tests/safeHaskell/unsafeLibs/BadImport06+      tests/safeHaskell/unsafeLibs/BadImport07+      tests/safeHaskell/unsafeLibs/BadImport08+      tests/safeHaskell/unsafeLibs/BadImport09+      tests/safeHaskell/unsafeLibs/Dep05+      tests/safeHaskell/unsafeLibs/Dep06+      tests/safeHaskell/unsafeLibs/Dep07+      tests/safeHaskell/unsafeLibs/Dep08+      tests/safeHaskell/unsafeLibs/Dep09+      tests/safeHaskell/unsafeLibs/Dep10++  -}+  DriverCannotImportFromUntrustedPackage :: !UnitState -> !Module -> DriverMessage++  DriverRedirectedNoMain :: !ModuleName -> DriverMessage++  DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage++  DriverInterfaceError :: !IfaceMessage -> DriverMessage++  -- TODO: Add structure messages rather than a String+  DriverInconsistentDynFlags :: String -> DriverMessage++  DriverSafeHaskellIgnoredExtension :: !LangExt.Extension -> DriverMessage++  DriverPackageTrustIgnored :: DriverMessage++  DriverUnrecognisedFlag :: String -> DriverMessage++  DriverDeprecatedFlag :: String -> String -> DriverMessage++  {-| DriverModuleGraphCycle is an error that occurs if the module graph+       contains cyclic imports.++  Test cases:+    tests/backpack/should_fail/bkpfail51+    tests/driver/T20459+    tests/driver/T24196/T24196+    tests/driver/T24275/T24275++  -}+  DriverModuleGraphCycle :: [ModuleGraphNode] -> DriverMessage++  {- | DriverInstantiationNodeInDependencyGeneration is an error that occurs+       if the module graph used for dependency generation contains+       Backpack 'InstantiationNode's. -}+  DriverInstantiationNodeInDependencyGeneration :: InstantiatedUnit -> DriverMessage++  {-| DriverNoConfiguredLLVMToolchain is an error that occurs if there is no+     LLVM toolchain configured but -fllvm is passed as an option to the compiler.++    Test cases: None.++  -}+  DriverNoConfiguredLLVMToolchain :: DriverMessage++deriving instance Generic DriverMessage++data DriverMessageOpts =+  DriverMessageOpts { psDiagnosticOpts :: DiagnosticOpts PsMessage+                    , ifaceDiagnosticOpts :: DiagnosticOpts IfaceMessage }+++-- | Checks if we are building a cabal package by consulting the 'DynFlags'.+checkBuildingCabalPackage :: DynFlags -> BuildingCabalPackage+checkBuildingCabalPackage dflags =+  if gopt Opt_BuildingCabalPackage dflags+     then YesBuildingCabalPackage+     else NoBuildingCabalPackage
+ GHC/Driver/Flags.hs view
@@ -0,0 +1,1435 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Driver.Flags+   ( DumpFlag(..)+   , getDumpFlagFrom+   , enabledIfVerbose+   , GeneralFlag(..)+   , Language(..)+   , defaultLanguage+   , optimisationFlags+   , codeGenFlags++   -- * Warnings+   , WarningGroup(..)+   , warningGroupName+   , warningGroupFlags+   , warningGroupIncludesExtendedWarnings+   , WarningFlag(..)+   , warnFlagNames+   , warningGroups+   , warningHierarchies+   , smallestWarningGroups+   , smallestWarningGroupsForCategory++   , standardWarnings+   , minusWOpts+   , minusWallOpts+   , minusWeverythingOpts+   , minusWcompatOpts+   , unusedBindsFlags++   , OnOff(..)+   , TurnOnFlag+   , turnOn+   , turnOff+   , impliedXFlags+   , validHoleFitsImpliedGFlags+   , impliedGFlags+   , impliedOffGFlags+   , glasgowExtsFlags++   , ExtensionDeprecation(..)+   , Deprecation(..)+   , extensionDeprecation+   , deprecation+   , extensionNames+   , extensionName+   )+where++import GHC.Prelude+import GHC.Utils.Outputable+import GHC.Utils.Binary+import GHC.Data.EnumSet as EnumSet++import Control.DeepSeq+import Control.Monad (guard)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe,mapMaybe)++import qualified GHC.LanguageExtensions as LangExt++data Language = Haskell98 | Haskell2010 | GHC2021 | GHC2024+   deriving (Eq, Enum, Show, Bounded)++-- | The default Language is used if one is not specified explicitly, by both+-- GHC and GHCi.+defaultLanguage :: Language+defaultLanguage = GHC2021++instance Outputable Language where+    ppr = text . show++instance Binary Language where+  put_ bh = put_ bh . fromEnum+  get bh = toEnum <$> get bh++instance NFData Language where+  rnf Haskell98 = ()+  rnf Haskell2010 = ()+  rnf GHC2021 = ()+  rnf GHC2024 = ()++data OnOff a = On a+             | Off a+  deriving (Eq, Show)++instance Outputable a => Outputable (OnOff a) where+  ppr (On x)  = text "On" <+> ppr x+  ppr (Off x) = text "Off" <+> ppr x++type TurnOnFlag = Bool   -- True  <=> we are turning the flag on+                         -- False <=> we are turning the flag off+turnOn  :: TurnOnFlag; turnOn  = True+turnOff :: TurnOnFlag; turnOff = False++data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)++data ExtensionDeprecation+  = ExtensionNotDeprecated+  | ExtensionDeprecatedFor [LangExt.Extension]+  | ExtensionFlagDeprecatedCond TurnOnFlag String+  | ExtensionFlagDeprecated String+  deriving Eq++-- | Always returns 'Deprecated' even when the flag is+-- only conditionally deprecated.+deprecation :: ExtensionDeprecation -> Deprecation+deprecation ExtensionNotDeprecated = NotDeprecated+deprecation _ = Deprecated++extensionDeprecation :: LangExt.Extension -> ExtensionDeprecation+extensionDeprecation = \case+  LangExt.TypeInType           -> ExtensionDeprecatedFor [LangExt.DataKinds, LangExt.PolyKinds]+  LangExt.NullaryTypeClasses   -> ExtensionDeprecatedFor [LangExt.MultiParamTypeClasses]+  LangExt.RelaxedPolyRec       -> ExtensionFlagDeprecatedCond turnOff+                                    "You can't turn off RelaxedPolyRec any more"+  LangExt.DatatypeContexts     -> ExtensionFlagDeprecatedCond turnOn+                                    "It was widely considered a misfeature, and has been removed from the Haskell language."+  LangExt.AutoDeriveTypeable   -> ExtensionFlagDeprecatedCond turnOn+                                    "Typeable instances are created automatically for all types since GHC 8.2."+  LangExt.OverlappingInstances -> ExtensionFlagDeprecated+                                    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS"+  _                            -> ExtensionNotDeprecated+++extensionName :: LangExt.Extension -> String+extensionName = \case+  LangExt.Cpp -> "CPP"+  LangExt.OverlappingInstances -> "OverlappingInstances"+  LangExt.UndecidableInstances -> "UndecidableInstances"+  LangExt.IncoherentInstances -> "IncoherentInstances"+  LangExt.UndecidableSuperClasses -> "UndecidableSuperClasses"+  LangExt.MonomorphismRestriction -> "MonomorphismRestriction"+  LangExt.MonoLocalBinds -> "MonoLocalBinds"+  LangExt.DeepSubsumption -> "DeepSubsumption"+  LangExt.RelaxedPolyRec -> "RelaxedPolyRec"           -- Deprecated+  LangExt.ExtendedDefaultRules -> "ExtendedDefaultRules"     -- Use GHC's extended rules for defaulting+  LangExt.NamedDefaults -> "NamedDefaults"+  LangExt.ForeignFunctionInterface -> "ForeignFunctionInterface"+  LangExt.UnliftedFFITypes -> "UnliftedFFITypes"+  LangExt.InterruptibleFFI -> "InterruptibleFFI"+  LangExt.CApiFFI -> "CApiFFI"+  LangExt.GHCForeignImportPrim -> "GHCForeignImportPrim"+  LangExt.JavaScriptFFI -> "JavaScriptFFI"+  LangExt.ParallelArrays -> "ParallelArrays"           -- Syntactic support for parallel arrays+  LangExt.Arrows -> "Arrows"                   -- Arrow-notation syntax+  LangExt.TemplateHaskell -> "TemplateHaskell"+  LangExt.TemplateHaskellQuotes -> "TemplateHaskellQuotes"    -- subset of TH supported by stage1, no splice+  LangExt.QualifiedDo -> "QualifiedDo"+  LangExt.QuasiQuotes -> "QuasiQuotes"+  LangExt.ImplicitParams -> "ImplicitParams"+  LangExt.ImplicitPrelude -> "ImplicitPrelude"+  LangExt.ScopedTypeVariables -> "ScopedTypeVariables"+  LangExt.AllowAmbiguousTypes -> "AllowAmbiguousTypes"+  LangExt.UnboxedTuples -> "UnboxedTuples"+  LangExt.UnboxedSums -> "UnboxedSums"+  LangExt.UnliftedNewtypes -> "UnliftedNewtypes"+  LangExt.UnliftedDatatypes -> "UnliftedDatatypes"+  LangExt.BangPatterns -> "BangPatterns"+  LangExt.TypeFamilies -> "TypeFamilies"+  LangExt.TypeFamilyDependencies -> "TypeFamilyDependencies"+  LangExt.TypeInType -> "TypeInType"               -- Deprecated+  LangExt.OverloadedStrings -> "OverloadedStrings"+  LangExt.OverloadedLists -> "OverloadedLists"+  LangExt.NumDecimals -> "NumDecimals"+  LangExt.OrPatterns -> "OrPatterns"+  LangExt.DisambiguateRecordFields -> "DisambiguateRecordFields"+  LangExt.RecordWildCards -> "RecordWildCards"+  LangExt.NamedFieldPuns -> "NamedFieldPuns"+  LangExt.ViewPatterns -> "ViewPatterns"+  LangExt.GADTs -> "GADTs"+  LangExt.GADTSyntax -> "GADTSyntax"+  LangExt.NPlusKPatterns -> "NPlusKPatterns"+  LangExt.DoAndIfThenElse -> "DoAndIfThenElse"+  LangExt.BlockArguments -> "BlockArguments"+  LangExt.RebindableSyntax -> "RebindableSyntax"+  LangExt.ConstraintKinds -> "ConstraintKinds"+  LangExt.PolyKinds -> "PolyKinds"                -- Kind polymorphism+  LangExt.DataKinds -> "DataKinds"                -- Datatype promotion+  LangExt.TypeData -> "TypeData"                 -- allow @type data@ definitions+  LangExt.InstanceSigs -> "InstanceSigs"+  LangExt.ApplicativeDo -> "ApplicativeDo"+  LangExt.LinearTypes -> "LinearTypes"+  LangExt.RequiredTypeArguments -> "RequiredTypeArguments"    -- Visible forall (VDQ) in types of terms+  LangExt.StandaloneDeriving -> "StandaloneDeriving"+  LangExt.DeriveDataTypeable -> "DeriveDataTypeable"+  LangExt.AutoDeriveTypeable -> "AutoDeriveTypeable"       -- Automatic derivation of Typeable+  LangExt.DeriveFunctor -> "DeriveFunctor"+  LangExt.DeriveTraversable -> "DeriveTraversable"+  LangExt.DeriveFoldable -> "DeriveFoldable"+  LangExt.DeriveGeneric -> "DeriveGeneric"            -- Allow deriving Generic/1+  LangExt.DefaultSignatures -> "DefaultSignatures"        -- Allow extra signatures for defmeths+  LangExt.DeriveAnyClass -> "DeriveAnyClass"           -- Allow deriving any class+  LangExt.DeriveLift -> "DeriveLift"               -- Allow deriving Lift+  LangExt.DerivingStrategies -> "DerivingStrategies"+  LangExt.DerivingVia -> "DerivingVia"              -- Derive through equal representation+  LangExt.TypeSynonymInstances -> "TypeSynonymInstances"+  LangExt.FlexibleContexts -> "FlexibleContexts"+  LangExt.FlexibleInstances -> "FlexibleInstances"+  LangExt.ConstrainedClassMethods -> "ConstrainedClassMethods"+  LangExt.MultiParamTypeClasses -> "MultiParamTypeClasses"+  LangExt.NullaryTypeClasses -> "NullaryTypeClasses"+  LangExt.FunctionalDependencies -> "FunctionalDependencies"+  LangExt.UnicodeSyntax -> "UnicodeSyntax"+  LangExt.ExistentialQuantification -> "ExistentialQuantification"+  LangExt.MagicHash -> "MagicHash"+  LangExt.EmptyDataDecls -> "EmptyDataDecls"+  LangExt.KindSignatures -> "KindSignatures"+  LangExt.RoleAnnotations -> "RoleAnnotations"+  LangExt.ParallelListComp -> "ParallelListComp"+  LangExt.TransformListComp -> "TransformListComp"+  LangExt.MonadComprehensions -> "MonadComprehensions"+  LangExt.GeneralizedNewtypeDeriving -> "GeneralizedNewtypeDeriving"+  LangExt.RecursiveDo -> "RecursiveDo"+  LangExt.PostfixOperators -> "PostfixOperators"+  LangExt.TupleSections -> "TupleSections"+  LangExt.PatternGuards -> "PatternGuards"+  LangExt.LiberalTypeSynonyms -> "LiberalTypeSynonyms"+  LangExt.RankNTypes -> "RankNTypes"+  LangExt.ImpredicativeTypes -> "ImpredicativeTypes"+  LangExt.TypeOperators -> "TypeOperators"+  LangExt.ExplicitNamespaces -> "ExplicitNamespaces"+  LangExt.PackageImports -> "PackageImports"+  LangExt.ExplicitForAll -> "ExplicitForAll"+  LangExt.AlternativeLayoutRule -> "AlternativeLayoutRule"+  LangExt.AlternativeLayoutRuleTransitional -> "AlternativeLayoutRuleTransitional"+  LangExt.DatatypeContexts -> "DatatypeContexts"+  LangExt.NondecreasingIndentation -> "NondecreasingIndentation"+  LangExt.RelaxedLayout -> "RelaxedLayout"+  LangExt.TraditionalRecordSyntax -> "TraditionalRecordSyntax"+  LangExt.LambdaCase -> "LambdaCase"+  LangExt.MultiWayIf -> "MultiWayIf"+  LangExt.BinaryLiterals -> "BinaryLiterals"+  LangExt.NegativeLiterals -> "NegativeLiterals"+  LangExt.HexFloatLiterals -> "HexFloatLiterals"+  LangExt.DuplicateRecordFields -> "DuplicateRecordFields"+  LangExt.OverloadedLabels -> "OverloadedLabels"+  LangExt.EmptyCase -> "EmptyCase"+  LangExt.PatternSynonyms -> "PatternSynonyms"+  LangExt.PartialTypeSignatures -> "PartialTypeSignatures"+  LangExt.NamedWildCards -> "NamedWildCards"+  LangExt.StaticPointers -> "StaticPointers"+  LangExt.TypeApplications -> "TypeApplications"+  LangExt.Strict -> "Strict"+  LangExt.StrictData -> "StrictData"+  LangExt.EmptyDataDeriving -> "EmptyDataDeriving"+  LangExt.NumericUnderscores -> "NumericUnderscores"+  LangExt.QuantifiedConstraints -> "QuantifiedConstraints"+  LangExt.StarIsType -> "StarIsType"+  LangExt.ImportQualifiedPost -> "ImportQualifiedPost"+  LangExt.CUSKs -> "CUSKs"+  LangExt.StandaloneKindSignatures -> "StandaloneKindSignatures"+  LangExt.LexicalNegation -> "LexicalNegation"+  LangExt.FieldSelectors -> "FieldSelectors"+  LangExt.OverloadedRecordDot -> "OverloadedRecordDot"+  LangExt.OverloadedRecordUpdate -> "OverloadedRecordUpdate"+  LangExt.TypeAbstractions -> "TypeAbstractions"+  LangExt.ExtendedLiterals -> "ExtendedLiterals"+  LangExt.ListTuplePuns -> "ListTuplePuns"+  LangExt.MultilineStrings -> "MultilineStrings"+  LangExt.ExplicitLevelImports -> "ExplicitLevelImports"+  LangExt.ImplicitStagePersistence -> "ImplicitStagePersistence"++-- | Is this extension known by any other names? For example+-- -XGeneralizedNewtypeDeriving is accepted+extensionAlternateNames :: LangExt.Extension -> [String]+extensionAlternateNames = \case+  LangExt.GeneralizedNewtypeDeriving -> ["GeneralisedNewtypeDeriving"]+  LangExt.RankNTypes                 -> ["Rank2Types", "PolymorphicComponents"]+  _ -> []++extensionDeprecatedNames :: LangExt.Extension -> [String]+extensionDeprecatedNames = \case+  LangExt.RecursiveDo         -> ["DoRec"]+  LangExt.NamedFieldPuns      -> ["RecordPuns"]+  LangExt.ScopedTypeVariables -> ["PatternSignatures"]+  _ -> []++-- | All the names by which an extension is known.+extensionNames :: LangExt.Extension -> [ (ExtensionDeprecation, String) ]+extensionNames ext = mk (extensionDeprecation ext)     (extensionName ext : extensionAlternateNames ext)+                  ++ mk (ExtensionDeprecatedFor [ext]) (extensionDeprecatedNames ext)+  where mk depr = map (\name -> (depr, name))++impliedXFlags :: [(LangExt.Extension, OnOff LangExt.Extension)]+impliedXFlags+-- See Note [Updating flag description in the User's Guide]+  = [ (LangExt.RankNTypes,                On LangExt.ExplicitForAll)+    , (LangExt.QuantifiedConstraints,     On LangExt.ExplicitForAll)+    , (LangExt.ScopedTypeVariables,       On LangExt.ExplicitForAll)+    , (LangExt.LiberalTypeSynonyms,       On LangExt.ExplicitForAll)+    , (LangExt.ExistentialQuantification, On LangExt.ExplicitForAll)+    , (LangExt.FlexibleInstances,         On LangExt.TypeSynonymInstances)+    , (LangExt.FunctionalDependencies,    On LangExt.MultiParamTypeClasses)+    , (LangExt.MultiParamTypeClasses,     On LangExt.ConstrainedClassMethods)  -- c.f. #7854+    , (LangExt.TypeFamilyDependencies,    On LangExt.TypeFamilies)++    , (LangExt.RebindableSyntax, Off LangExt.ImplicitPrelude)      -- NB: turn off!++    , (LangExt.DerivingVia, On LangExt.DerivingStrategies)++    , (LangExt.GADTs,            On LangExt.GADTSyntax)+    , (LangExt.GADTs,            On LangExt.MonoLocalBinds)+    , (LangExt.TypeFamilies,     On LangExt.MonoLocalBinds)++    , (LangExt.TypeFamilies,     On LangExt.KindSignatures)  -- Type families use kind signatures+    , (LangExt.PolyKinds,        On LangExt.KindSignatures)  -- Ditto polymorphic kinds++    -- TypeInType is now just a synonym for a couple of other extensions.+    , (LangExt.TypeInType,       On LangExt.DataKinds)+    , (LangExt.TypeInType,       On LangExt.PolyKinds)+    , (LangExt.TypeInType,       On LangExt.KindSignatures)++    -- Standalone kind signatures are a replacement for CUSKs.+    , (LangExt.StandaloneKindSignatures, Off LangExt.CUSKs)++    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable+    , (LangExt.AutoDeriveTypeable, On LangExt.DeriveDataTypeable)++    -- We turn this on so that we can export associated type+    -- type synonyms in subordinates (e.g. MyClass(type AssocType))+    , (LangExt.TypeFamilies,     On LangExt.ExplicitNamespaces)+    , (LangExt.TypeOperators, On LangExt.ExplicitNamespaces)++    , (LangExt.ImpredicativeTypes,  On LangExt.RankNTypes)++        -- Record wild-cards implies field disambiguation+        -- Otherwise if you write (C {..}) you may well get+        -- stuff like " 'a' not in scope ", which is a bit silly+        -- if the compiler has just filled in field 'a' of constructor 'C'+    , (LangExt.RecordWildCards,     On LangExt.DisambiguateRecordFields)++    , (LangExt.ParallelArrays, On LangExt.ParallelListComp)+    , (LangExt.MonadComprehensions, On LangExt.ParallelListComp)+    , (LangExt.JavaScriptFFI, On LangExt.InterruptibleFFI)++    , (LangExt.DeriveTraversable, On LangExt.DeriveFunctor)+    , (LangExt.DeriveTraversable, On LangExt.DeriveFoldable)++    -- Duplicate record fields require field disambiguation+    , (LangExt.DuplicateRecordFields, On LangExt.DisambiguateRecordFields)++    , (LangExt.TemplateHaskell, On LangExt.TemplateHaskellQuotes)+    , (LangExt.Strict, On LangExt.StrictData)++    -- Historically only UnboxedTuples was required for unboxed sums to work.+    -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.+    , (LangExt.UnboxedTuples, On LangExt.UnboxedSums)++    -- The extensions needed to declare an H98 unlifted data type+    , (LangExt.UnliftedDatatypes, On LangExt.DataKinds)+    , (LangExt.UnliftedDatatypes, On LangExt.StandaloneKindSignatures)++    -- See (NVP3) in Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind+    , (LangExt.LinearTypes, On LangExt.MonoLocalBinds)++    , (LangExt.ExplicitLevelImports, Off LangExt.ImplicitStagePersistence)+  ]+++validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+validHoleFitsImpliedGFlags+  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)+    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]++-- | General flags that are switched on/off when other general flags are switched+-- on+impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)+                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)+                ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)+                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)+                ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface)+                ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack)+                ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback)+                ] ++ validHoleFitsImpliedGFlags++-- | General flags that are switched on/off when other general flags are switched+-- off+impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]++-- Please keep @docs/users_guide/what_glasgow_exts_does.rst@ up to date with this list.+glasgowExtsFlags :: [LangExt.Extension]+glasgowExtsFlags = [+             LangExt.ConstrainedClassMethods+           , LangExt.DeriveDataTypeable+           , LangExt.DeriveFoldable+           , LangExt.DeriveFunctor+           , LangExt.DeriveGeneric+           , LangExt.DeriveTraversable+           , LangExt.EmptyDataDecls+           , LangExt.ExistentialQuantification+           , LangExt.ExplicitNamespaces+           , LangExt.FlexibleContexts+           , LangExt.FlexibleInstances+           , LangExt.ForeignFunctionInterface+           , LangExt.FunctionalDependencies+           , LangExt.GeneralizedNewtypeDeriving+           , LangExt.ImplicitParams+           , LangExt.KindSignatures+           , LangExt.LiberalTypeSynonyms+           , LangExt.MagicHash+           , LangExt.MultiParamTypeClasses+           , LangExt.ParallelListComp+           , LangExt.PatternGuards+           , LangExt.PostfixOperators+           , LangExt.RankNTypes+           , LangExt.RecursiveDo+           , LangExt.ScopedTypeVariables+           , LangExt.StandaloneDeriving+           , LangExt.TypeOperators+           , LangExt.TypeSynonymInstances+           , LangExt.UnboxedTuples+           , LangExt.UnicodeSyntax+           , LangExt.UnliftedFFITypes ]++-- | Debugging flags+data DumpFlag+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session++   -- debugging flags+   = Opt_D_dump_cmm+   | Opt_D_dump_cmm_from_stg+   | Opt_D_dump_cmm_raw+   | Opt_D_dump_cmm_verbose_by_proc+   -- All of the cmm subflags (there are a lot!) automatically+   -- enabled if you run -ddump-cmm-verbose-by-proc+   -- Each flag corresponds to exact stage of Cmm pipeline.+   | Opt_D_dump_cmm_verbose+   -- ^ same as -ddump-cmm-verbose-by-proc but writes each stage+   -- to a separate file (if used with -ddump-to-file)+   | Opt_D_dump_cmm_cfg+   | Opt_D_dump_cmm_cbe+   | Opt_D_dump_cmm_switch+   | Opt_D_dump_cmm_proc+   | Opt_D_dump_cmm_sp+   | Opt_D_dump_cmm_sink+   | Opt_D_dump_cmm_caf+   | Opt_D_dump_cmm_procmap+   | Opt_D_dump_cmm_split+   | Opt_D_dump_cmm_info+   | Opt_D_dump_cmm_cps+   | Opt_D_dump_cmm_thread_sanitizer+   -- end cmm subflags+   | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout.+   | Opt_D_dump_asm+   | Opt_D_dump_asm_native+   | Opt_D_dump_asm_liveness+   | Opt_D_dump_asm_regalloc+   | Opt_D_dump_asm_regalloc_stages+   | Opt_D_dump_asm_conflicts+   | Opt_D_dump_asm_stats+   | Opt_D_dump_c_backend+   | Opt_D_dump_llvm+   | Opt_D_dump_js+   | Opt_D_dump_core_stats+   | Opt_D_dump_deriv+   | Opt_D_dump_ds+   | Opt_D_dump_ds_preopt+   | Opt_D_dump_foreign+   | Opt_D_dump_inlinings+   | Opt_D_dump_verbose_inlinings+   | Opt_D_dump_rule_firings+   | Opt_D_dump_rule_rewrites+   | Opt_D_dump_simpl_trace+   | Opt_D_dump_occur_anal+   | Opt_D_dump_parsed+   | Opt_D_dump_parsed_ast+   | Opt_D_dump_rn+   | Opt_D_dump_rn_ast+   | Opt_D_dump_simpl+   | Opt_D_dump_simpl_iterations+   | Opt_D_dump_spec+   | Opt_D_dump_spec_constr+   | Opt_D_dump_prep+   | Opt_D_dump_late_cc+   | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output)+   | Opt_D_dump_stg_unarised  -- ^ STG after unarise+   | Opt_D_dump_stg_cg        -- ^ STG (after stg2stg)+   | Opt_D_dump_stg_tags      -- ^ Result of tag inference analysis.+   | Opt_D_dump_stg_final     -- ^ Final STG (before cmm gen)+   | Opt_D_dump_stg_from_js_sinker -- ^ STG after JS sinker+   | Opt_D_dump_call_arity+   | Opt_D_dump_exitify+   | Opt_D_dump_dmdanal+   | Opt_D_dump_dmd_signatures+   | Opt_D_dump_cpranal+   | Opt_D_dump_cpr_signatures+   | Opt_D_dump_tc+   | Opt_D_dump_tc_ast+   | Opt_D_dump_hie+   | Opt_D_dump_types+   | Opt_D_dump_rules+   | Opt_D_dump_cse+   | Opt_D_dump_float_out+   | Opt_D_dump_float_in+   | Opt_D_dump_liberate_case+   | Opt_D_dump_static_argument_transformation+   | Opt_D_dump_worker_wrapper+   | Opt_D_dump_rn_trace+   | Opt_D_dump_rn_stats+   | Opt_D_dump_opt_cmm+   | Opt_D_dump_simpl_stats+   | Opt_D_dump_cs_trace -- ^ Constraint solver in type checker+   | Opt_D_dump_tc_trace+   | Opt_D_dump_ec_trace -- ^ Pattern match exhaustiveness checker+   | Opt_D_dump_if_trace+   | Opt_D_dump_splices+   | Opt_D_th_dec_file+   | Opt_D_dump_BCOs+   | Opt_D_dump_ticked+   | Opt_D_dump_rtti+   | Opt_D_source_stats+   | Opt_D_verbose_stg2stg+   | Opt_D_dump_hi+   | Opt_D_dump_hi_diffs+   | Opt_D_dump_mod_cycles+   | Opt_D_dump_mod_map+   | Opt_D_dump_timings+   | Opt_D_dump_view_pattern_commoning+   | Opt_D_verbose_core2core+   | Opt_D_dump_debug+   | Opt_D_dump_json+   | Opt_D_ppr_debug+   | Opt_D_no_debug_output+   | Opt_D_dump_faststrings+   | Opt_D_faststring_stats+   | Opt_D_ipe_stats+   deriving (Eq, Show, Enum)++-- | Helper function to query whether a given `DumpFlag` is enabled or not.+getDumpFlagFrom+  :: (a -> Int) -- ^ Getter for verbosity setting+  -> (a -> EnumSet DumpFlag) -- ^ Getter for the set of enabled dump flags+  -> DumpFlag -> a -> Bool+getDumpFlagFrom getVerbosity getFlags f x+  =  (f `EnumSet.member` getFlags x)+  || (getVerbosity x >= 4 && enabledIfVerbose f)++-- | Is the flag implicitly enabled when the verbosity is high enough?+enabledIfVerbose :: DumpFlag -> Bool+enabledIfVerbose Opt_D_dump_tc_trace               = False+enabledIfVerbose Opt_D_dump_rn_trace               = False+enabledIfVerbose Opt_D_dump_cs_trace               = False+enabledIfVerbose Opt_D_dump_if_trace               = False+enabledIfVerbose Opt_D_dump_tc                     = False+enabledIfVerbose Opt_D_dump_rn                     = False+enabledIfVerbose Opt_D_dump_rn_stats               = False+enabledIfVerbose Opt_D_dump_hi_diffs               = False+enabledIfVerbose Opt_D_verbose_core2core           = False+enabledIfVerbose Opt_D_verbose_stg2stg             = False+enabledIfVerbose Opt_D_dump_splices                = False+enabledIfVerbose Opt_D_th_dec_file                 = False+enabledIfVerbose Opt_D_dump_rule_firings           = False+enabledIfVerbose Opt_D_dump_rule_rewrites          = False+enabledIfVerbose Opt_D_dump_simpl_trace            = False+enabledIfVerbose Opt_D_dump_rtti                   = False+enabledIfVerbose Opt_D_dump_inlinings              = False+enabledIfVerbose Opt_D_dump_verbose_inlinings      = False+enabledIfVerbose Opt_D_dump_core_stats             = False+enabledIfVerbose Opt_D_dump_asm_stats              = False+enabledIfVerbose Opt_D_dump_types                  = False+enabledIfVerbose Opt_D_dump_simpl_iterations       = False+enabledIfVerbose Opt_D_dump_ticked                 = False+enabledIfVerbose Opt_D_dump_view_pattern_commoning = False+enabledIfVerbose Opt_D_dump_mod_cycles             = False+enabledIfVerbose Opt_D_dump_mod_map                = False+enabledIfVerbose Opt_D_dump_ec_trace               = False+enabledIfVerbose _                                 = True++-- | Enumerates the simple on-or-off dynamic flags+data GeneralFlag+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session++   = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.+   | Opt_DumpWithWays                   -- ^ Use foo.ways.<dumpFlag> instead of foo.<dumpFlag>+   | Opt_D_dump_minimal_imports+   | Opt_DoCoreLinting+   | Opt_DoLinearCoreLinting+   | Opt_DoStgLinting+   | Opt_DoCmmLinting+   | Opt_DoAsmLinting+   | Opt_DoAnnotationLinting+   | Opt_DoBoundsChecking+   | Opt_AddBcoName+   | Opt_NoLlvmMangler                  -- hidden flag+   | Opt_FastLlvm                       -- hidden flag+   | Opt_NoTypeableBinds++   | Opt_DistinctConstructorTables+   | Opt_InfoTableMap+   | Opt_InfoTableMapWithFallback+   | Opt_InfoTableMapWithStack++   | Opt_WarnIsError+   -- ^ @-Werror@; makes all warnings fatal.+   -- See 'wopt_set_fatal' for making individual warnings fatal as in @-Werror=foo@.+   | Opt_ShowWarnGroups+   -- ^ Show the group a warning belongs to.+   | Opt_HideSourcePaths+   -- ^ @-fhide-source-paths@; hide module source/object paths.++   | Opt_PrintExplicitForalls+   | Opt_PrintExplicitKinds+   | Opt_PrintExplicitCoercions+   | Opt_PrintExplicitRuntimeReps+   | Opt_PrintEqualityRelations+   | Opt_PrintAxiomIncomps+   | Opt_PrintUnicodeSyntax+   | Opt_PrintExpandedSynonyms+   | Opt_PrintPotentialInstances+   | Opt_PrintRedundantPromotionTicks+   | Opt_PrintTypecheckerElaboration++   -- optimisation opts+   | Opt_CallArity+   | Opt_Exitification+   | Opt_Strictness+   | Opt_LateDmdAnal                    -- #6087+   | Opt_KillAbsence+   | Opt_KillOneShot+   | Opt_FullLaziness+   | Opt_FloatIn+   | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the+                      --   simplifier+   | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the+                               --   top level in the simplifier+                               --   N.B. See Note [RHS Floating]+   | Opt_LateSpecialise+   | Opt_Specialise+   | Opt_SpecialiseAggressively+   | Opt_CrossModuleSpecialise+   | Opt_PolymorphicSpecialisation+   | Opt_InlineGenerics+   | Opt_InlineGenericsAggressively+   | Opt_StaticArgumentTransformation+   | Opt_CSE+   | Opt_StgCSE+   | Opt_StgLiftLams+   | Opt_LiberateCase+   | Opt_SpecConstr+   | Opt_SpecConstrKeen+   | Opt_SpecialiseIncoherents+   | Opt_DoLambdaEtaExpansion+   | Opt_DoCleverArgEtaExpansion        -- See Note [Eta expansion of arguments in CorePrep]+   | Opt_IgnoreAsserts+   | Opt_DoEtaReduction+   | Opt_CaseMerge+   | Opt_CaseFolding                    -- ^ Constant folding through case-expressions+   | Opt_UnboxStrictFields+   | Opt_UnboxSmallStrictFields+   | Opt_DictsCheap+   | Opt_EnableRewriteRules             -- ^ Apply rewrite rules during simplification+   | Opt_EnableThSpliceWarnings         -- ^ Enable warnings for TH splices+   | Opt_RegsGraph                      -- ^ Do graph coloring register allocation+   | Opt_RegsIterative                  -- ^ Do iterative coalescing graph coloring register allocation+   | Opt_PedanticBottoms                -- ^ Be picky about how we treat bottom+   | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)+   | Opt_IrrefutableTuples+   | Opt_CmmSink+   | Opt_CmmStaticPred+   | Opt_CmmElimCommonBlocks+   | Opt_CmmControlFlow+   | Opt_AsmShortcutting+   | Opt_InterModuleFarJumps+   | Opt_OmitYields+   | Opt_FunToThunk                -- deprecated+   | Opt_DictsStrict               -- ^ Be strict in argument dictionaries+   | Opt_DmdTxDictSel              -- ^ deprecated, no effect and behaviour is now default.+                                   -- Allowed switching of a special demand transformer for dictionary selectors+   | Opt_Loopification             -- See Note [Self-recursive tail calls]+   | Opt_CfgBlocklayout            -- ^ Use the cfg based block layout algorithm.+   | Opt_WeightlessBlocklayout     -- ^ Layout based on last instruction per block.+   | Opt_CprAnal+   | Opt_WorkerWrapper+   | Opt_WorkerWrapperUnlift  -- ^ Do W/W split for unlifting even if we won't unbox anything.+   | Opt_SolveConstantDicts+   | Opt_AlignmentSanitisation+   | Opt_CatchNonexhaustiveCases+   | Opt_NumConstantFolding   -- ^ See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold+   | Opt_CoreConstantFolding+   | Opt_FastPAPCalls                  -- #6084+   | Opt_SpecEval+   | Opt_SpecEvalDictFun   -- See Note [Controlling Speculative Evaluation]+++   -- Inference flags+   | Opt_DoTagInferenceChecks++   -- | PreInlining is on by default. The option is there just to see how+   -- bad things get if you turn it off!+   | Opt_SimplPreInlining++   -- Interface files+   | Opt_IgnoreInterfacePragmas+   | Opt_OmitInterfacePragmas+   | Opt_ExposeAllUnfoldings+   | Opt_ExposeOverloadedUnfoldings+   | Opt_KeepAutoRules -- ^ Keep auto-generated rules even if they seem to have become useless+   | Opt_WriteInterface -- ^ Forces .hi files to be written even with -fno-code+   | Opt_WriteSelfRecompInfo+   | Opt_WriteSelfRecompFlags -- ^ Include detailed flag information for self-recompilation debugging+   | Opt_WriteHie -- ^ Generate .hie files++   -- JavaScript opts+   | Opt_DisableJsMinifier -- ^ Render JavaScript pretty-printed instead of minified (compacted)+   | Opt_DisableJsCsources -- ^ Don't link C sources (compiled to JS) with Haskell code (compiled to JS)++   -- profiling opts+   | Opt_AutoSccsOnIndividualCafs+   | Opt_ProfCountEntries+   | Opt_ProfLateInlineCcs+   | Opt_ProfLateCcs+   | Opt_ProfLateOverloadedCcs+   | Opt_ProfLateoverloadedCallsCCs+   | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations++   -- misc opts+   | Opt_Pp+   | Opt_ForceRecomp+   | Opt_IgnoreOptimChanges+   | Opt_IgnoreHpcChanges+   | Opt_ExcessPrecision+   | Opt_EagerBlackHoling+   | Opt_OrigThunkInfo+   | Opt_NoHsMain+   | Opt_SplitSections+   | Opt_StgStats+   | Opt_HideAllPackages+   | Opt_HideAllPluginPackages+   | Opt_PrintBindResult+   | Opt_Haddock+   | Opt_HaddockOptions+   | Opt_BreakOnException+   | Opt_BreakOnError+   | Opt_PrintEvldWithShow+   | Opt_PrintBindContents+   | Opt_GenManifest+   | Opt_EmbedManifest+   | Opt_SharedImplib+   | Opt_BuildingCabalPackage+   | Opt_IgnoreDotGhci+   | Opt_GhciSandbox+   | Opt_InsertBreakpoints+   | Opt_GhciHistory+   | Opt_GhciLeakCheck+   | Opt_ValidateHie+   | Opt_LocalGhciHistory+   | Opt_NoIt++   -- wasm ghci browser mode+   | Opt_GhciBrowser+   | Opt_GhciBrowserRedirectWasiConsole++   -- | Instruct GHCi to load all targets on startup+   | Opt_GhciDoLoadTargets++   | Opt_HelpfulErrors+   | Opt_DeferTypeErrors             -- Since 7.6+   | Opt_DeferTypedHoles             -- Since 7.10+   | Opt_DeferOutOfScopeVariables+   | Opt_PIC                         -- ^ @-fPIC@+   | Opt_PIE                         -- ^ @-fPIE@+   | Opt_PICExecutable               -- ^ @-pie@+   | Opt_ExternalDynamicRefs+   | Opt_Ticky+   | Opt_Ticky_Allocd+   | Opt_Ticky_LNE+   | Opt_Ticky_Dyn_Thunk+   | Opt_Ticky_Tag+   | Opt_Ticky_AP                    -- ^ Use regular thunks even when we could use std ap thunks in order to get entry counts+   | Opt_CmmThreadSanitizer+   | Opt_RPath+   | Opt_RelativeDynlibPaths+   | Opt_CompactUnwind               -- ^ @-fcompact-unwind@+   | Opt_Hpc+   | Opt_FamAppCache+   | Opt_ExternalInterpreter+   | Opt_OptimalApplicativeDo+   | Opt_VersionMacros+   | Opt_WholeArchiveHsLibs+   -- copy all libs into a single folder prior to linking binaries+   -- this should alleviate the excessive command line limit restrictions+   -- on windows, by only requiring a single -L argument instead of+   -- one for each dependency.  At the time of this writing, gcc+   -- forwards all -L flags to the collect2 command without using a+   -- response file and as such breaking apart.+   | Opt_SingleLibFolder+   | Opt_ExposeInternalSymbols+   | Opt_KeepCAFs+   | Opt_KeepGoing+   | Opt_ByteCode+   | Opt_ByteCodeAndObjectCode+   | Opt_UnoptimizedCoreForInterpreter+   | Opt_LinkRts++   -- output style opts+   | Opt_ErrorSpans -- ^ Include full span info in error messages,+                    -- instead of just the start position.+   | Opt_DeferDiagnostics+   | Opt_DiagnosticsAsJSON  -- ^ Dump diagnostics as JSON+   | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code+   | Opt_PprCaseAsLet+   | Opt_PprShowTicks+   | Opt_ShowHoleConstraints+    -- Options relating to the display of valid hole fits+    -- when generating an error message for a typed hole+    -- See Note [Valid hole fits include ...] in GHC.Tc.Errors.Hole+   | Opt_ShowValidHoleFits+   | Opt_SortValidHoleFits+   | Opt_SortBySizeHoleFits+   | Opt_SortBySubsumHoleFits+   | Opt_AbstractRefHoleFits+   | Opt_UnclutterValidHoleFits+   | Opt_ShowTypeAppOfHoleFits+   | Opt_ShowTypeAppVarsOfHoleFits+   | Opt_ShowDocsOfHoleFits+   | Opt_ShowTypeOfHoleFits+   | Opt_ShowProvOfHoleFits+   | Opt_ShowMatchesOfHoleFits++   | Opt_ShowLoadedModules+   | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals]++   -- | Suppress a coercions inner structure, replacing it with '...'+   | Opt_SuppressCoercions+   -- | Suppress the type of a coercion as well+   | Opt_SuppressCoercionTypes+   | Opt_SuppressVarKinds+   -- | Suppress module id prefixes on variables.+   | Opt_SuppressModulePrefixes+   -- | Suppress type applications.+   | Opt_SuppressTypeApplications+   -- | Suppress info such as arity and unfoldings on identifiers.+   | Opt_SuppressIdInfo+   -- | Suppress separate type signatures in core, but leave types on+   -- lambda bound vars+   | Opt_SuppressUnfoldings+   -- | Suppress the details of even stable unfoldings+   | Opt_SuppressTypeSignatures+   -- | Suppress unique ids on variables.+   -- Except for uniques, as some simplifier phases introduce new+   -- variables that have otherwise identical names.+   | Opt_SuppressUniques+   | Opt_SuppressStgExts+   | Opt_SuppressStgReps+   | Opt_SuppressTicks      -- ^ Replaces Opt_PprShowTicks+   | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps+   | Opt_SuppressCoreSizes  -- ^ Suppress per binding Core size stats in dumps++   -- Error message suppression+   | Opt_ShowErrorContext++   -- Object code determinism+   | Opt_ObjectDeterminism++   -- temporary flags+   | Opt_AutoLinkPackages+   | Opt_ImplicitImportQualified++   -- keeping stuff+   | Opt_KeepHscppFiles+   | Opt_KeepHiDiffs+   | Opt_KeepHcFiles+   | Opt_KeepSFiles+   | Opt_KeepTmpFiles+   | Opt_KeepRawTokenStream+   | Opt_KeepLlvmFiles+   | Opt_KeepHiFiles+   | Opt_KeepOFiles++   | Opt_BuildDynamicToo+   | Opt_WriteIfSimplifiedCore+   | Opt_UseBytecodeRatherThanObjects++   -- safe haskell flags+   | Opt_DistrustAllPackages+   | Opt_PackageTrust+   | Opt_PluginTrustworthy++   | Opt_G_NoStateHack+   | Opt_G_NoOptCoercion+   deriving (Eq, Show, Enum)++-- | The set of flags which affect optimisation for the purposes of+-- recompilation avoidance. Specifically, these include flags which+-- affect code generation but not the semantics of the program.+--+-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags)+optimisationFlags :: EnumSet GeneralFlag+optimisationFlags = EnumSet.fromList+   [ Opt_CallArity+   , Opt_Strictness+   , Opt_LateDmdAnal+   , Opt_KillAbsence+   , Opt_KillOneShot+   , Opt_FullLaziness+   , Opt_FloatIn+   , Opt_LateSpecialise+   , Opt_Specialise+   , Opt_SpecialiseAggressively+   , Opt_CrossModuleSpecialise+   , Opt_StaticArgumentTransformation+   , Opt_CSE+   , Opt_StgCSE+   , Opt_StgLiftLams+   , Opt_LiberateCase+   , Opt_SpecConstr+   , Opt_SpecConstrKeen+   , Opt_DoLambdaEtaExpansion+   , Opt_IgnoreAsserts+   , Opt_DoEtaReduction+   , Opt_CaseMerge+   , Opt_CaseFolding+   , Opt_UnboxStrictFields+   , Opt_UnboxSmallStrictFields+   , Opt_DictsCheap+   , Opt_EnableRewriteRules+   , Opt_RegsGraph+   , Opt_RegsIterative+   , Opt_IrrefutableTuples+   , Opt_CmmSink+   , Opt_CmmElimCommonBlocks+   , Opt_AsmShortcutting+   , Opt_InterModuleFarJumps+   , Opt_FunToThunk+   , Opt_DmdTxDictSel+   , Opt_Loopification+   , Opt_CfgBlocklayout+   , Opt_WeightlessBlocklayout+   , Opt_CprAnal+   , Opt_WorkerWrapper+   , Opt_WorkerWrapperUnlift+   , Opt_SolveConstantDicts+   , Opt_SpecEval+   , Opt_SpecEvalDictFun+   ]++-- | The set of flags which affect code generation and can change a program's+-- runtime behavior (other than performance). These include flags which affect:+--+--  * user visible debugging information (e.g. info table provenance)+--  * the ability to catch runtime errors (e.g. -fignore-asserts)+--  * the runtime result of the program (e.g. -fomit-yields)+--  * which code or interface file declarations are emitted+--+-- We also considered placing flags which affect asympototic space behavior+-- (e.g. -ffull-laziness) however this would mean that changing optimisation+-- levels would trigger recompilation even with -fignore-optim-changes,+-- regressing #13604.+--+-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place+-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and+-- therefore would also break #13604.+--+-- See #23369.+codeGenFlags :: EnumSet GeneralFlag+codeGenFlags = EnumSet.fromList+   [ -- Flags that affect runtime result+     Opt_EagerBlackHoling+   , Opt_ExcessPrecision+   , Opt_DictsStrict+   , Opt_PedanticBottoms+   , Opt_OmitYields++     -- Flags that affect generated code+   , Opt_ExposeAllUnfoldings+   , Opt_ExposeOverloadedUnfoldings+   , Opt_NoTypeableBinds+   , Opt_ObjectDeterminism+   , Opt_Haddock++     -- Flags that affect catching of runtime errors+   , Opt_CatchNonexhaustiveCases+   , Opt_LlvmFillUndefWithGarbage+   , Opt_DoTagInferenceChecks++     -- Flags that affect debugging information+   , Opt_DistinctConstructorTables+   , Opt_InfoTableMap+   , Opt_InfoTableMapWithStack+   , Opt_InfoTableMapWithFallback+   , Opt_OrigThunkInfo+   ]++data WarningFlag =+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session+     Opt_WarnDuplicateExports+   | Opt_WarnDuplicateConstraints+   | Opt_WarnRedundantConstraints+   | Opt_WarnHiShadows+   | Opt_WarnImplicitPrelude+   | Opt_WarnIncompletePatterns+   | Opt_WarnIncompleteUniPatterns+   | Opt_WarnIncompletePatternsRecUpd+   | Opt_WarnOverflowedLiterals+   | Opt_WarnEmptyEnumerations+   | Opt_WarnMissingFields+   | Opt_WarnMissingImportList+   | Opt_WarnMissingMethods+   | Opt_WarnMissingSignatures+   | Opt_WarnMissingLocalSignatures+   | Opt_WarnNameShadowing+   | Opt_WarnOverlappingPatterns+   | Opt_WarnTypeDefaults+   | Opt_WarnMonomorphism+   | Opt_WarnUnusedTopBinds+   | Opt_WarnUnusedLocalBinds+   | Opt_WarnUnusedPatternBinds+   | Opt_WarnUnusedImports+   | Opt_WarnUnusedMatches+   | Opt_WarnUnusedTypePatterns+   | Opt_WarnUnusedForalls+   | Opt_WarnUnusedRecordWildcards+   | Opt_WarnRedundantBangPatterns+   | Opt_WarnRedundantRecordWildcards+   | Opt_WarnDeprecatedFlags+   | Opt_WarnMissingMonadFailInstances               -- since 8.0, has no effect since 8.8+   | Opt_WarnSemigroup                               -- since 8.0, has no effect since 9.8+   | Opt_WarnDodgyExports+   | Opt_WarnDodgyImports+   | Opt_WarnOrphans+   | Opt_WarnAutoOrphans+   | Opt_WarnIdentities+   | Opt_WarnTabs+   | Opt_WarnUnrecognisedPragmas+   | Opt_WarnMisplacedPragmas+   | Opt_WarnDodgyForeignImports+   | Opt_WarnUnusedDoBind+   | Opt_WarnWrongDoBind+   | Opt_WarnAlternativeLayoutRuleTransitional+   | Opt_WarnUnsafe+   | Opt_WarnSafe+   | Opt_WarnTrustworthySafe+   | Opt_WarnMissedSpecs+   | Opt_WarnAllMissedSpecs+   | Opt_WarnUnsupportedCallingConventions+   | Opt_WarnUnsupportedLlvmVersion+   | Opt_WarnMissedExtraSharedLib+   | Opt_WarnInlineRuleShadowing+   | Opt_WarnTypedHoles+   | Opt_WarnPartialTypeSignatures+   | Opt_WarnMissingExportedSignatures+   | Opt_WarnUntickedPromotedConstructors+   | Opt_WarnDerivingTypeable+   | Opt_WarnDeferredTypeErrors+   | Opt_WarnDeferredOutOfScopeVariables+   | Opt_WarnNonCanonicalMonadInstances              -- ^ @since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances          -- ^ @since 8.0, has no effect since 8.8+   | Opt_WarnNonCanonicalMonoidInstances             -- ^ @since 8.0+   | Opt_WarnMissingPatternSynonymSignatures         -- ^ @since 8.0+   | Opt_WarnUnrecognisedWarningFlags                -- ^ @since 8.0+   | Opt_WarnSimplifiableClassConstraints            -- ^ @since 8.2+   | Opt_WarnCPPUndef                                -- ^ @since 8.2+   | Opt_WarnUnbangedStrictPatterns                  -- ^ @since 8.2+   | Opt_WarnMissingHomeModules                      -- ^ @since 8.2+   | Opt_WarnPartialFields                           -- ^ @since 8.4+   | Opt_WarnMissingExportList+   | Opt_WarnInaccessibleCode+   | Opt_WarnStarIsType                              -- ^ @since 8.6+   | Opt_WarnStarBinder                              -- ^ @since 8.6+   | Opt_WarnImplicitKindVars                        -- ^ @since 8.6+   | Opt_WarnSpaceAfterBang+   | Opt_WarnMissingDerivingStrategies               -- ^ @since 8.8+   | Opt_WarnPrepositiveQualifiedModule              -- ^ @since 8.10+   | Opt_WarnUnusedPackages                          -- ^ @since 8.10+   | Opt_WarnInferredSafeImports                     -- ^ @since 8.10+   | Opt_WarnMissingSafeHaskellMode                  -- ^ @since 8.10+   | Opt_WarnCompatUnqualifiedImports                -- ^ @since 8.10+   | Opt_WarnDerivingDefaults+   | Opt_WarnInvalidHaddock                          -- ^ @since 9.0+   | Opt_WarnOperatorWhitespaceExtConflict           -- ^ @since 9.2+   | Opt_WarnOperatorWhitespace                      -- ^ @since 9.2+   | Opt_WarnAmbiguousFields                         -- ^ @since 9.2+   | Opt_WarnImplicitLift                            -- ^ @since 9.2+   | Opt_WarnMissingKindSignatures                   -- ^ @since 9.2+   | Opt_WarnMissingPolyKindSignatures               -- ^ @since 9.8+   | Opt_WarnMissingExportedPatternSynonymSignatures -- ^ @since 9.2+   | Opt_WarnRedundantStrictnessFlags                -- ^ @since 9.4+   | Opt_WarnForallIdentifier                        -- ^ @since 9.4+   | Opt_WarnUnicodeBidirectionalFormatCharacters    -- ^ @since 9.0.2+   | Opt_WarnGADTMonoLocalBinds                      -- ^ @since 9.4+   | Opt_WarnTypeEqualityOutOfScope                  -- ^ @since 9.4+   | Opt_WarnTypeEqualityRequiresOperators           -- ^ @since 9.4+   | Opt_WarnLoopySuperclassSolve                    -- ^ @since 9.6, has no effect since 9.10+   | Opt_WarnTermVariableCapture                     -- ^ @since 9.8+   | Opt_WarnMissingRoleAnnotations                  -- ^ @since 9.8+   | Opt_WarnImplicitRhsQuantification               -- ^ @since 9.8+   | Opt_WarnIncompleteExportWarnings                -- ^ @since 9.8+   | Opt_WarnIncompleteRecordSelectors               -- ^ @since 9.10+   | Opt_WarnBadlyLevelledTypes                      -- ^ @since 9.10+   | Opt_WarnInconsistentFlags                       -- ^ @since 9.8+   | Opt_WarnDataKindsTC                             -- ^ @since 9.10+   | Opt_WarnDefaultedExceptionContext               -- ^ @since 9.10+   | Opt_WarnViewPatternSignatures                   -- ^ @since 9.12+   | Opt_WarnUselessSpecialisations                  -- ^ @since 9.14+   | Opt_WarnDeprecatedPragmas                       -- ^ @since 9.14+   | Opt_WarnRuleLhsEqualities+       -- ^ @since 9.14, scheduled to be removed in 9.18+       --+       -- See Note [Quantifying over equalities in RULES] in GHC.Tc.Gen.Sig+   | Opt_WarnUnusableUnpackPragmas                   -- Since 9.14+   | Opt_WarnPatternNamespaceSpecifier               -- Since 9.14+   deriving (Eq, Ord, Show, Enum, Bounded)++-- | Return the names of a WarningFlag+--+-- One flag may have several names because of US/UK spelling.  The first one is+-- the "preferred one" that will be displayed in warning messages.+warnFlagNames :: WarningFlag -> NonEmpty String+warnFlagNames wflag = case wflag of+  Opt_WarnAlternativeLayoutRuleTransitional       -> "alternative-layout-rule-transitional" :| []+  Opt_WarnAmbiguousFields                         -> "ambiguous-fields" :| []+  Opt_WarnAutoOrphans                             -> "auto-orphans" :| []+  Opt_WarnTermVariableCapture                     -> "term-variable-capture" :| []+  Opt_WarnCPPUndef                                -> "cpp-undef" :| []+  Opt_WarnUnbangedStrictPatterns                  -> "unbanged-strict-patterns" :| []+  Opt_WarnDeferredTypeErrors                      -> "deferred-type-errors" :| []+  Opt_WarnDeferredOutOfScopeVariables             -> "deferred-out-of-scope-variables" :| []+  Opt_WarnDeprecatedFlags                         -> "deprecated-flags" :| []+  Opt_WarnDerivingDefaults                        -> "deriving-defaults" :| []+  Opt_WarnDerivingTypeable                        -> "deriving-typeable" :| []+  Opt_WarnDodgyExports                            -> "dodgy-exports" :| []+  Opt_WarnDodgyForeignImports                     -> "dodgy-foreign-imports" :| []+  Opt_WarnDodgyImports                            -> "dodgy-imports" :| []+  Opt_WarnEmptyEnumerations                       -> "empty-enumerations" :| []+  Opt_WarnDuplicateConstraints                    -> "duplicate-constraints" :| []+  Opt_WarnRedundantConstraints                    -> "redundant-constraints" :| []+  Opt_WarnDuplicateExports                        -> "duplicate-exports" :| []+  Opt_WarnHiShadows                               -> "hi-shadowing" :| []+  Opt_WarnInaccessibleCode                        -> "inaccessible-code" :| []+  Opt_WarnImplicitPrelude                         -> "implicit-prelude" :| []+  Opt_WarnImplicitKindVars                        -> "implicit-kind-vars" :| []+  Opt_WarnIncompletePatterns                      -> "incomplete-patterns" :| []+  Opt_WarnIncompletePatternsRecUpd                -> "incomplete-record-updates" :| []+  Opt_WarnIncompleteUniPatterns                   -> "incomplete-uni-patterns" :| []+  Opt_WarnInlineRuleShadowing                     -> "inline-rule-shadowing" :| []+  Opt_WarnIdentities                              -> "identities" :| []+  Opt_WarnMissingFields                           -> "missing-fields" :| []+  Opt_WarnMissingImportList                       -> "missing-import-lists" :| []+  Opt_WarnMissingExportList                       -> "missing-export-lists" :| []+  Opt_WarnMissingLocalSignatures                  -> "missing-local-signatures" :| []+  Opt_WarnMissingMethods                          -> "missing-methods" :| []+  Opt_WarnMissingMonadFailInstances               -> "missing-monadfail-instances" :| []+  Opt_WarnSemigroup                               -> "semigroup" :| []+  Opt_WarnMissingSignatures                       -> "missing-signatures" :| []+  Opt_WarnMissingKindSignatures                   -> "missing-kind-signatures" :| []+  Opt_WarnMissingPolyKindSignatures               -> "missing-poly-kind-signatures" :| []+  Opt_WarnMissingExportedSignatures               -> "missing-exported-signatures" :| []+  Opt_WarnMonomorphism                            -> "monomorphism-restriction" :| []+  Opt_WarnNameShadowing                           -> "name-shadowing" :| []+  Opt_WarnNonCanonicalMonadInstances              -> "noncanonical-monad-instances" :| []+  Opt_WarnNonCanonicalMonadFailInstances          -> "noncanonical-monadfail-instances" :| []+  Opt_WarnNonCanonicalMonoidInstances             -> "noncanonical-monoid-instances" :| []+  Opt_WarnOrphans                                 -> "orphans" :| []+  Opt_WarnOverflowedLiterals                      -> "overflowed-literals" :| []+  Opt_WarnOverlappingPatterns                     -> "overlapping-patterns" :| []+  Opt_WarnMissedSpecs                             -> "missed-specialisations" :| ["missed-specializations"]+  Opt_WarnAllMissedSpecs                          -> "all-missed-specialisations" :| ["all-missed-specializations"]+  Opt_WarnSafe                                    -> "safe" :| []+  Opt_WarnTrustworthySafe                         -> "trustworthy-safe" :| []+  Opt_WarnInferredSafeImports                     -> "inferred-safe-imports" :| []+  Opt_WarnMissingSafeHaskellMode                  -> "missing-safe-haskell-mode" :| []+  Opt_WarnTabs                                    -> "tabs" :| []+  Opt_WarnTypeDefaults                            -> "type-defaults" :| []+  Opt_WarnTypedHoles                              -> "typed-holes" :| []+  Opt_WarnPartialTypeSignatures                   -> "partial-type-signatures" :| []+  Opt_WarnUnrecognisedPragmas                     -> "unrecognised-pragmas" :| []+  Opt_WarnMisplacedPragmas                        -> "misplaced-pragmas" :| []+  Opt_WarnUnsafe                                  -> "unsafe" :| []+  Opt_WarnUnsupportedCallingConventions           -> "unsupported-calling-conventions" :| []+  Opt_WarnUnsupportedLlvmVersion                  -> "unsupported-llvm-version" :| []+  Opt_WarnMissedExtraSharedLib                    -> "missed-extra-shared-lib" :| []+  Opt_WarnUntickedPromotedConstructors            -> "unticked-promoted-constructors" :| []+  Opt_WarnUnusedDoBind                            -> "unused-do-bind" :| []+  Opt_WarnUnusedForalls                           -> "unused-foralls" :| []+  Opt_WarnUnusedImports                           -> "unused-imports" :| []+  Opt_WarnUnusedLocalBinds                        -> "unused-local-binds" :| []+  Opt_WarnUnusedMatches                           -> "unused-matches" :| []+  Opt_WarnUnusedPatternBinds                      -> "unused-pattern-binds" :| []+  Opt_WarnUnusedTopBinds                          -> "unused-top-binds" :| []+  Opt_WarnUnusedTypePatterns                      -> "unused-type-patterns" :| []+  Opt_WarnUnusedRecordWildcards                   -> "unused-record-wildcards" :| []+  Opt_WarnRedundantBangPatterns                   -> "redundant-bang-patterns" :| []+  Opt_WarnRedundantRecordWildcards                -> "redundant-record-wildcards" :| []+  Opt_WarnRedundantStrictnessFlags                -> "redundant-strictness-flags" :| []+  Opt_WarnWrongDoBind                             -> "wrong-do-bind" :| []+  Opt_WarnMissingPatternSynonymSignatures         -> "missing-pattern-synonym-signatures" :| []+  Opt_WarnMissingDerivingStrategies               -> "missing-deriving-strategies" :| []+  Opt_WarnSimplifiableClassConstraints            -> "simplifiable-class-constraints" :| []+  Opt_WarnMissingHomeModules                      -> "missing-home-modules" :| []+  Opt_WarnUnrecognisedWarningFlags                -> "unrecognised-warning-flags" :| []+  Opt_WarnStarBinder                              -> "star-binder" :| []+  Opt_WarnStarIsType                              -> "star-is-type" :| []+  Opt_WarnSpaceAfterBang                          -> "missing-space-after-bang" :| []+  Opt_WarnPartialFields                           -> "partial-fields" :| []+  Opt_WarnPrepositiveQualifiedModule              -> "prepositive-qualified-module" :| []+  Opt_WarnUnusedPackages                          -> "unused-packages" :| []+  Opt_WarnCompatUnqualifiedImports                -> "compat-unqualified-imports" :| []+  Opt_WarnInvalidHaddock                          -> "invalid-haddock" :| []+  Opt_WarnOperatorWhitespaceExtConflict           -> "operator-whitespace-ext-conflict" :| []+  Opt_WarnOperatorWhitespace                      -> "operator-whitespace" :| []+  Opt_WarnImplicitLift                            -> "implicit-lift" :| []+  Opt_WarnMissingExportedPatternSynonymSignatures -> "missing-exported-pattern-synonym-signatures" :| []+  Opt_WarnForallIdentifier                        -> "forall-identifier" :| []+  Opt_WarnUnicodeBidirectionalFormatCharacters    -> "unicode-bidirectional-format-characters" :| []+  Opt_WarnGADTMonoLocalBinds                      -> "gadt-mono-local-binds" :| []+  Opt_WarnTypeEqualityOutOfScope                  -> "type-equality-out-of-scope" :| []+  Opt_WarnLoopySuperclassSolve                    -> "loopy-superclass-solve" :| []+  Opt_WarnTypeEqualityRequiresOperators           -> "type-equality-requires-operators" :| []+  Opt_WarnMissingRoleAnnotations                  -> "missing-role-annotations" :| []+  Opt_WarnImplicitRhsQuantification               -> "implicit-rhs-quantification" :| []+  Opt_WarnIncompleteExportWarnings                -> "incomplete-export-warnings" :| []+  Opt_WarnIncompleteRecordSelectors               -> "incomplete-record-selectors" :| []+  Opt_WarnBadlyLevelledTypes                      -> "badly-levelled-types" :| []+  Opt_WarnInconsistentFlags                       -> "inconsistent-flags" :| []+  Opt_WarnDataKindsTC                             -> "data-kinds-tc" :| []+  Opt_WarnDefaultedExceptionContext               -> "defaulted-exception-context" :| []+  Opt_WarnViewPatternSignatures                   -> "view-pattern-signatures" :| []+  Opt_WarnUselessSpecialisations                  -> "useless-specialisations" :| ["useless-specializations"]+  Opt_WarnDeprecatedPragmas                       -> "deprecated-pragmas" :| []+  Opt_WarnRuleLhsEqualities                       -> "rule-lhs-equalities" :| []+  Opt_WarnUnusableUnpackPragmas                   -> "unusable-unpack-pragmas" :| []+  Opt_WarnPatternNamespaceSpecifier               -> "pattern-namespace-specifier" :| []++-- -----------------------------------------------------------------------------+-- Standard sets of warning options++-- Note [Documenting warning flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of warnings enabled by default+-- please remember to update the User's Guide. The relevant file is:+--+--  docs/users_guide/using-warnings.rst+++-- | A group of warning flags that can be enabled or disabled collectively,+-- e.g. using @-Wcompat@ to enable all warnings in the 'W_compat' group.+data WarningGroup = W_compat+                  | W_unused_binds+                  | W_extended_warnings+                  | W_default+                  | W_extra+                  | W_all+                  | W_everything+  deriving (Bounded, Enum, Eq)++warningGroupName :: WarningGroup -> String+warningGroupName W_compat            = "compat"+warningGroupName W_unused_binds      = "unused-binds"+warningGroupName W_extended_warnings = "extended-warnings"+warningGroupName W_default           = "default"+warningGroupName W_extra             = "extra"+warningGroupName W_all               = "all"+warningGroupName W_everything        = "everything"++warningGroupFlags :: WarningGroup -> [WarningFlag]+warningGroupFlags W_compat            = minusWcompatOpts+warningGroupFlags W_unused_binds      = unusedBindsFlags+warningGroupFlags W_extended_warnings = []+warningGroupFlags W_default           = standardWarnings+warningGroupFlags W_extra             = minusWOpts+warningGroupFlags W_all               = minusWallOpts+warningGroupFlags W_everything        = minusWeverythingOpts++-- | Does this warning group contain (all) extended warning categories?  See+-- Note [Warning categories] in GHC.Unit.Module.Warnings.+--+-- The 'W_extended_warnings' group contains extended warnings but no+-- 'WarningFlag's, but extended warnings are also treated as part of 'W_default'+-- and every warning group that includes it.+warningGroupIncludesExtendedWarnings :: WarningGroup -> Bool+warningGroupIncludesExtendedWarnings W_compat            = False+warningGroupIncludesExtendedWarnings W_unused_binds      = False+warningGroupIncludesExtendedWarnings W_extended_warnings = True+warningGroupIncludesExtendedWarnings W_default           = True+warningGroupIncludesExtendedWarnings W_extra             = True+warningGroupIncludesExtendedWarnings W_all               = True+warningGroupIncludesExtendedWarnings W_everything        = True++-- | Warning groups.+--+-- As all warnings are in the 'W_everything' set, it is ignored when+-- displaying to the user which group a warning is in.+warningGroups :: [WarningGroup]+warningGroups = [minBound..maxBound]++-- | Warning group hierarchies, where there is an explicit inclusion+-- relation.+--+-- Each inner list is a hierarchy of warning groups, ordered from+-- smallest to largest, where each group is a superset of the one+-- before it.+--+-- Separating this from 'warningGroups' allows for multiple+-- hierarchies with no inherent relation to be defined.+--+-- The special-case 'W_everything' group is not included.+warningHierarchies :: [[WarningGroup]]+warningHierarchies = hierarchies ++ map (:[]) rest+  where+    hierarchies = [[W_default, W_extra, W_all]]+    rest = filter (`notElem` W_everything : concat hierarchies) warningGroups++-- | Find the smallest group in every hierarchy which a warning+-- belongs to, excluding Weverything.+smallestWarningGroups :: WarningFlag -> [WarningGroup]+smallestWarningGroups flag = mapMaybe go warningHierarchies where+    -- Because each hierarchy is arranged from smallest to largest,+    -- the first group we find in a hierarchy which contains the flag+    -- is the smallest.+    go (group:rest) = fromMaybe (go rest) $ do+        guard (flag `elem` warningGroupFlags group)+        pure (Just group)+    go [] = Nothing++-- | The smallest group in every hierarchy to which a custom warning+-- category belongs is currently always @-Wextended-warnings@.+-- See Note [Warning categories] in "GHC.Unit.Module.Warnings".+smallestWarningGroupsForCategory :: [WarningGroup]+smallestWarningGroupsForCategory = [W_extended_warnings]++-- | Warnings enabled unless specified otherwise+standardWarnings :: [WarningFlag]+standardWarnings -- see Note [Documenting warning flags]+    = [ Opt_WarnOverlappingPatterns,+        Opt_WarnDeprecatedFlags,+        Opt_WarnDeferredTypeErrors,+        Opt_WarnTypedHoles,+        Opt_WarnDeferredOutOfScopeVariables,+        Opt_WarnPartialTypeSignatures,+        Opt_WarnUnrecognisedPragmas,+        Opt_WarnMisplacedPragmas,+        Opt_WarnDuplicateExports,+        Opt_WarnDerivingDefaults,+        Opt_WarnOverflowedLiterals,+        Opt_WarnEmptyEnumerations,+        Opt_WarnAmbiguousFields,+        Opt_WarnMissingFields,+        Opt_WarnMissingMethods,+        Opt_WarnWrongDoBind,+        Opt_WarnUnsupportedCallingConventions,+        Opt_WarnDodgyForeignImports,+        Opt_WarnInlineRuleShadowing,+        Opt_WarnAlternativeLayoutRuleTransitional,+        Opt_WarnUnsupportedLlvmVersion,+        Opt_WarnMissedExtraSharedLib,+        Opt_WarnTabs,+        Opt_WarnUnrecognisedWarningFlags,+        Opt_WarnSimplifiableClassConstraints,+        Opt_WarnStarBinder,+        Opt_WarnStarIsType,+        Opt_WarnInaccessibleCode,+        Opt_WarnSpaceAfterBang,+        Opt_WarnNonCanonicalMonadInstances,+        Opt_WarnNonCanonicalMonoidInstances,+        Opt_WarnOperatorWhitespaceExtConflict,+        Opt_WarnUnicodeBidirectionalFormatCharacters,+        Opt_WarnGADTMonoLocalBinds,+        Opt_WarnBadlyLevelledTypes,+        Opt_WarnTypeEqualityRequiresOperators,+        Opt_WarnInconsistentFlags,+        Opt_WarnTypeEqualityOutOfScope,+        Opt_WarnImplicitRhsQuantification, -- was in -Wcompat since 9.8, enabled by default since 9.14, to turn into a hard error in 9.16+        Opt_WarnViewPatternSignatures,+        Opt_WarnUselessSpecialisations,+        Opt_WarnDeprecatedPragmas,+        Opt_WarnRuleLhsEqualities,+        Opt_WarnUnusableUnpackPragmas+      ]++-- | Things you get with @-W@.+minusWOpts :: [WarningFlag]+minusWOpts+    = standardWarnings +++      [ Opt_WarnUnusedTopBinds,+        Opt_WarnUnusedLocalBinds,+        Opt_WarnUnusedPatternBinds,+        Opt_WarnUnusedMatches,+        Opt_WarnUnusedForalls,+        Opt_WarnUnusedImports,+        Opt_WarnIncompletePatterns,+        Opt_WarnDodgyExports,+        Opt_WarnDodgyImports,+        Opt_WarnUnbangedStrictPatterns+      ]++-- | Things you get with @-Wall@.+minusWallOpts :: [WarningFlag]+minusWallOpts+    = minusWOpts +++      [ Opt_WarnTypeDefaults,+        Opt_WarnNameShadowing,+        Opt_WarnMissingSignatures,+        Opt_WarnHiShadows,+        Opt_WarnOrphans,+        Opt_WarnUnusedDoBind,+        Opt_WarnTrustworthySafe,+        Opt_WarnMissingPatternSynonymSignatures,+        Opt_WarnUnusedRecordWildcards,+        Opt_WarnRedundantRecordWildcards,+        Opt_WarnIncompleteUniPatterns,+        Opt_WarnIncompletePatternsRecUpd,+        Opt_WarnIncompleteExportWarnings,+        Opt_WarnIncompleteRecordSelectors,+        Opt_WarnDerivingTypeable+      ]++-- | Things you get with @-Weverything@, i.e. *all* known warnings flags.+minusWeverythingOpts :: [WarningFlag]+minusWeverythingOpts = [ toEnum 0 .. ]++-- | Things you get with @-Wcompat@.+--+-- This is intended to group together warnings that will be enabled by default+-- at some point in the future, so that library authors eager to make their+-- code future compatible to fix issues before they even generate warnings.+minusWcompatOpts :: [WarningFlag]+minusWcompatOpts+    = [ Opt_WarnPatternNamespaceSpecifier+      ]++-- | Things you get with @-Wunused-binds@.+unusedBindsFlags :: [WarningFlag]+unusedBindsFlags = [ Opt_WarnUnusedTopBinds+                   , Opt_WarnUnusedLocalBinds+                   , Opt_WarnUnusedPatternBinds+                   ]
+ GHC/Driver/GenerateCgIPEStub.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE GADTs         #-}+{-# LANGUAGE TupleSections #-}++module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where++import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Semigroup ((<>))+import GHC.Cmm+import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel)+import GHC.Cmm.Dataflow (O)+import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Info.Build (emptySRT)+import GHC.Cmm.Pipeline (cmmPipeline)+import GHC.Data.Stream (liftIO, liftEff)+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 (..), DumpFlag(Opt_D_ipe_stats))+import GHC.Driver.DynFlags (gopt, targetPlatform)+import GHC.Driver.Config.StgToCmm+import GHC.Driver.Config.Cmm ( initCmmConfig )+import GHC.Prelude+import GHC.Runtime.Heap.Layout (isStackRep)+import GHC.Settings (platformTablesNextToCode)+import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)+import GHC.StgToCmm.Prof (initInfoTableProv)+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)+import GHC.StgToCmm.Utils+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Types.Tickish (GenTickish (SourceNote))+import GHC.Unit.Types (Module, moduleName)+import GHC.Unit.Module (moduleNameString)+import qualified GHC.Utils.Logger as Logger+import GHC.Utils.Outputable (ppr)+import GHC.Types.Unique.DSM++{-+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?++The algorithm for determining source locations for stack info tables is implemented in+`lookupEstimatedTicks` as two passes over every 'CmmGroupSRTs'. The first pass generates estimated+source locations for any labels potentially corresponding to stack info tables in the Cmm code. The+second pass walks over the Cmm decls and creates an entry in the IPE map for every info table,+looking up source locations for stack info tables in the map generated during the first pass.++The rest of this note will document exactly how the first pass generates the map from labels to+estimated source positions. The algorithms are different depending on whether tables-next-to-code+is on or off. Both algorithms have in common that we are looking for a `CmmNode.CmmTick`+(containing a `SourceNote`) that is near what we estimate to be the label of a return stack frame.++With tables-next-to-code+~~~~~~~~~~~~~~~~~~~~~~~~++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 `CmmGraph`:+  - Look at the end of every block: If it is a `CmmNode.CmmCall` returning to some label, 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 map the label we+    found to it's payload as an `IpeSourceLocation`. (There are other `Tickish` constructors like+    `ProfNote` or `HpcTick`, these are ignored.)++See `labelsToSourcesWithTNTC` for the implementation of this algorithm.++Without tables-next-to-code+~~~~~~~~~~~~~~~~~~~~~~~~~~~++When tables-next-to-code is off, 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`).++Given a `CmmGraph`:+  - Check every `CmmBlock` from top (first) to bottom (last).+  - If a `CmmTick` holding a `SourceNote` is found, remember the source location in the tick.+  - If an assignment of the form `... = block_c18M_info;` (a `CmmStore` whose RHS is a+    `CmmLit (CmmLabel l)`) is found, map that label to the most recently visited source note's+    location.++See `labelsToSourcesSansTNTC` for the implementation of this algorithm.+-}++generateCgIPEStub+  :: HscEnv+  -> Module+  -> InfoTableProvMap+  -- ^ If the CmmInfoTables map refer Cmm symbols which were deterministically renamed, the info table provenance map must also be accordingly renamed.+  -> ( NonCaffySet+     , ModuleLFInfos+     , Map CmmInfoTable (Maybe IpeSourceLocation)+     , IPEStats+     )+  -> CgStream CmmGroupSRTs CmmCgInfos+generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = 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++  -- NB: For determinism, don't use DetUniqFM to rename the IPE Cmm because+  -- detRenameCmm isn't idempotent and this Cmm references symbols in the rest+  -- of the code!  Instead, make sure all labels generated for IPE related code+  -- sources uniques from the DUniqSupply gotten from CgStream (see its use in+  -- initInfoTableProv/emitIpeBufferListNode).+  (mIpeStub, ipeCmmGroup) <- liftEff $ UDSMT $ \dus -> do++    -- Yield Cmm for Info Table Provenance Entries (IPEs)+    let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}+        (((mIpeStub, dus'), ipeCmmGroup), _) =+            runC (initStgToCmmConfig dflags this_mod) fstate cgState $+              getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv' dus)++    return ((mIpeStub, ipeCmmGroup), dus')++  (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup)+  Stream.yield ipeCmmGroupSRTs++  ipeStub <-+    case mIpeStub of+      Just (stats, stub) -> do+        -- Print ipe stats if requested+        liftIO $+          Logger.putDumpFileMaybe logger+            Opt_D_ipe_stats+            ("IPE Stats for module " ++ (moduleNameString $ moduleName this_mod))+            Logger.FormatText+            (ppr stats)+        return stub+      Nothing -> return mempty++  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}++-- | Given:+--   * an initial mapping from info tables to possible source locations,+--   * initial 'IPEStats',+--   * a 'CmmGroupSRTs',+--+-- map every info table listed in the 'CmmProc's of the group to their possible+-- source locations and update 'IPEStats' for skipped stack info tables (in case+-- both -finfo-table-map and -fno-info-table-map-with-stack were given). See:+-- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+--+-- Note: While it would be cleaner if we could keep the recursion and+-- accumulation internal to this function, this cannot be done without+-- separately traversing stream of 'CmmGroupSRTs' in 'GHC.Driver.Main'. The+-- initial implementation of this logic did such a thing, and code generation+-- performance suffered considerably as a result (see #23103).+lookupEstimatedTicks+  :: HscEnv+  -> Map CmmInfoTable (Maybe IpeSourceLocation)+  -> IPEStats+  -> CmmGroupSRTs+  -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =+    -- Pass 2: Create an entry in the IPE map for every info table listed in+    -- this CmmGroupSRTs. If the info table is a stack info table and+    -- -finfo-table-map-with-stack is enabled, look up its estimated source+    -- location in the map generate during Pass 1. If the info table is a stack+    -- info table and -finfo-table-map-with-stack is not enabled, skip the table+    -- and note it as skipped in the IPE stats. If the info table is not a stack+    -- info table, insert into the IPE map with no source location information+    -- (for now; see `convertInfoProvMap` in GHC.StgToCmm.Utils to see how source+    -- locations for these tables get filled in)+    pure $ foldl' collectInfoTables (ipes, stats) cmm_group_srts+  where+    dflags = hsc_dflags hsc_env+    platform = targetPlatform dflags++    -- Pass 1: Map every label meeting the conditions described in Note+    -- [Stacktraces from Info Table Provenance Entries (IPE based stack+    -- unwinding)] to the estimated source location (also as described in the+    -- aformentioned note)+    --+    -- Note: It's important that this remains a thunk so we do not compute this+    -- map if -fno-info-table-with-stack is given+    labelsToSources :: Map CLabel IpeSourceLocation+    labelsToSources =+      if platformTablesNextToCode platform then+        foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts+      else+        foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts++    collectInfoTables+      :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+      -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+      -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+    collectInfoTables (!acc, !stats) (CmmProc h _ _ _) =+        mapFoldlWithKey go (acc, stats) (info_tbls h)+      where+        go :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+           -> Label+           -> CmmInfoTable+           -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+        go (!acc, !stats) lbl' tbl =+          let+            lbl =+              if platformTablesNextToCode platform then+                -- TNTC case, the mapped CLabel will be the result of+                -- mkAsmTempLabel on the info table label+                mkAsmTempLabel lbl'+              else+                -- Non-TNTC case, the mapped CLabel will be the CLabel of the+                -- info table itself+                cit_lbl tbl+          in+            if (isStackRep . cit_rep) tbl then+              if gopt Opt_InfoTableMapWithStack dflags then+                -- This is a stack info table and we DO want to put it in the+                -- info table map+                (Map.insert tbl (Map.lookup lbl labelsToSources) acc, stats)+              else+                -- This is a stack info table but we DO NOT want to put it in+                -- the info table map (-fno-info-table-map-with-stack was+                -- given), track it as skipped+                (acc, stats <> skippedIpeStats)+            else+              -- This is not a stack info table, so put it in the map with no+              -- source location (for now)+              (Map.insert tbl Nothing acc, stats)+    collectInfoTables (!acc, !stats) _ = (acc, stats)++-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesWithTNTC+  :: Map CLabel IpeSourceLocation+  -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+  -> Map CLabel IpeSourceLocation+labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) =+    foldl' go acc (toBlockList cmm_graph)+  where+    go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+    go acc block =+        case (,) <$> returnFrameLabel <*> lastTickInBlock of+          Just (clabel, src_loc) -> Map.insert clabel src_loc acc+          Nothing -> acc+      where+        (_, middleBlock, endBlock) = blockSplit block++        returnFrameLabel :: Maybe CLabel+        returnFrameLabel =+          case endBlock of+            (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l+            _ -> Nothing++        lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock)++        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+        maybeTick _ s@(Just _) = s+        maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name)+        maybeTick _ _ = Nothing+labelsToSourcesWithTNTC acc _ = acc++-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesSansTNTC+  :: Map CLabel IpeSourceLocation+  -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+  -> Map CLabel IpeSourceLocation+labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) =+    foldl' go acc (toBlockList cmm_graph)+  where+    go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+    go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock)+      where+        (_, middleBlock, _) = blockSplit block++        collectLabels+          :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+          -> CmmNode O O+          -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+        collectLabels (!acc, lastTick) b =+          case (b, lastTick) of+            (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) ->+              (Map.insert l src_loc acc, Nothing)+            (CmmTick (SourceNote span name), _) ->+              (acc, Just (span, name))+            _ -> (acc, lastTick)+labelsToSourcesSansTNTC acc _ = acc
+ GHC/Driver/Hooks.hs view
@@ -0,0 +1,160 @@+-- \section[Hooks]{Low level API hooks}++-- NB: this module is SOURCE-imported by DynFlags, and should primarily+--     refer to *types*, rather than *code*++{-# LANGUAGE RankNTypes, TypeFamilies #-}++module GHC.Driver.Hooks+   ( Hooks+   , HasHooks (..)+   , ContainsHooks (..)+   , emptyHooks+     -- the hooks:+   , DsForeignsHook+   , dsForeignsHook+   , tcForeignImportsHook+   , tcForeignExportsHook+   , hscFrontendHook+   , hscCompileCoreExprHook+   , ghcPrimIfaceHook+   , runPhaseHook+   , runMetaHook+   , linkHook+   , runRnSpliceHook+   , getValueSafelyHook+   , createIservProcessHook+   , stgToCmmHook+   , cmmToRawCmmHook+   )+where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.DynFlags+import GHC.Driver.Pipeline.Phases++import GHC.Hs.Decls+import GHC.Hs.Binds+import GHC.Hs.Expr+import GHC.Hs.Extension++import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.Meta++import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.PackageTable++import GHC.Core+import GHC.Core.TyCon+import GHC.Core.Type++import GHC.Tc.Types+import GHC.Stg.Syntax+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.StgToCmm.Types (ModuleLFInfos)+import GHC.StgToCmm.Config+import GHC.Cmm++import GHCi.RemoteTypes++import GHC.Data.Bag++import qualified Data.Kind+import System.Process+import GHC.Linker.Types++{-+************************************************************************+*                                                                      *+\subsection{Hooks}+*                                                                      *+************************************************************************+-}++-- | Hooks can be used by GHC API clients to replace parts of+--   the compiler pipeline. If a hook is not installed, GHC+--   uses the default built-in behaviour++emptyHooks :: Hooks+emptyHooks = Hooks+  { dsForeignsHook         = Nothing+  , tcForeignImportsHook   = Nothing+  , tcForeignExportsHook   = Nothing+  , hscFrontendHook        = Nothing+  , hscCompileCoreExprHook = Nothing+  , ghcPrimIfaceHook       = Nothing+  , runPhaseHook           = Nothing+  , runMetaHook            = Nothing+  , linkHook               = Nothing+  , runRnSpliceHook        = Nothing+  , getValueSafelyHook     = Nothing+  , createIservProcessHook = Nothing+  , stgToCmmHook           = Nothing+  , cmmToRawCmmHook        = Nothing+  }++{- Note [The Decoupling Abstract Data Hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "Abstract Data" idea is due to Richard Eisenberg in+https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1957, where the pattern is+described in more detail.++Here we use it as a temporary measure to break the dependency from the Parser on+the Desugarer until the parser is free of DynFlags. We introduced a nullary type+family @DsForeignsook@, whose single definition is in GHC.HsToCore.Types, where+we instantiate it to++   [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))++In doing so, the Hooks module (which is an hs-boot dependency of DynFlags) can+be decoupled from its use of the DsM definition in GHC.HsToCore.Types. Since+both DsM and the definition of @ForeignsHook@ live in the same module, there is+virtually no difference for plugin authors that want to write a foreign hook.++An awkward consequences is that the `type instance DsForeignsHook`, in+GHC.HsToCore.Types is an orphan instance.+-}++-- See Note [The Decoupling Abstract Data Hack]+type family DsForeignsHook :: Data.Kind.Type++data Hooks = Hooks+  { dsForeignsHook         :: !(Maybe DsForeignsHook)+  -- ^ Actual type:+  -- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@+  , tcForeignImportsHook   :: !(Maybe ([LForeignDecl GhcRn]+                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , tcForeignExportsHook   :: !(Maybe ([LForeignDecl GhcRn]+            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , hscFrontendHook        :: !(Maybe (ModSummary -> Hsc FrontendResult))+  , hscCompileCoreExprHook :: !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)))+  , ghcPrimIfaceHook       :: !(Maybe ModIface)+  , runPhaseHook           :: !(Maybe PhaseHook)+  , runMetaHook            :: !(Maybe (MetaHook TcM))+  , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool+                                         -> HomePackageTable -> IO SuccessFlag))+  , runRnSpliceHook        :: !(Maybe (HsUntypedSplice GhcRn -> RnM (HsUntypedSplice GhcRn)))+  , getValueSafelyHook     :: !(Maybe (HscEnv -> Name -> Type+                                         -> IO (Either Type (HValue, [Linkable], PkgsLoaded))))+  , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))+  , stgToCmmHook           :: !(Maybe (StgToCmmConfig -> InfoTableProvMap -> [TyCon] -> CollectedCCs+                                 -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a+                                 -> IO (CgStream RawCmmGroup a)))+  }++class HasHooks m where+    getHooks :: m Hooks++class ContainsHooks a where+    extractHooks :: a -> Hooks
+ GHC/Driver/Hooks.hs-boot view
@@ -0,0 +1,13 @@+module GHC.Driver.Hooks where++import GHC.Prelude ()++data Hooks++emptyHooks :: Hooks++class HasHooks m where+    getHooks :: m Hooks++class ContainsHooks a where+    extractHooks :: a -> Hooks
+ GHC/Driver/IncludeSpecs.hs view
@@ -0,0 +1,48 @@+module GHC.Driver.IncludeSpecs+  ( IncludeSpecs(..)+  , addGlobalInclude+  , addQuoteInclude+  , addImplicitQuoteInclude+  , flattenIncludes+  ) where++import GHC.Prelude++-- | Used to differentiate the scope an include needs to apply to.+-- We have to split the include paths to avoid accidentally forcing recursive+-- includes since -I overrides the system search paths. See #14312.+data IncludeSpecs+  = IncludeSpecs { includePathsQuote  :: [String]+                 , includePathsGlobal :: [String]+                 -- | See Note [Implicit include paths]+                 , includePathsQuoteImplicit :: [String]+                 }+  deriving Show++-- | Append to the list of includes a path that shall be included using `-I`+-- when the C compiler is called. These paths override system search paths.+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addGlobalInclude spec paths  = let f = includePathsGlobal spec+                               in spec { includePathsGlobal = f ++ paths }++-- | Append to the list of includes a path that shall be included using+-- `-iquote` when the C compiler is called. These paths only apply when quoted+-- includes are used. e.g. #include "foo.h"+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addQuoteInclude spec paths  = let f = includePathsQuote spec+                              in spec { includePathsQuote = f ++ paths }++-- | These includes are not considered while fingerprinting the flags for iface+-- | See Note [Implicit include paths]+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec+                              in spec { includePathsQuoteImplicit = f ++ paths }+++-- | Concatenate and flatten the list of global and quoted includes returning+-- just a flat list of paths.+flattenIncludes :: IncludeSpecs -> [String]+flattenIncludes specs =+    includePathsQuote specs +++    includePathsQuoteImplicit specs +++    includePathsGlobal specs
+ GHC/Driver/LlvmConfigCache.hs view
@@ -0,0 +1,26 @@+-- | LLVM config cache+module GHC.Driver.LlvmConfigCache+  ( LlvmConfigCache+  , initLlvmConfigCache+  , readLlvmConfigCache+  )+where++import GHC.Prelude+import GHC.CmmToLlvm.Config++import System.IO.Unsafe++-- | Cache LLVM configuration read from files in top_dir+--+-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config+--+-- Currently implemented with unsafe lazy IO. But it could be implemented with+-- an IORef as the exposed interface is in IO.+data LlvmConfigCache = LlvmConfigCache LlvmConfig++initLlvmConfigCache :: FilePath -> IO LlvmConfigCache+initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir)++readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig+readLlvmConfigCache (LlvmConfigCache !config) = pure config
+ GHC/Driver/Main.hs view
@@ -0,0 +1,2917 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}++{-# 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+    , loadIfaceByteCode+    , loadIfaceByteCodeLazy+    , hscMaybeWriteIface+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive+    , mkCgInteractiveGuts+    , CgInteractiveGuts+    , generateByteCode+    , generateFreshByteCode++    -- * Running passes separately+    , hscRecompStatus+    , hscParse+    , hscTypecheckRename+    , hscTypecheckRenameWithDiagnostics+    , 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+    , hscParseDeclsWithLocation, 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+    , loadByteCode+    , genModDetails+    ) where++import GHC.Prelude++import GHC.Platform++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.Messager+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, lookupEstimatedTicks)++import GHC.Runtime.Context+import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.JS+import GHC.Runtime.Loader      ( initializePlugins )+import GHCi.RemoteTypes+import GHC.ByteCode.Types++import GHC.Linker.Loader+import GHC.Linker.Types+import GHC.Linker.Deps++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.StgToJS.Ids+import GHC.StgToJS.Types+import GHC.JS.Syntax++import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )++import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface )+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.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+import GHC.Core.LateCC.Types+++import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr )+import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds )+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.TcType+import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) )++import GHC.Stg.Syntax+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )++import GHC.Builtin.Names++import qualified GHC.StgToCmm as StgToCmm ( codeGen )+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..))+import GHC.StgToCmm.CgUtils (CgStream)++import GHC.Cmm+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info+import GHC.Cmm.Parser+import GHC.Cmm.UniqueRenamer++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+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.Name.Env      ( mkNameEnv )+import GHC.Types.Var.Env       ( mkEmptyTidyEnv )+import GHC.Types.Var.Set+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 ( newNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.Unique.Supply (uniqFromTag)+import GHC.Types.Unique.Set++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import GHC.Utils.Touch++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.OsPath (unsafeEncodeUtf)+import GHC.Data.StringBuffer+import qualified GHC.Data.Stream as Stream+import GHC.Data.Maybe++import GHC.SysTools (initSysTools)+import GHC.SysTools.BaseDir (findTopDir)++import Data.Data hiding (Fixity, TyCon)+import Data.Functor ((<&>))+import Data.List ( nub, isPrefixOf, partition )+import qualified Data.List.NonEmpty as NE+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Set as S+import Data.Set (Set)+import Control.DeepSeq (force)+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.Platform.Ways+import GHC.Stg.EnforceEpt.TagSig (seqTagSig)+import GHC.StgToCmm.Utils (IPEStats)+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Cmm.Config (CmmConfig)+import Data.Bifunctor+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: FilePath -> DynFlags -> IO HscEnv+newHscEnv top_dir dflags = do+  hpt <- emptyHomePackageTable+  newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt)+  where+    home_unit_graph hpt = HUG.unitEnv_singleton+                        (homeUnitId_ dflags)+                        (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing)++newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do+    nc_var  <- newNameCache+    fc_var  <- initFinderCache+    logger  <- initLogger+    tmpfs   <- initTmpFs+    let dflags = homeUnitEnv_dflags $ HUG.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_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+  setUnsafeGlobalDynFlags dflags+   -- c.f. DynFlags.parseDynamicFlagsFull, which+   -- creates DynFlags and sets the UnsafeGlobalDynFlags+  return hsc_env++-- -----------------------------------------------------------------------------++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 (NonEmpty Name)+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.+       -- Once errors has been dealt with in hoistTcRnMessage, we can enforce+       -- this invariant in types by converting to NonEmpty.+       ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ 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 <- getHscEnv+            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 =+    fst <$> hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module++-- | Rename and typecheck a module, additionally returning the renamed syntax+-- and the diagnostics produced.+hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule+                                  -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)+hscTypecheckRenameWithDiagnostics 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.+-}++++-- | 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 [] (ModuleNodeCompile 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 mb_checked_iface+      UpToDateItem checked_iface -> do+        let lcl_dflags = ms_hspp_opts mod_summary+        if | not (backendGeneratesCode (backend lcl_dflags)) -> do+               -- No need for a linkable, we're good to go+               msg UpToDate+               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable+           | not (backendGeneratesCodeForHsBoot (backend lcl_dflags))+           , IsBoot <- isBootSummary mod_summary -> do+               msg UpToDate+               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable++           -- Always recompile with the JS backend when TH is enabled until+           -- #23013 is fixed.+           | ArchJavaScript <- platformArch (targetPlatform lcl_dflags)+           , xopt LangExt.TemplateHaskell lcl_dflags+           -> do+              msg $ needsRecompileBecause THWithJS+              return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface++           | otherwise -> do+               -- Do need linkable+               -- 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 $ 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+                | linkableIsNativeCodeOnly 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 (linkableIsNativeCodeOnly 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 iface_core_bindings iface (ms_location mod_sum) of+      Just fi -> do+          return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))+      _ -> return $ outOfDateItemBecause MissingBytecode Nothing++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------++add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> IO ()+add_iface_to_hpt iface details =+  hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable)++-- 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+    add_iface_to_hpt iface details' 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++-- | Modify flags such that objects are compiled for the interpreter's way.+-- This is necessary when building foreign objects for Template Haskell, since+-- those are object code built outside of the pipeline, which means they aren't+-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build+-- outputs for dependencies when the interpreter used for TH is dynamic but the+-- main outputs aren't.+-- Furthermore, the HPT only stores one set of objects with different names for+-- bytecode linking in 'HomeModLinkable', so the usual hack for switching+-- between ways in 'get_link_deps' doesn't work.+compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a+compile_for_interpreter hsc_env use =+  use (hscUpdateFlags update hsc_env)+  where+    update dflags = dflags {+      targetWays_ = adapt_way interpreterDynamic WayDyn $+                    adapt_way interpreterProfiled WayProf $+                    targetWays_ dflags+      }++    adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay++-- | Assemble 'WholeCoreBindings' if the interface contains Core bindings.+iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings+iface_core_bindings iface wcb_mod_location =+  mi_simplified_core <&> \(IfaceSimplifiedCore bindings foreign') ->+    WholeCoreBindings {+      wcb_bindings = bindings,+      wcb_module = mi_module,+      wcb_mod_location,+      wcb_foreign = foreign'+    }+  where+    ModIface {mi_module, mi_simplified_core} = iface++-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if+-- the interface contains any, using the supplied type env for typechecking.+--+-- Unlike 'initWholeCoreBindings', this does not use lazy IO.+-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear+-- that it will be used immediately (because we're linking TH with+-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in+-- 'LoaderState'.+--+-- 'initWholeCoreBindings' needs the laziness because it is used to populate+-- 'HomeModInfo', which is done preemptively, in anticipation of downstream+-- modules using the bytecode for TH in make mode, which might never happen.+loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)+loadIfaceByteCode hsc_env iface location type_env =+  compile <$> iface_core_bindings iface location+  where+    compile decls = do+      (bcos, fos) <- compileWholeCoreBindings hsc_env type_env decls+      linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos]++    linkable parts = do+      if_time <- modificationTimeIfExists (ml_hi_file location)+      time <- maybe getCurrentTime pure if_time+      return $! Linkable time (mi_module iface) parts++loadIfaceByteCodeLazy ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  IO (Maybe Linkable)+loadIfaceByteCodeLazy hsc_env iface location type_env =+  case iface_core_bindings iface location of+    Nothing -> return Nothing+    Just wcb -> do+      Just <$> compile wcb+  where+    compile decls = do+      ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls+      linkable $ NE.singleton (LazyBCOs bcos fos)++    linkable parts = do+      if_time <- modificationTimeIfExists (ml_hi_file location)+      time <- maybe getCurrentTime pure if_time+      return $!Linkable time (mi_module iface) parts++-- | If the 'Linkable' contains Core bindings loaded from an interface, replace+-- them with a lazy IO thunk that compiles them to bytecode and foreign objects,+-- using the supplied environment for type checking.+--+-- The laziness is necessary because this value is stored purely in a+-- 'HomeModLinkable' in the home package table, rather than some dedicated+-- mutable state that would generate bytecode on demand, so we have to call this+-- function even when we don't know that we'll need the bytecode.+--+-- In addition, the laziness has to be hidden inside 'LazyBCOs' because+-- 'Linkable' is used too generally, so that looking at the constructor to+-- decide whether to discard it when linking native code would force the thunk+-- otherwise, incurring a significant performance penalty.+--+-- This is sound because generateByteCode just depends on things already loaded+-- in the interface file.++-- TODO: We should just use loadIfaceByteCodeLazy instead of the two stage process with+-- loadByteCode and initWholeCoreBindings. The main reason it is like this is because+-- initWholeCoreBindings requires a ModDetails, which we don't have during recompilation+-- checking. We should modify recompilation checking to return a HomeModInfo directly.++initWholeCoreBindings ::+  HscEnv ->+  ModIface ->+  ModDetails ->+  Linkable ->+  IO Linkable+initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do+  Linkable utc_time this_mod <$> mapM (go hsc_env) uls+  where+    go hsc_env' = \case+      CoreBindings wcb -> do+        add_iface_to_hpt iface details hsc_env+        ~(bco, fos) <- unsafeInterleaveIO $+                       compileWholeCoreBindings hsc_env' type_env wcb+        pure (LazyBCOs bco fos)+      l -> pure l++    type_env = md_types details++-- | Hydrate interface Core bindings and compile them to bytecode.+--+-- This consists of:+--+-- 1. Running a typechecking step to insert the global names that were removed+--    when the interface was written or were unavailable due to boot import+--    cycles, converting the bindings to 'CoreBind'.+--+-- 2. Restoring the foreign build inputs from their serialized format, resulting+--    in a set of foreign import stubs and source files added via+--    'qAddForeignFilePath'.+--+-- 3. Generating bytecode and foreign objects from the results of the previous+--    steps using the usual pipeline actions.+compileWholeCoreBindings ::+  HscEnv ->+  TypeEnv ->+  WholeCoreBindings ->+  IO (CompiledByteCode, [FilePath])+compileWholeCoreBindings hsc_env type_env wcb = do+  core_binds <- typecheck+  (stubs, foreign_files) <- decode_foreign+  gen_bytecode core_binds stubs foreign_files+  where+    typecheck = do+      types_var <- newIORef type_env+      let+        tc_env = hsc_env {+          hsc_type_env_vars =+            knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])+        }+      initIfaceCheck (text "l") tc_env $+        typecheckWholeCoreBindings types_var wcb++    decode_foreign =+      decodeIfaceForeign logger (hsc_tmpfs hsc_env)+      (tmpDir (hsc_dflags hsc_env)) wcb_foreign++    gen_bytecode core_binds stubs foreign_files = do+      let cgi_guts = CgInteractiveGuts wcb_module core_binds+                      (typeEnvTyCons type_env) stubs foreign_files+                      Nothing []+      trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module)+      generateByteCode hsc_env cgi_guts wcb_mod_location++    WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb++    logger = hsc_logger hsc_env++{-+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+  -- exception is when it is not a HsSrcFile module.+  mb_desugar <- if+    | hsc_src /= HsSrcFile       -> pure Nothing+    -- Desugar an empty ghc-prim:GHC.Prim module by filtering out all its+    -- bindings: the reason is that some of them are invalid (such as top-level+    -- unlifted ones like void# or proxy#) and cause HsToCore failures.+    --+    -- We still need to desugar *something* because the driver and the linkers+    -- expect a valid object file (.o) to be generated for this module.+    | ms_mod summary == gHC_PRIM -> Just <$> hscDesugar' (ms_location summary) (tc_result { tcg_binds = [] })+    | otherwise                  -> Just <$> hscDesugar' (ms_location summary) tc_result++  -- 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++          !partial_iface <- liftIO $+                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                fmap force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) 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)++          -- when compiling gHC_PRIM without generating code (e.g. with+          -- Haddock), we still want the virtual interface in the cache+          if ms_mod summary == gHC_PRIM+            then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+            else 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)++        -- when compiling gHC_PRIM without generating code (e.g. with+        -- Haddock), we still want the virtual interface in the cache+        if ms_mod summary == gHC_PRIM+          then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+          else 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 (flagsToIfCompression dflags) 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 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.Utils.Touch.touch 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+++--------------------------------------------------------------+-- 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++        diag_opts <- initDiagOpts <$> getDynFlags+        print_config <- initPrintConfig <$> getDynFlags+        logger <- getLogger++        -- Will throw if failed safe check+        liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs++        -- No fatal warnings or errors: passed safe check+        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 = M.toList 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+        iface <- liftIO $ lookupIfaceByModuleHsc hsc_env 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 $+             mkSimpleUnknownDiagnostic $+             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 (ext,loc,on,_)+        | on df     = [mkLocMessage MCOutput (loc df) $+                            text "-X" <> ppr ext <+> 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 mod_loc output_filename = do+        let CgGuts{ cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_ccs      = local_ccs+                    } = cgguts+            dflags = hsc_dflags hsc_env+            logger = hsc_logger hsc_env++        -------------------+        -- ADD IMPLICIT BINDINGS+        -- NB: we must feed mkImplicitBinds through corePrep too+        -- so that they are suitably cloned and eta-expanded+        let cp_pgm_cfg :: CorePrepPgmConfig+            cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                               (interactiveInScope $ hsc_IC hsc_env)+        binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds++        -------------------+        -- INSERT LATE COST CENTRES, based on the provided flags.+        --+        -- If -fprof-late-inline is enabled, we will skip adding CCs on any+        -- top-level bindings here (via shortcut in `addLateCostCenters`), since+        -- it will have already added a superset of the CCs we would add here.+        let+          late_cc_config :: LateCCConfig+          late_cc_config =+            LateCCConfig+              { lateCCConfig_whichBinds =+                  if gopt Opt_ProfLateInlineCcs dflags then+                    LateCCNone+                  else if gopt Opt_ProfLateCcs dflags then+                    LateCCBinds+                  else if gopt Opt_ProfLateOverloadedCcs dflags then+                    LateCCOverloadedBinds+                  else+                    LateCCNone+              , lateCCConfig_overloadedCalls =+                  gopt Opt_ProfLateoverloadedCallsCCs dflags+              , lateCCConfig_env =+                  LateCCEnv+                    { lateCCEnv_module = this_mod+                    , lateCCEnv_file = fsLit <$> ml_hs_file mod_loc+                    , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags+                    , lateCCEnv_collectCCs = True+                    }+              }++        (late_cc_binds, late_cc_state) <-+          addLateCostCenters logger late_cc_config binds_with_implicits++        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 late_cc_binds))++        -------------------+        -- RUN LATE PLUGINS+        -- This is the last use of the CgGuts in a compilation.+        -- From now on, we just use the bits we need.+        ( CgGuts+            { cg_tycons        = tycons,+              cg_foreign       = foreign_stubs0,+              cg_foreign_files = foreign_files,+              cg_dep_pkgs      = dependencies,+              cg_spt_entries   = spt_entries,+              cg_binds         = binds_to_prep,+              cg_ccs           = late_local_ccs+            }+          , _+          ) <-+          {-# SCC latePlugins #-}+          withTiming+            logger+            (text "LatePlugins"<+>brackets (ppr this_mod))+            (const ()) $+            withPlugins (hsc_plugins hsc_env)+              (($ hsc_env) . latePlugin)+                ( cgguts+                    { cg_binds = late_cc_binds+                    , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs+                    }+                , lateCCState_ccState late_cc_state+                )++        let+          hooks  = hsc_hooks hsc_env+          tmpfs  = hsc_tmpfs hsc_env+          llvm_config = hsc_llvm_config hsc_env+          profile = targetProfile dflags++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        cp_cfg <- initCorePrepConfig hsc_env+        (prepd_binds) <- {-# SCC "CorePrep" #-}+                         corePrepPgm+                           (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                           this_mod binds_to_prep++        -----------------  Convert to STG ------------------+        (stg_binds_with_deps, 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 (interactiveInScope (hsc_IC hsc_env)) False this_mod mod_loc prepd_binds)++        let (stg_binds,_stg_deps) = unzip stg_binds_with_deps++        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++                  -- The JavaScript backend does not create CmmCgInfos like the Cmm backend,+                  -- but it is needed for writing the interface file. Here we compute a very+                  -- conservative but correct value.+                  lf_infos (StgTopLifted (StgNonRec b _)) = [(idName b, LFUnknown True)]+                  lf_infos (StgTopLifted (StgRec bs))     = map (\(b,_) -> (idName b, LFUnknown True)) bs+                  lf_infos (StgTopStringLit b _)          = [(idName b, LFUnlifted)]++                  cmm_cg_infos  = CmmCgInfos+                    { cgNonCafs = mempty+                    , cgLFInfos = mkNameEnv (concatMap lf_infos stg_binds)+                    , cgIPEStub = mempty+                    }+                  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, Just cmm_cg_infos)++            _          ->+              do+              cmms <- {-# SCC "StgToCmm" #-}+                doCodeGen hsc_env this_mod denv tycons+                cost_centre_info+                stg_binds++              ------------------  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 (liftIO . 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 mod_loc+                    foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) 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_foreign_files :: [(ForeignSrcLang, FilePath)]+                                           , cgi_modBreaks ::  Maybe ModBreaks+                                           , cgi_spt_entries :: [SptEntry]+                                           }++mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts+mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries}+  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries++hscInteractive :: HscEnv+               -> CgInteractiveGuts+               -> ModLocation+               -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode+hscInteractive hsc_env cgguts mod_loc = 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++    -------------------+    -- ADD IMPLICIT BINDINGS+    let cp_pgm_cfg :: CorePrepPgmConfig+        cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                           (interactiveInScope $ hsc_IC hsc_env)+    binds_to_prep <- addImplicitBinds cp_pgm_cfg mod_loc tycons core_binds++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    cp_cfg <- initCorePrepConfig hsc_env+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                               this_mod binds_to_prep++    -- The stg cg info only provides a runtime benfit, but is not requires so we just+    -- omit it here+    (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)+      <- {-# SCC "CoreToStg" #-}+          myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod mod_loc prepd_binds++    let (stg_binds,_stg_deps) = unzip stg_binds_with_deps++    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries++    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod mod_loc foreign_stubs+    return (istub_c_exists, comp_bc)++-- | Compile Core bindings and foreign inputs that were loaded from an+-- interface, to produce bytecode and potential foreign objects for the purpose+-- of linking splices.+generateByteCode :: HscEnv+  -> CgInteractiveGuts+  -> ModLocation+  -> IO (CompiledByteCode, [FilePath])+generateByteCode hsc_env cgguts mod_location = do+  (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location+  compile_for_interpreter hsc_env $ \ i_env -> do+    stub_o <- traverse (compileForeign i_env LangC) hasStub+    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)+    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)++generateFreshByteCode :: HscEnv+  -> ModuleName+  -> CgInteractiveGuts+  -> ModLocation+  -> IO Linkable+generateFreshByteCode hsc_env mod_name cgguts mod_location = do+  bco_time <- getCurrentTime+  (bcos, fos) <- generateByteCode hsc_env cgguts mod_location+  return $!+    Linkable bco_time+    (mkHomeModule (hsc_home_unit hsc_env) mod_name)+    (BCOs bcos :| [DotO fo ForeignObject | fo <- fos])+------------------------------++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+    (dcmm, 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)+    -- Probably need to rename cmm here+    let cmm = removeDeterm dcmm+    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]+        ((_,dus1), cmmgroup) <- second concat <$>+          mapAccumLM (\(msrt0, dus0) cmm -> do+            ((msrt1, cmm'), dus1) <- cmmPipeline logger cmm_config msrt0 [cmm] dus0+            return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 0) cmm++        unless (null cmmgroup) $+          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"+            FormatCMM (pdoc platform cmmgroup)++        rawCmms0 <- case cmmToRawCmmHook hooks of+          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)+          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)++        let dump a = do+              unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+              return a+            rawCmms = Stream.mapM (liftIO . dump) rawCmms0++        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+             dus1 rawCmms+        return stub_c_exists+  where+    no_loc = OsPathModLocation+        { ml_hs_file_ospath  = Just $ unsafeEncodeUtf original_filename,+          ml_hi_file_ospath  = panic "hscCompileCmmFile: no hi file",+          ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",+          ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",+          ml_dyn_hi_file_ospath  = panic "hscCompileCmmFile: no dyn obj file",+          ml_hie_file_ospath = 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+          -> IO (CgStream 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 tycons+              cost_centre_info stg_binds_w_fvs = 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 a b c d = case stgToCmmHook hooks of+          Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d+          Just h  -> (,emptyDetUFM) <$> h          (initStgToCmmConfig dflags mod) a b c d++    let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)+        -- See Note [Forcing of stg_binds]+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv tycons cost_centre_info stg_binds_w_fvs++        -- 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 (liftIO . dump1) cmm_stream++        cmm_config = initCmmConfig dflags++        pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos+        pipeline_stream = do+          ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-+            {-# SCC "cmmPipeline" #-}+            Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1++          let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)++              -- denv::InfoTableProvMap refers to symbols that no longer exist+              -- if -fobject-determinism is on, since it was created before the+              -- Cmm was renamed. Update all the symbols by renaming them with+              -- the renaming map in that case.+              (_drn, rn_denv)+                | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv+                | otherwise = (detRnEnv, denv)++          cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats)+          return cmmCgInfos++        pipeline_action+          :: Logger+          -> CmmConfig+          -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+          -> CmmGroup+          -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)+        pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do+          (mod_srt_info', cmm_srts) <- withDUS $ cmmPipeline logger cmm_config mod_srt_info cmm_group++          -- If -finfo-table-map is enabled, we precompute a map from info+          -- tables to source locations. See Note [Mapping Info Tables to Source+          -- Positions] in GHC.Stg.Debug.+          (ipes', stats') <-+            if (gopt Opt_InfoTableMap dflags) then+              liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts+            else+              return (ipes, stats)++          return ((mod_srt_info', ipes', stats'), cmm_srts)++        dump2 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)+          return a++    return $ Stream.mapM (liftIO . dump2) pipeline_stream++myCoreToStg :: Logger -> DynFlags -> [Var]+            -> Bool+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [(CgStgTopBinding,IdSet)] -- output program and its dependencies+                  , InfoTableProvMap+                  , CollectedCCs -- CAF cost centre info (declared and used)+                  , StgCgInfos )+myCoreToStg logger dflags ic_inscope 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 ic_inscope (initStgPipelineOpts dflags for_bytecode)+                   this_mod stg_binds++    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst 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)++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++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 = OsPathModLocation+            { ml_hs_file_ospath   = Nothing,+              ml_hi_file_ospath   = panic "hsDeclsWithLocation:ml_hi_file_ospath",+              ml_obj_file_ospath  = panic "hsDeclsWithLocation:ml_obj_file_ospath",+              ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",+              ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",+              ml_hie_file_ospath  = panic "hsDeclsWithLocation:ml_hie_file_ospath" }+    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+                 } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++    {- Generate byte code & foreign stubs -}+    linkable <- liftIO $ generateFreshByteCode hsc_env+      (moduleName this_mod)+      (mkCgInteractiveGuts tidy_cg)+      iNTERACTIVELoc++    let src_span = srcLocSpan interactiveSrcLoc+    _ <- liftIO $ loadDecls interp hsc_env src_span linkable++    {- 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 $+                     mkSimpleUnknownDiagnostic $+                      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+             $ mkSimpleUnknownDiagnostic+             $ 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++  -- Create a unique temporary binding+  --+  -- The id has to be exported for the JS backend. This isn't required for the+  -- byte-code interpreter but it does no harm to always do it.+  u <- uniqFromTag 'I'+  let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel"))+  let binding_id   = mkExportedVanillaId binding_name (exprType simpl_expr)++  {- Tidy it (temporary, until coreSat does cloning) -}+  let tidy_occ_env = initTidyOccEnv [occName binding_id]+  let tidy_env     = mkEmptyTidyEnv tidy_occ_env+  let tidy_expr    = tidyExpr tidy_env simpl_expr++  {- Prepare for codegen -}+  cp_cfg <- initCorePrepConfig hsc_env+  prepd_expr <- corePrepExpr+   logger cp_cfg+   tidy_expr++  {- Lint if necessary -}+  lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr+  let this_loc = OsPathModLocation+          { ml_hs_file_ospath   = Nothing,+            ml_hi_file_ospath   = panic "hscCompileCoreExpr':ml_hi_file_ospath",+            ml_obj_file_ospath  = panic "hscCompileCoreExpr':ml_obj_file_ospath",+            ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",+            ml_dyn_hi_file_ospath  = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",+            ml_hie_file_ospath  = panic "hscCompileCoreExpr':ml_hie_file_ospath" }++  -- Ensure module uniqueness by giving it a name like "GhciNNNN".+  -- This uniqueness is needed by the JS linker. Without it we break the 1-1+  -- relationship between modules and object files, i.e. we get different object+  -- files for the same module and the JS linker doesn't support this.+  --+  -- Note that we can't use icInteractiveModule because the ic_mod_index value+  -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't+  -- guaranteed.+  --+  -- We reuse the unique we obtained for the binding, but any unique would do.+  let this_mod = mkInteractiveModule (show u)+  let for_bytecode = True++  (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <-+       myCoreToStg logger+                   dflags+                   (interactiveInScope (hsc_IC hsc_env))+                   for_bytecode+                   this_mod+                   this_loc+                   [NonRec binding_id prepd_expr]++  let (stg_binds, _stg_deps) = unzip stg_binds_with_deps++  let interp = hscInterp hsc_env++  case interp of+    -- always generate JS code for the JS interpreter (no bytecode!)+    Interp (ExternalInterp (ExtJS i)) _ _ ->+      jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id++    _ -> do+      {- Convert to BCOs -}+      bcos <- byteCodeGen hsc_env+                this_mod+                stg_binds+                []+                Nothing -- modbreaks+                [] -- spt entries++      {- load it -}+      bco_time <- getCurrentTime+      (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $+        Linkable bco_time this_mod $ NE.singleton $ BCOs bcos+      {- Get the HValue for the root -}+      return (expectJust $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)++++-- | Generate JS code for the given bindings and return the HValue for the given id+jsCodeGen+  :: HscEnv+  -> SrcSpan+  -> JSInterp+  -> Module+  -> [(CgStgTopBinding,IdSet)]+  -> Id+  -> IO (ForeignHValue, [Linkable], PkgsLoaded)+jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do+  let logger           = hsc_logger hsc_env+      tmpfs            = hsc_tmpfs hsc_env+      dflags           = hsc_dflags hsc_env+      interp           = hscInterp hsc_env+      tmp_dir          = tmpDir dflags+      unit_env         = hsc_unit_env hsc_env+      js_config        = initStgToJSConfig dflags++  -- We need to load all the dependencies first.+  --+  -- We get all the imported names from the Stg bindings and load their modules.+  --+  -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker)+  let+    (stg_binds, stg_deps) = unzip stg_binds_with_deps+    imported_ids   = nonDetEltsUniqSet (unionVarSets stg_deps)+    imported_names = map idName imported_ids++    needed_mods :: [Module]+    needed_mods = [ nameModule n | n <- imported_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.++  -- Initialise the linker (if it's not been done already)+  initLoaderState interp hsc_env++  -- Take lock for the actual work.+  (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do+    let link_opts = initLinkDepsOpts hsc_env++    -- Find what packages and linkables are required+    deps <- getLinkDeps link_opts interp pls srcspan needed_mods+    -- We update the LinkerState even if the JS interpreter maintains its linker+    -- state independently to load new objects here.++    let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps)+        (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs++    -- FIXME: we should make the JS linker load new_objs here, instead of+    -- on-demand.++    -- FIXME: we don't report needed units because we would have to find a way+    -- to build a meaningful LoadedPkgInfo (see the mess in+    -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load+    -- and actually loading (using the native interpreter) are intermingled, so+    -- we can't directly reuse this code.+    let pls' = pls { objs_loaded = objs_loaded' }+    pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) )+++  let foreign_stubs    = NoStubs+      spt_entries      = mempty+      cost_centre_info = mempty++  -- codegen into object file whose path is in out_obj+  out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o"+  stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj++  let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod+  -- link code containing binding "id_sym = expr", using id_sym as root+  withJSInterp i $ \inst -> do+    let roots = mkExportedModFuns this_mod [id_sym]+    jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots++  -- look up "id_sym" closure and create a StablePtr (HValue) from it+  href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case+    Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)+    Just r  -> pure r++  binding_fref <- withJSInterp i $ \inst ->+                    mkForeignRef href (freeReallyRemoteRef inst href)++  return (castForeignRef binding_fref, dep_linkables, dep_units)+++{- **********************************************************************+%*                                                                      *+        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)++++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ not (backendGeneratesCode (backend dflags))
+ GHC/Driver/Main.hs-boot view
@@ -0,0 +1,15 @@+module GHC.Driver.Main where++import GHC.Driver.Env.Types (HscEnv)+import GHC.Linker.Types (Linkable)+import GHC.Prelude.Basic+import GHC.Types.TypeEnv (TypeEnv)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Unit.Module.ModIface (ModIface)++loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)
+ GHC/Driver/Make.hs view
@@ -0,0 +1,1935 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}++-- -----------------------------------------------------------------------------+--+-- (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,+        load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        SummaryNode,+        IsBootInterface(..), mkNodeKey,++        ModNodeKey, ModNodeKeyWithUid(..),+        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith,++        -- * Re-exports from Downsweep+        checkHomeUnitsClosed,+        summariseModule,+        summariseModuleInterface,+        SummariseResult(..),+        summariseFile,++        instantiationNodes,+        ) 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.Driver.Config.Diagnostic+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.DynFlags (ReexportedModule(..))+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main+import GHC.Driver.MakeSem+import GHC.Driver.Downsweep+import GHC.Driver.MakeAction++import GHC.ByteCode.Types++import GHC.Iface.Load      ( cannotFindModule, readIface )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )++import GHC.Data.Bag        ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.Maybe      ( expectJust )++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+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.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 qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.List (sortOn, groupBy, sortBy)+import qualified Data.List as List+import System.FilePath++import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+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.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Utils.Constants+import GHC.Iface.Errors.Types+import Data.Function+import qualified GHC.Data.Maybe as M++import GHC.Data.Graph.Directed.Reachability+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable++-- -----------------------------------------------------------------------------+-- 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 mkUnknownDiagnostic Nothing 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+               (GhcMessage -> AnyGhcDiagnostic)+            -> Maybe Messager+            -> [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (DriverMessages, ModuleGraph)+depanalE diag_wrapper msg excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial diag_wrapper msg 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 $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+        logDiagnostics (GhcDriverMessage <$> all_errs)+        setSession (setModuleGraph mod_graph hsc_env)+        pure (emptyMessages, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession (setModuleGraph emptyMG hsc_env)+        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+    => (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (DriverMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial diag_wrapper msg 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, mod_graph) <- liftIO $ downsweep+      hsc_env diag_wrapper msg (mgModSummaries old_graph)+      excluded_mods allow_dup_roots+    return (unionManyMessages errs, mod_graph)+++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`.+--+-- Here "home module" means a module that doesn't come from another 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 the 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++    -- 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_known_module mod =+      is_module_target mod+      ||+      maybe False is_file_target (ml_hs_file (ms_location mod))++    is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets++    is_file_target file = Set.member (withoutExt file) file_targets++    file_targets = Set.fromList (mapMaybe file_target targets)++    file_target Target {targetId} =+      case targetId of+        TargetModule _ -> Nothing+        TargetFile file _ ->+          Just (withoutExt (augmentByWorkingDirectory dflags file))++    mod_targets = Set.fromList (mod_target <$> targets)++    mod_target Target {targetUnitId, targetId} =+      case targetId of+        TargetModule name -> (name, targetUnitId)+        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++    withoutExt = fst . splitExtension++    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 (homeUnitId_ dflags) 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 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 (reexportFrom mn)+      case fr of+        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+        _ -> return True+++    warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ diagnostic++    final_msgs hidden_warns reexported_warns+          =+        unionManyMessages $+          [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)]+          ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) 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 modules and its dependencies.+     -- If empty, we load none of the targets+   | 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 }++instance Outputable CachedIface where+  ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln]++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 mkUnknownDiagnostic 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 -- ^ Instructions about how to cache interfaces as we create them.+                            -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.+                                                                -- If you are using the GHC API you can use this to override how messages+                                                                -- created during 'loadWithCache' are displayed to the user.+                            -> LoadHowMuch -- ^ How much `loadWithCache` should load+                            -> m SuccessFlag+loadWithCache cache diag_wrapper how_much = do+    msg <- mkBatchMsg <$> getSession+    (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False                        -- #17459+    success <- load' cache how_much diag_wrapper (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++        home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs)+            $ concatMap ms_imps home_mod_sum++        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 = sortOn (\(u,_,_,_) -> u) $ 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+        acyclic_mod_graph = topSortModuleGraph False 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 acyclic_mod_graph+          | 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 ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++        -- Compute the intermediate modules between a file and its hs-boot file.+        -- See Step 2a in Note [Upsweep]+        boot_path mn uid =+          Set.toList $+          -- Don't include the boot module itself+          Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey)  $+          -- 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 (\(mkNodeKey -> nk) ->+            nodeKeyUnitId nk == uid  -- Cheap test+              && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $+          Set.fromList $+          expectJust (mgReachable mod_graph (NodeKey_Module (key NotBoot)))+          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+          [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn)))+            | m@(ModuleNode _ ms) <- mgModSummaries' mod_graph+            , let mn = moduleNodeInfoModule ms+            , isBootModuleNodeInfo 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 (ModuleNode _ ms)+          | NotBoot <- isBootModuleNodeInfo ms+          = lookupModuleEnv boot_modules (moduleNodeInfoModule ms)+        get_boot_module _ = Nothing++        -- Any cycles should be resolved now+        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        -- Must be at least two nodes, as we were in a cycle+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes)+        -- Cyclic+        collapseSCC nodes = Left (flattenSCCs nodes)++        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+    -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module+    -- graph is pruned, reducing the number of 'build_plan' elements.+    -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added+    -- later in the processing.+    assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph)+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))])+              build_plan+  where+    lengthMGWithSCC :: [SCC a] -> Int+    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0++-- | 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 -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do+    -- In normal usage plugins are initialised already by ghc/Main.hs this is protective+    -- for any client who might interact with GHC via load'.+    -- See Note [Timing of plugin initialization]+    initializeSessionPlugins+    modifySession (setModuleGraph 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 ms)          = checkMods ms+        checkHowMuch (LoadDependenciesOf m) = checkMods [m]+        checkHowMuch _ = id++        checkMods ms and_then =+          case List.partition (`Set.member` all_home_mods) ms of+            (_, []) -> and_then+            (_, not_found_mods) -> do+              let+                mkModuleNotFoundError m =+                  mkPlainErrorMsgEnvelope noSrcSpan+                  $ GhcDriverMessage+                  $ DriverModuleNotFound (moduleUnit m) (moduleName m)+              throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods]++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles. It is just used for warning about unnecessary 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_mods = case how_much of+                          LoadUpTo m           -> Just m+                          LoadDependenciesOf m -> Just [m]+                          _                    -> Nothing++        build_plan = createBuildPlan mod_graph maybe_top_mods+++    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+                            [ms | (ModuleNodeCompile ms) <- (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 = do+          emptyHPT <- liftIO emptyHomePackageTable+          pure $! hme{ homeUnitEnv_hpt = emptyHPT }+    hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env)+    let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' }+    setSession $ discardIC hsc_env{hsc_unit_env = ue' }+    hsc_env <- getSession++    -- Unload everything+    liftIO $ unload interp hsc_env++    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+                                    2 (ppr build_plan))++    worker_limit <- liftIO $ mkWorkerLimit dflags++    (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do+      hsc_env <- getSession+      liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan++    -- At this point, all the HPT variables will be populated, but we don't want+    -- to leak the contents of a failed session.+    liftIO $ restrictDepsHscEnv new_deps hsc_env+    case upsweep_ok of+      Failed -> loadFinish upsweep_ok+      Succeeded -> do+          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+          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 fmap (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 (moduleNodeInfoLocation 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' <- case platformArchOS platform of+                             ArchOS _ OSMinGW32  -> fmap (<.> "exe") name+                             ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name+                             _ -> 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 = miKey iface+           linkable'+                | Just ms <- M.lookup modl ms_map+                , mi_src_hash iface == Just (ms_hs_hash ms)+                = linkable+                | otherwise+                = emptyHomeModInfoLinkable++        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.+        ms_map = M.fromListWith+                  (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2))+                               ms2)+                  [(msKey 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)+                               }++-- 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) -> 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+                                     }++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 . flip M.lookup build_map) direct_deps++type BuildM a = StateT BuildLoopState 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+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1)+  let wait = collect_results (buildDep build_map)+  return (mcycle, plans, wait)++  where+    collect_results build_map =+      sequence (map (\br -> collect_result (resultVar br)) (M.elems build_map))+      where+        collect_result res_var = runMaybeT (waitResult res_var)++    -- Just used for an assertion+    count_mods :: BuildPlan -> Int+    count_mods (SingleModule m) = count_m m+    count_mods (ResolvedCycle ns) = length ns+    count_mods (UnresolvedCycle ns) = length ns++    count_m (UnitNode {}) = 0+    count_m _ = 1++    n_mods = sum (map count_mods 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+      !build_map <- getBuildMap+      -- 1. Get the direct dependencies of this module+      let direct_deps = mgNodeDependencies 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+      !build_action <-+            case mod of+              InstantiationNode uid iu -> do+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                  !_ <- wait_deps build_deps+                  executeInstantiationNode mod_idx n_mods hug uid iu+                  return Nothing+              ModuleNode _build_deps ms -> do+                let !old_hmi = M.lookup (mnKey ms) old_hpt+                    rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                     !_ <- wait_deps build_deps+                     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+                     -- Make sure the result is written to the HPT var+                     liftIO $ HUG.addHomeModInfoToHug hmi hug+                     return (Just hmi)+              LinkNode _nks uid -> do+                  mod_idx <- nodeId+                  return $ withCurrentUnit (mgNodeUnitId mod) $ do+                    !_ <- wait_deps build_deps+                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps+                    return Nothing+              UnitNode {} -> return $ return Nothing+++      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+      !build_map <- getBuildMap+      res_var <- liftIO newEmptyMVar+      let loop_unit :: UnitId+          !loop_unit = nodeKeyUnitId (gwib_mod (head deps))+          !build_deps = getDependencies (map gwib_mod deps) build_map+      let loop_action = withCurrentUnit loop_unit $ do+            !_ <- wait_deps build_deps+            hsc_env <- asks hsc_env+            let mns :: [ModuleName]+                mns = mapMaybe (nodeKeyModName . gwib_mod) deps++            hmis' <- liftIO $ rehydrateAfter hsc_env mns++            checkRehydrationInvariant hmis' deps++            -- Add hydrated interfaces to global variable+            liftIO $ mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi hug) hmis'+            return hmis'++      let fanout i = 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+    :: WorkerLimit -- ^ 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+    -> (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> M.Map ModNodeKeyWithUid HomeModInfo+    -> [BuildPlan]+    -> IO (SuccessFlag, [HomeModInfo])+upsweep n_jobs hsc_env hmi_cache diag_wrapper 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 diag_wrapper mHscMessage pipelines+    res <- collect_result++    let completed = [m | Just (Just m) <- res]++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+          throwOneError $ cyclicModuleErr mss+        Nothing  -> do+          let success_flag = successIf (all isJust res)+          return (success_flag, completed)++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++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+  -- used to only happen with the bytecode backend, but with+  -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating+  -- object code, see #25230.+  hscInsertHPT hmi hsc_env+  addSptEntries (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+     | linkable <- maybeToList mlinkable+     , bco <- linkableBCOs linkable+     , spt <- bc_spt_entries bco+     ]+++-- 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 =+  topSortModules drop_hs_boot_nodes+    (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph)+    mb_root_mod+++  where+    -- In order to get the "right" ordering+    --    Module nodes must be in reverse lexigraphic order.+    --    All modules nodes must appear before package nodes.+    --+    -- MP: This is just the ordering which the tests needed in Jan 2025, it does+    --     not arise from nature.+    --+    -- Given the current implementation of scc, the result is in+    -- The order is sensitive to the internal implementation in Data.Graph,+    -- if it changes in future then this ordering will need to be modified.+    --+    -- The SCC algorithm firstly transposes the input graph and then+    -- performs dfs on the vertices in the order which they are originally given.+    -- Therefore, if `ExternalUnit` nodes are first, the order returned will+    -- be determined by the order the dependencies are stored in the transposed graph.+    moduleGraphNodeRank :: NodeKey -> Int+    moduleGraphNodeRank k =+      case k of+        NodeKey_Unit {}         -> 0+        NodeKey_Module {}       -> 1+        NodeKey_Link {}         -> 2+        NodeKey_ExternalUnit {} -> 3++    cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2)+                                  `mappend` compare k2 k1++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 mods ->+            -- 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+              findNodeForModule (Module uid root_mod)+                | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+                , graph `hasVertexG` node+                = seq node node+                | otherwise+                = throwGhcException (ProgramError "module does not exist")+              roots = fmap findNodeForModule mods+            in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots))++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 ModuleNodeInfo] -> 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 moduleNodeInfoModuleName ms in+           [ warn i | (ModuleNodeCompile 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))+++-----------------------------------------------------------------------------+--                      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. The lazy variant is used here as we want to force+            -- this error if the IORef is ever accessed again, rather than now.+            -- See #20981 for an issue which discusses this general issue.+            let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []+            actions <- atomicModifyIORef ref $ \i -> (landmine, 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 $+    DriverInterfaceError $+    (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot))++{-+noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}++++cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = assert (not (null mss)) $+    case findCycle graph of+       Nothing   -> pprPanic "Unexpected non-cycle" (ppr mss)+       Just path -> mkPlainErrorMsgEnvelope src_span $+                    GhcDriverMessage $ DriverModuleGraphCycle path+        where+          src_span = maybe noSrcSpan (mkFileSrcSpan . moduleNodeInfoLocation) (mgNodeIsModule (head path))+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = mgNodeDependencies False ms+        }+      | ms <- mss+      ]++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+  if gopt Opt_KeepTmpFiles dflags+    then liftIO $ keepCurrentModuleTempFiles logger tmpfs+    else liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++-- | Thin each HPT variable to only contain keys from the given dependencies.+-- This is used at the end of upsweep to make sure that only completely successfully loaded+-- modules are visible for subsequent operations.+restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO ()+restrictDepsHscEnv deps hsc_env =+  let deps_with_unit = map (\xs -> (fst (head xs), map snd xs)) $ groupBy ((==) `on` fst) (sortOn fst (map go deps))+      hug = ue_home_unit_graph $ hsc_unit_env hsc_env+      go hmi = (hmi_unit, hmi)+        where+          hmi_mod  = mi_module (hm_iface hmi)+          hmi_unit = toUnitId (moduleUnit hmi_mod)+  in HUG.restrictHug deps_with_unit hug+++setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+  hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)+wrapAction msg_wrapper hsc_env k = do+  let lcl_logger = hsc_logger hsc_env+      lcl_dynflags = hsc_dflags hsc_env+      print_config = initPrintConfig lcl_dynflags+      logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> 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 $ 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+++++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+        wrapper <- asks diag_wrapper+        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+          let lcl_hsc_env = setHUG deps hsc_env+          in wrapAction wrapper 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 interprets how --make module should compile a ModuleNode+--+-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check+--    if the interface file exists and is up to date. If it is, we return those.+--    Otherwise, we compile the module and return the new HomeModInfo.+-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface+--    and artifacts from disk.++executeCompileNode :: Int+  -> Int+  -> Maybe HomeModInfo+  -> HomeUnitGraph+  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+  -> ModuleNodeInfo+  -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi hug mrehydrate_mods mni = 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+     hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods+     case mni of+       ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me  mod+       ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc+    )++  where+    fixed_mrehydrate_mods =+      case moduleNodeInfoHscSource mni 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.+        Just HsigFile -> Just []+        _        -> mrehydrate_mods++    executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)+    executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc =+      wrapAction diag_wrapper hsc_env $ do+        forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc))+        read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc)+        case read_result of+          M.Failed interface_err ->+            let mn = mnkModuleName mod+                err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn))+            in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err))+          M.Succeeded iface -> do+            details <- genModDetails hsc_env iface+            mb_object <- findObjectLinkableMaybe (mi_module iface) loc+            mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details)+            let hm_linkable = HomeModLinkable mb_bytecode mb_object+            return (HomeModInfo iface details hm_linkable)++    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)+    executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do+     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 $+             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 diag_wrapper 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+++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.+          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+          -> IO [HomeModInfo]+rehydrate hsc_env hmis = do+  debugTraceMsg logger 2 $ (+     text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis)))+  -- When the HPT was pure we had to tie a knot to update the ModDetails in the+  -- HPT required to update those ModDetails, but since it was made an IORef we+  -- just have to make sure the new ModDetails are "reset" so that the new+  -- modules are looked up in HPT when it is forced. If we didn't "reset" the+  -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions+  -- (as explained in Note [Rehydrating Modules]).+  mds <- initIfaceCheck (text "rehydrate") hsc_env $+            mapM (typecheckIface . hm_iface) hmis+  let new_mods = [ hmi{ hm_details = details }+                 | (hmi,details) <- zip hmis mds+                 ]+  return new_mods++  where+    logger = hsc_logger hsc_env++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mni (Just mns) = do+  knot_var <- initialise_knot_var hsc_env+  let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }+  hmis <- mapM (fmap expectJust . lookupHpt (hsc_HPT hsc_env')) mns+  hmis' <- rehydrate hsc_env' hmis+  mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi (hsc_HUG hsc_env')) hmis'+  return hsc_env'++  where+   initialise_knot_var hsc_env = liftIO $+    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)+    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++rehydrateAfter :: HscEnv+  -> [ModuleName]+  -> IO [HomeModInfo]+rehydrateAfter hsc mns = do+  let hpt = hsc_HPT hsc+  hmis <- mapM (fmap expectJust . lookupHpt hpt) mns+  rehydrate (hsc { hsc_type_env_vars = emptyKnotVars }) hmis++{-+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+that 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_FC 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 ()++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+  res <- lift $ waitResult (resultVar x)+  hmis <- wait_deps xs+  case res of+    Nothing -> return hmis+    Just hmi -> return (hmi:hmis)+++{- 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? dontLeakTheHUG 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.+-}
+ GHC/Driver/MakeAction.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE CPP #-}+module GHC.Driver.MakeAction+  ( MakeAction(..)+  , MakeEnv(..)+  , RunMakeM+  -- * Running the pipelines+  , runAllPipelines+  , runParPipelines+  , runSeqPipelines+  , runPipelines+  -- * Worker limit+  , WorkerLimit(..)+  , mkWorkerLimit+  , runWorkerLimit+  -- * Utility+  , withLoggerHsc+  , withParLog+  , withLocalTmpFS+  , withLocalTmpFSMake+  ) where++import GHC.Prelude+import GHC.Driver.DynFlags++import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import GHC.Driver.Messager+import GHC.Driver.MakeSem++import GHC.Utils.Logger+import GHC.Utils.TmpFs++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe++-- Executing the pipelines++mkWorkerLimit :: DynFlags -> IO WorkerLimit+mkWorkerLimit dflags =+  case parMakeCount dflags of+    Nothing -> pure $ num_procs 1+    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))+    Just ParMakeNumProcessors -> num_procs <$> getNumProcessors+    Just (ParMakeThisMany n) -> pure $ num_procs n+  where+    num_procs x = NumProcessorsLimit (max 1 x)++isWorkerLimitSequential :: WorkerLimit -> Bool+isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1+isWorkerLimitSequential (JSemLimit {})         = False++-- | This describes what we use to limit the number of jobs, either we limit it+-- ourselves to a specific number or we have an external parallelism semaphore+-- limit it for us.+data WorkerLimit+  = NumProcessorsLimit Int+  | JSemLimit+    SemaphoreName+      -- ^ Semaphore name to use+  deriving Eq++-- | 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)+                       , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic+                       }+++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name+++runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do+  liftIO $ label_self "main --make thread"+  case n_job of+    NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines+    _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =+  let env = MakeEnv { hsc_env = plugin_hsc_env+                    , withLogger = \_ k -> k id+                    , compile_sem = AbstractSem (return ()) (return ())+                    , env_messager = mHscMessager+                    , diag_wrapper = diag_wrapper+                    }+  in runAllPipelines (NumProcessorsLimit 1) env all_pipelines++runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a+runNjobsAbstractSem n_jobs action = do+  compile_sem <- newQSem n_jobs+  n_capabilities <- getNumCapabilities+  n_cpus <- getNumProcessors+  let+    asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)+    set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n+    updNumCapabilities =  do+      -- Setting number of capabilities more than+      -- CPU count usually leads to high userspace+      -- lock contention. #9221+      set_num_caps $ min n_jobs n_cpus+    resetNumCapabilities = set_num_caps n_capabilities+  MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem++runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a+#if defined(wasm32_HOST_ARCH)+runWorkerLimit _ action = do+  lock <- newMVar ()+  action $ AbstractSem (takeMVar lock) (putMVar lock ())+#else+runWorkerLimit worker_limit action = case worker_limit of+    NumProcessorsLimit n_jobs ->+      runNjobsAbstractSem n_jobs action+    JSemLimit sem ->+      runJSemAbstractSem sem action+#endif++-- | Build and run a pipeline+runParPipelines :: WorkerLimit -- ^ How to limit work parallelism+             -> HscEnv         -- ^ The basic HscEnv which is augmented with specific info for each module+             -> (GhcMessage -> AnyGhcDiagnostic)+             -> Maybe Messager   -- ^ Optional custom messager to use to report progress+             -> [MakeAction]  -- ^ The build plan for all the module nodes+             -> IO ()+runParPipelines worker_limit plugin_hsc_env diag_wrapper 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 (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 }++  runWorkerLimit worker_limit $ \abstract_sem -> do+    let env = MakeEnv { hsc_env = thread_safe_hsc_env+                      , withLogger = withParLog log_queue_queue_var+                      , compile_sem = abstract_sem+                      , env_messager = mHscMessager+                      , diag_wrapper = diag_wrapper+                      }+    -- Reset the number of capabilities once the upsweep ends.+    runAllPipelines worker_limit env all_pipelines+    atomically $ writeTVar stopped_var True+    wait_log_thread++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'++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)))++withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a+withLocalTmpFS tmpfs act = do+  let initialiser = do+        liftIO $ forkTmpFsFrom tmpfs+      finaliser tmpfs_local = do+        liftIO $ mergeTmpFsInto tmpfs_local tmpfs+       -- 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 act++withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a+withLocalTmpFSMake env k =+  withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs+    -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})+++-- | Run the given actions and then wait for them all to finish.+runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()+runAllPipelines worker_limit env acts = do+  let single_worker = isWorkerLimitSequential worker_limit+      spawn_actions :: IO [ThreadId]+      spawn_actions = if single_worker+        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++  -- withLocalTmpFs has to occur outside of fork to remain deterministic+  new_thread <- withLocalTmpFSMake env $ \lcl_env ->+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline lcl_env 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 :: MakeEnv -> RunMakeM a -> IO (Maybe a)+      run_pipeline env p = runMaybeT (runReaderT p env)++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))++waitMakeAction :: MakeAction -> IO ()+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
+ GHC/Driver/MakeFile.hs view
@@ -0,0 +1,480 @@+++-----------------------------------------------------------------------------+--+-- Makefile Dependency Generation+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GHC.Driver.MakeFile+   ( doMkDependHS+   , doMkDependModuleGraph+   )+where++import GHC.Prelude++import qualified GHC+import GHC.Driver.Make+import GHC.Driver.Monad+import GHC.Driver.DynFlags+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.Data.OsPath (unsafeDecodeUtf)+import GHC.Utils.Outputable+import GHC.Utils.Panic+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+import GHC.Iface.Errors.Types+import Data.Either++-----------------------------------------------------------------+--+--              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 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++    -- 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 -}+    doMkDependModuleGraph dflags module_graph++++doMkDependModuleGraph :: GhcMonad m =>  DynFlags -> ModuleGraph -> m ()+doMkDependModuleGraph dflags module_graph = do+    logger <- getLogger+    tmpfs <- hsc_tmpfs <$> getSession+    let excl_mods = depExcludeMods dflags++    files <- liftIO $ beginMkDependHS logger tmpfs dflags+    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 _ _ _ _ _ (CyclicSCC nodes)+  =     -- There shouldn't be any cycles; report them+    throwOneError $ cyclicModuleErr nodes++processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))+  =     -- There shouldn't be any backpack instantiations; report them as well+    throwOneError $+      mkPlainErrorMsgEnvelope noSrcSpan $+      GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node++processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()+processDeps _dflags _ _ _ _ (AcyclicSCC (UnitNode {})) = return ()+processDeps _ _ _ _ _ (AcyclicSCC (ModuleNode _ (ModuleNodeFixed {})))+  -- No dependencies needed for fixed modules (already compiled)+  = return ()+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleNodeCompile 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     = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath 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+                    | (_lvl, mb_pkg, L loc mod) <- idecls,+                      mod `notElem` excl_mods ]++        ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (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 <- findImportedModuleWithIsBoot hsc_env imp is_boot 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 (ml_hi_file loc))++        -- Not in this package: we don't need a dependency+        | otherwise+        -> return Nothing++    fail ->+        throwOneError $+          mkPlainErrorMsgEnvelope srcloc $+          GhcDriverMessage $ DriverInterfaceError $+             (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot))++-----------------------------+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_keys :: [NodeKey]  -- The modules in this cycle+    cycle_keys = map mkNodeKey summaries++    pp_group :: SCC ModuleGraphNode -> SDoc+    pp_group (AcyclicSCC (ModuleNode deps m)) = pp_mod deps m+    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_mod loop_deps loop_breaker $$ vcat (map pp_group groups)+        where+          (boot_only, others) = partitionEithers (map is_boot_only mss)+          is_boot_key (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True+          is_boot_key _ = False+          is_boot_only n@(ModuleNode deps ms) =+            let dep_mods = map edgeTargetKey deps+                non_boot_deps = filter (not . is_boot_key) dep_mods+            in if not (any in_group non_boot_deps)+                then Left (deps, ms)+                else Right n+          is_boot_only n = Right n+          in_group m = m `elem` group_mods+          group_mods = map mkNodeKey mss++          (loop_deps, loop_breaker) =  head boot_only+          all_others   = tail (map (uncurry ModuleNode) boot_only) ++ others+          groups =+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing++    pp_mod :: [ModuleNodeEdge] -> ModuleNodeInfo -> SDoc+    pp_mod deps mn =+      text mod_str <> text (take (20 - length mod_str) (repeat ' ')) <> ppr_deps (map edgeTargetKey deps)+      where+        mod_str = moduleNameString (moduleNodeInfoModuleName mn)++    ppr_deps :: [NodeKey] -> SDoc+    ppr_deps [] = empty+    ppr_deps deps =+      let is_mod_dep (NodeKey_Module {}) = True+          is_mod_dep _ = False++          is_boot_dep (NodeKey_Module (ModNodeKeyWithUid (GWIB _ IsBoot) _)) = True+          is_boot_dep _ = False++          cycle_deps = filter (`elem` cycle_keys) deps+          (mod_deps, other_deps) = partition is_mod_dep cycle_deps+          (boot_deps, normal_deps) = partition is_boot_dep mod_deps+      in vcat [+           if null normal_deps then empty+           else text "imports" <+> pprWithCommas ppr normal_deps,+           if null boot_deps then empty+           else text "{-# SOURCE #-} imports" <+> pprWithCommas ppr boot_deps,+           if null other_deps then empty+           else text "depends on" <+> pprWithCommas ppr other_deps+         ]++-----------------------------------------------------------------+--+--              Flags+--+-----------------------------------------------------------------++depStartMarker, depEndMarker :: String+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
+ GHC/Driver/MakeSem.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NumericUnderscores #-}++-- | Implementation of a jobserver using system semaphores.+--+--+module GHC.Driver.MakeSem+  ( -- * JSem: parallelism semaphore backed+    -- by a system semaphore (Posix/Windows)+    runJSemAbstractSem++  -- * System semaphores+  , Semaphore, SemaphoreName(..)++  -- * Abstract semaphores+  , AbstractSem(..)+  , withAbstractSem+  )+  where++import GHC.Prelude+import GHC.Conc+import GHC.Data.OrdList+import GHC.IO.Exception+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Json++import System.Semaphore++import Control.Monad+import qualified Control.Monad.Catch as MC+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Data.Foldable+import Data.Functor+import GHC.Stack+import Debug.Trace++---------------------------------------+-- Semaphore jobserver++-- | A jobserver based off a system 'Semaphore'.+--+-- Keeps track of the pending jobs and resources+-- available from the semaphore.+data Jobserver+  = Jobserver+  { jSemaphore :: !Semaphore+    -- ^ The semaphore which controls available resources+  , jobs :: !(TVar JobResources)+    -- ^ The currently pending jobs, and the resources+    -- obtained from the semaphore+  }++data JobserverOptions+  = JobserverOptions+  { releaseDebounce    :: !Int+     -- ^ Minimum delay, in milliseconds, between acquiring a token+     -- and releasing a token.+  , setNumCapsDebounce :: !Int+    -- ^ Minimum delay, in milliseconds, between two consecutive+    -- calls of 'setNumCapabilities'.+  }++defaultJobserverOptions :: JobserverOptions+defaultJobserverOptions =+  JobserverOptions+    { releaseDebounce    = 1000 -- 1 second+    , setNumCapsDebounce = 1000 -- 1 second+    }++-- | Resources available for running jobs, i.e.+-- tokens obtained from the parallelism semaphore.+data JobResources+  = Jobs+  { tokensOwned :: !Int+    -- ^ How many tokens have been claimed from the semaphore+  , tokensFree  :: !Int+    -- ^ How many tokens are not currently being used+  , jobsWaiting :: !(OrdList (TMVar ()))+    -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into+    -- the TMVar will allow the job to continue.+  }++instance Outputable JobResources where+  ppr Jobs{..}+    = text "JobResources" <+>+        ( braces $ hsep+          [ text "owned=" <> ppr tokensOwned+          , text "free=" <> ppr tokensFree+          , text "num_waiting=" <> ppr (length jobsWaiting)+          ] )++-- | Add one new token.+addToken :: JobResources -> JobResources+addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })+  = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }++-- | Free one token.+addFreeToken :: JobResources -> JobResources+addFreeToken jobs@( Jobs { tokensFree = free })+  = assertPpr (tokensOwned jobs > free)+      (text "addFreeToken:" <+> ppr (tokensOwned jobs) <+> ppr free)+  $ jobs { tokensFree = free + 1 }++-- | Use up one token.+removeFreeToken :: JobResources -> JobResources+removeFreeToken jobs@( Jobs { tokensFree = free })+  = assertPpr (free > 0)+      (text "removeFreeToken:" <+> ppr free)+  $ jobs { tokensFree = free - 1 }++-- | Return one owned token.+removeOwnedToken :: JobResources -> JobResources+removeOwnedToken jobs@( Jobs { tokensOwned = owned })+  = assertPpr (owned > 1)+      (text "removeOwnedToken:" <+> ppr owned)+  $ jobs { tokensOwned = owned - 1 }++-- | Add one new job to the end of the list of pending jobs.+addJob :: TMVar () -> JobResources -> JobResources+addJob job jobs@( Jobs { jobsWaiting = wait })+  = jobs { jobsWaiting = wait `SnocOL` job }++-- | The state of the semaphore job server.+data JobserverState+  = JobserverState+    { jobserverAction  :: !JobserverAction+      -- ^ The current action being performed by the+      -- job server.+    , canChangeNumCaps :: !(TVar Bool)+      -- ^ A TVar that signals whether it has been long+      -- enough since we last changed 'numCapabilities'.+    , canReleaseToken  :: !(TVar Bool)+      -- ^ A TVar that signals whether we last acquired+      -- a token long enough ago that we can now release+      -- a token.+    }+data JobserverAction+  -- | The jobserver is idle: no thread is currently+  -- interacting with the semaphore.+  = Idle+  -- | A thread is waiting for a token on the semaphore.+  | Acquiring+    { activeWaitId   :: WaitId+    , threadFinished :: TMVar (Maybe MC.SomeException) }++-- | Retrieve the 'TMVar' that signals if the current thread has finished,+-- if any thread is currently active in the jobserver.+activeThread_maybe :: JobserverAction -> Maybe (TMVar (Maybe MC.SomeException))+activeThread_maybe Idle                                   = Nothing+activeThread_maybe (Acquiring { threadFinished = tmvar }) = Just tmvar++-- | Whether we should try to acquire a new token from the semaphore:+-- there is a pending job and no free tokens.+guardAcquire :: JobResources -> Bool+guardAcquire ( Jobs { tokensFree, jobsWaiting } )+  = tokensFree == 0 && not (null jobsWaiting)++-- | Whether we should release a token from the semaphore:+-- there are no pending jobs and we can release a token.+guardRelease :: JobResources -> Bool+guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } )+  = null jobsWaiting && tokensFree > 0 && tokensOwned > 1++---------------------------------------+-- Semaphore jobserver implementation++-- | Add one pending job to the jobserver.+--+-- Blocks, waiting on the jobserver to supply a free token.+acquireJob :: TVar JobResources -> IO ()+acquireJob jobs_tvar = do+  (job_tmvar, _jobs0) <- tracedAtomically "acquire" $+    modifyJobResources jobs_tvar \ jobs -> do+      job_tmvar <- newEmptyTMVar+      return ((job_tmvar, jobs), addJob job_tmvar jobs)+  atomically $ takeTMVar job_tmvar++-- | Signal to the job server that one job has completed,+-- releasing its corresponding token.+releaseJob :: TVar JobResources -> IO ()+releaseJob jobs_tvar = do+  tracedAtomically "release" do+    modifyJobResources jobs_tvar \ jobs -> do+      massertPpr (tokensFree jobs < tokensOwned jobs)+        (text "releaseJob: more free jobs than owned jobs!")+      return ((), addFreeToken jobs)+++-- | Release all tokens owned from the semaphore (to clean up+-- the jobserver at the end).+cleanupJobserver :: Jobserver -> IO ()+cleanupJobserver (Jobserver { jSemaphore = sem+                            , jobs       = jobs_tvar })+  = do+    Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar+    let toks_to_release = owned - 1+      -- Subtract off the implicit token: whoever spawned the ghc process+      -- in the first place is responsible for that token.+    releaseSemaphore sem toks_to_release++-- | Dispatch the available tokens acquired from the semaphore+-- to the pending jobs in the job server.+dispatchTokens :: JobResources -> STM JobResources+dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } )+  | toks_free > 0+  , next `ConsOL` rest <- wait+  -- There's a pending job and a free token:+  -- pass on the token to that job, and recur.+  = do+      putTMVar next ()+      let jobs' = jobs { tokensFree = toks_free - 1, jobsWaiting = rest }+      dispatchTokens jobs'+  | otherwise+  = return jobs++-- | Update the available resources used from a semaphore, dispatching+-- any newly acquired resources.+--+-- Invariant: if the number of available resources decreases, there+-- must be no pending jobs.+--+-- All modifications should go through this function to ensure the contents+-- of the 'TVar' remains in normal form.+modifyJobResources :: HasCallStack => TVar JobResources+                   -> (JobResources -> STM (a, JobResources))+                   -> STM (a, Maybe JobResources)+modifyJobResources jobs_tvar action = do+  old_jobs  <- readTVar jobs_tvar+  (a, jobs) <- action old_jobs++  -- Check the invariant: if the number of free tokens has decreased,+  -- there must be no pending jobs.+  massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $+    vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ]+  dispatched_jobs <- dispatchTokens jobs+  writeTVar jobs_tvar dispatched_jobs+  return (a, Just dispatched_jobs)+++tracedAtomically_ :: String -> STM (Maybe JobResources) -> IO ()+tracedAtomically_ s act = tracedAtomically s (((),) <$> act)++tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a+tracedAtomically origin act = do+  (a, mjr) <- atomically act+  forM_ mjr $ \ jr -> do+    -- Use the "jsem:" prefix to identify where the write traces are+    traceEventIO ("jsem:" ++ renderJobResources origin jr)+  return a++renderJobResources :: String -> JobResources -> String+renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $+  JSObject [ ("name", JSString origin)+           , ("owned", JSInt own)+           , ("free", JSInt free)+           , ("pending", JSInt (length pending) )+           ]+++-- | Spawn a new thread that waits on the semaphore in order to acquire+-- an additional token.+acquireThread :: Jobserver -> IO JobserverAction+acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do+    threadFinished_tmvar <- newEmptyTMVarIO+    let+      wait_result_action :: Either MC.SomeException Bool -> IO ()+      wait_result_action wait_res =+        tracedAtomically_ "acquire_thread" do+          (r, jb) <- case wait_res of+            Left (e :: MC.SomeException) -> do+              return $ (Just e, Nothing)+            Right success -> do+              if success+                then do+                  modifyJobResources jobs_tvar \ jobs ->+                    return (Nothing, addToken jobs)+                else+                  return (Nothing, Nothing)+          putTMVar threadFinished_tmvar r+          return jb+    wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action+    labelThread (waitingThreadId wait_id) "acquire_thread"+    return $ Acquiring { activeWaitId   = wait_id+                       , threadFinished = threadFinished_tmvar }++-- | Spawn a thread to release ownership of one resource from the semaphore,+-- provided we have spare resources and no pending jobs.+releaseThread :: Jobserver -> IO JobserverAction+releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do+  threadFinished_tmvar <- newEmptyTMVarIO+  MC.mask_ do+    -- Pre-release the resource so that another thread doesn't take control of it+    -- just as we release the lock on the semaphore.+    still_ok_to_release+      <- tracedAtomically "pre_release" $+         modifyJobResources jobs_tvar \ jobs ->+           if guardRelease jobs+               -- TODO: should this also debounce?+           then return (True , removeOwnedToken $ removeFreeToken jobs)+           else return (False, jobs)+    if not still_ok_to_release+    then return Idle+    else do+      tid <- forkIO $ do+        x <- MC.try $ releaseSemaphore sem 1+        tracedAtomically_ "post-release" $ do+          (r, jobs) <- case x of+            Left (e :: MC.SomeException) -> do+              modifyJobResources jobs_tvar \ jobs ->+                return (Just e, addToken jobs)+            Right _ -> do+              return (Nothing, Nothing)+          putTMVar threadFinished_tmvar r+          return jobs+      labelThread tid "release_thread"+      return Idle++-- | When there are pending jobs but no free tokens,+-- spawn a thread to acquire a new token from the semaphore.+--+-- See 'acquireThread'.+tryAcquire :: JobserverOptions+           -> Jobserver+           -> JobserverState+           -> STM (IO JobserverState)+tryAcquire opts js@( Jobserver { jobs = jobs_tvar })+  st@( JobserverState { jobserverAction = Idle } )+  = do+    jobs <- readTVar jobs_tvar+    guard $ guardAcquire jobs+    return do+      action           <- acquireThread js+      -- Set a debounce after acquiring a token.+      can_release_tvar <- registerDelay $ (releaseDebounce opts * 1000)+      return $ st { jobserverAction = action+                  , canReleaseToken = can_release_tvar }+tryAcquire _ _ _ = retry++-- | When there are free tokens and no pending jobs,+-- spawn a thread to release a token from the semaphore.+--+-- See 'releaseThread'.+tryRelease :: Jobserver+           -> JobserverState+           -> STM (IO JobserverState)+tryRelease sjs@( Jobserver { jobs = jobs_tvar } )+  st@( JobserverState+      { jobserverAction = Idle+      , canReleaseToken = can_release_tvar } )+  = do+    jobs <- readTVar jobs_tvar+    guard  $ guardRelease jobs+    can_release <- readTVar can_release_tvar+    guard can_release+    return do+      action <- releaseThread sjs+      return $ st { jobserverAction = action }+tryRelease _ _ = retry++-- | Wait for an active thread to finish. Once it finishes:+--+--  - set the 'JobserverAction' to 'Idle',+--  - update the number of capabilities to reflect the number+--    of owned tokens from the semaphore.+tryNoticeIdle :: JobserverOptions+              -> TVar JobResources+              -> JobserverState+              -> STM (IO JobserverState)+tryNoticeIdle opts jobs_tvar jobserver_state+  | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state+  = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar+  | otherwise+  = retry -- no active thread: wait until jobserver isn't idle+  where+    sync_num_caps :: TVar Bool+                  -> TMVar (Maybe MC.SomeException)+                  -> STM (IO JobserverState)+    sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do+      mb_ex <- takeTMVar threadFinished_tmvar+      for_ mb_ex MC.throwM+      Jobs { tokensOwned } <- readTVar jobs_tvar+      can_change_numcaps <- readTVar can_change_numcaps_tvar+      guard can_change_numcaps+      return do+        x <- getNumCapabilities+        can_change_numcaps_tvar_2 <-+          if x == tokensOwned+          then return can_change_numcaps_tvar+          else do+            setNumCapabilities tokensOwned+            registerDelay $ (setNumCapsDebounce opts * 1000)+        return $+          jobserver_state+            { jobserverAction  = Idle+            , canChangeNumCaps = can_change_numcaps_tvar_2 }++-- | Try to stop the current thread which is acquiring/releasing resources+-- if that operation is no longer relevant.+tryStopThread :: TVar JobResources+              -> JobserverState+              -> STM (IO JobserverState)+tryStopThread jobs_tvar jsj = do+  case jobserverAction jsj of+    Acquiring { activeWaitId = wait_id } -> do+     jobs <- readTVar jobs_tvar+     guard $ null (jobsWaiting jobs)+     return do+       interruptWaitOnSemaphore wait_id+       return $ jsj { jobserverAction = Idle }+    _ -> retry++-- | Main jobserver loop: acquire/release resources as+-- needed for the pending jobs and available semaphore tokens.+jobserverLoop :: JobserverOptions -> Jobserver -> IO ()+jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })+  = do+      true_tvar <- newTVarIO True+      let init_state :: JobserverState+          init_state =+            JobserverState+              { jobserverAction  = Idle+              , canChangeNumCaps = true_tvar+              , canReleaseToken  = true_tvar }+      loop init_state+  where+    loop s = do+      action <- atomically $ asum $ (\x -> x s) <$>+        [ tryRelease    sjs+        , tryAcquire    opts sjs+        , tryNoticeIdle opts jobs_tvar+        , tryStopThread jobs_tvar+        ]+      s <- action+      loop s++-- | Create a new jobserver using the given semaphore handle.+makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())+makeJobserver sem_name = do+  semaphore <- openSemaphore sem_name+  let+    init_jobs =+      Jobs { tokensOwned = 1+           , tokensFree  = 1+           , jobsWaiting = NilOL+           }+  jobs_tvar <- newTVarIO init_jobs+  let+    opts = defaultJobserverOptions -- TODO: allow this to be configured+    sjs = Jobserver { jSemaphore = semaphore+                    , jobs       = jobs_tvar }+  loop_finished_mvar <- newEmptyMVar+  loop_tid <- forkIOWithUnmask \ unmask -> do+    r <- try $ unmask $ jobserverLoop opts sjs+    putMVar loop_finished_mvar $+      case r of+        Left e+          | Just ThreadKilled <- fromException e+          -> Nothing+          | otherwise+          -> Just e+        Right () -> Nothing+  labelThread loop_tid "job_server"+  let+    acquireSem = acquireJob jobs_tvar+    releaseSem = releaseJob jobs_tvar+    cleanupSem = do+      -- this is interruptible+      cleanupJobserver sjs+      killThread loop_tid+      mb_ex <- takeMVar loop_finished_mvar+      for_ mb_ex MC.throwM++  return (AbstractSem{..}, cleanupSem)++-- | Implement an abstract semaphore using a semaphore 'Jobserver'+-- which queries the system semaphore of the given name for resources.+runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use+                   -> (AbstractSem -> IO a) -- ^ the operation to run+                                            -- which requires a semaphore+                   -> IO a+runJSemAbstractSem sem action = MC.mask \ unmask -> do+  (abs, cleanup) <- makeJobserver sem+  r <- try $ unmask $ action abs+  case r of+    Left (e1 :: MC.SomeException) -> do+      (_ :: Either MC.SomeException ()) <- MC.try cleanup+      MC.throwM e1+    Right x -> cleanup $> x++{- Note [Architecture of the Job Server]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `-jsem` mode, the amount of parallelism that GHC can use is controlled by a+system semaphore. We take resources from the semaphore when we need them, and+give them back if we don't have enough to do.++A naive implementation would just take and release the semaphore around performing+the action, but this leads to two issues:++* When taking a token in the semaphore, we must call `setNumCapabilities` in order+  to adjust how many capabilities are available for parallel garbage collection.+  This causes unnecessary synchronisations.+* We want to implement a debounce, so that whilst there is pending work in the+  current process we prefer to keep hold of resources from the semaphore.+  This reduces overall memory usage, as there are fewer live GHC processes at once.++Therefore, the obtention of semaphore resources is separated away from the+request for the resource in the driver.++A token from the semaphore is requested using `acquireJob`. This creates a pending+job, which is a MVar that can be filled in to signal that the requested token is ready.++When the job is finished, the token is released by calling `releaseJob`, which just+increases the number of `free` jobs. If there are more pending jobs when the free count+is increased, the token is immediately reused (see `modifyJobResources`).++The `jobServerLoop` interacts with the system semaphore: when there are pending+jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a+token is obtained, it increases the owned count.++When GHC has free tokens (tokens from the semaphore that it is not using),+no pending jobs, and the debounce has expired, then `releaseThread` will+release tokens back to the global semaphore.++`tryStopThread` attempts to kill threads which are waiting to acquire a resource+when we no longer need it. For example, consider that we attempt to acquire two+tokens, but the first job finishes before we acquire the second token.+This second token is no longer needed, so we should cancel the wait+(as it would not be used to do any work, and not be returned until the debounce).+We only need to kill `acquireJob`, because `releaseJob` never blocks.++Note [Eventlog Messages for jsem]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be tricky to verify that the work is shared adequately across different+processes. To help debug this, we output the values of `JobResource` to the+eventlog whenever the global state changes. There are some scripts which can be used+to analyse this output and report statistics about core saturation in the+GitHub repo (https://github.com/mpickering/ghc-jsem-analyse).++-}
+ GHC/Driver/Messager.hs view
@@ -0,0 +1,66 @@+module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where++import GHC.Prelude+import GHC.Driver.Env+import GHC.Unit.Module.Graph+import GHC.Iface.Recomp+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Unit.State++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++--------------------------------------------------------------+-- 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 (mgNodeUnitId 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"+                    UnitNode {} -> "Loading"+        hsc_env = hscSetActiveUnitId (mgNodeUnitId 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++{- **********************************************************************+%*                                                                      *+        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
+ GHC/Driver/Monad.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DerivingVia, NoPolyKinds #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2010+--+-- The Session type and related functionality+--+-- -----------------------------------------------------------------------------++module GHC.Driver.Monad (+        -- * 'Ghc' monad stuff+        GhcMonad(..),+        Ghc(..),+        GhcT(..), liftGhcT,+        reflectGhc, reifyGhc,+        getSessionDynFlags,+        liftIO,+        Session(..), withSession, modifySession, modifySessionM,+        withTempSession,++        -- * Logger+        modifyLogger,+        pushLogHookM,+        popLogHookM,+        pushJsonLogHookM,+        popJsonLogHookM,+        putLogMsgM,+        putMsgM,+        withTimingM,++        -- ** Diagnostics+        logDiagnostics, printException,+        WarnErrLogger, defaultWarnErrLogger+  ) where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Driver.Env+import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages )+import GHC.Driver.Errors.Types+import GHC.Driver.Config.Diagnostic++import GHC.Utils.Monad+import GHC.Utils.Exception+import GHC.Utils.Error+import GHC.Utils.Logger++import GHC.Types.SrcLoc+import GHC.Types.SourceError++import Control.Monad+import Control.Monad.Catch as MC+import Control.Monad.Trans.Reader+import Data.IORef++-- -----------------------------------------------------------------------------+-- | A monad that has all the features needed by GHC API calls.+--+-- In short, a GHC monad+--+--   - allows embedding of IO actions,+--+--   - can log warnings,+--+--   - allows handling of (extensible) exceptions, and+--+--   - maintains a current session.+--+-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'+-- before any call to the GHC API functions can occur.+--+class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where+  getSession :: m HscEnv+  setSession :: HscEnv -> m ()++-- | Call the argument with the current session.+withSession :: GhcMonad m => (HscEnv -> m a) -> m a+withSession f = getSession >>= f++-- | Grabs the DynFlags from the Session+getSessionDynFlags :: GhcMonad m => m DynFlags+getSessionDynFlags = withSession (return . hsc_dflags)++-- | Set the current session to the result of applying the current session to+-- the argument.+modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()+modifySession f = do h <- getSession+                     setSession $! f h++-- | Set the current session to the result of applying the current session to+-- the argument.+modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()+modifySessionM f = do h <- getSession+                      h' <- f h+                      setSession $! h'++withSavedSession :: GhcMonad m => m a -> m a+withSavedSession m = do+  saved_session <- getSession+  m `MC.finally` setSession saved_session++-- | Call an action with a temporarily modified Session.+withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a+withTempSession f m =+  withSavedSession $ modifySession f >> m++----------------------------------------+-- Logging+----------------------------------------++-- | Modify the logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+modifyLogger f = modifySession $ \hsc_env ->+    hsc_env { hsc_logger = f (hsc_logger hsc_env) }++-- | Push a log hook on the stack+pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()+pushLogHookM = modifyLogger . pushLogHook++-- | Pop a log hook from the stack+popLogHookM :: GhcMonad m => m ()+popLogHookM  = modifyLogger popLogHook++pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()+pushJsonLogHookM = modifyLogger . pushJsonLogHook++popJsonLogHookM :: GhcMonad m => m ()+popJsonLogHookM = modifyLogger popJsonLogHook++-- | Put a log message+putMsgM :: GhcMonad m => SDoc -> m ()+putMsgM doc = do+    logger <- getLogger+    liftIO $ putMsg logger doc++-- | Put a log message+putLogMsgM :: GhcMonad m => MessageClass -> SrcSpan -> SDoc -> m ()+putLogMsgM msg_class loc doc = do+    logger <- getLogger+    liftIO $ logMsg logger msg_class loc doc++-- | Time an action+withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b+withTimingM doc force action = do+    logger <- getLogger+    withTiming logger doc force action++-- -----------------------------------------------------------------------------+-- | A monad that allows logging of diagnostics.++logDiagnostics :: GhcMonad m => Messages GhcMessage -> m ()+logDiagnostics warns = do+  dflags <- getSessionDynFlags+  logger <- getLogger+  let !diag_opts = initDiagOpts dflags+      !print_config = initPrintConfig dflags+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts warns++-- -----------------------------------------------------------------------------+-- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,+-- e.g., to maintain additional state consider wrapping this monad or using+-- 'GhcT'.+newtype Ghc a = Ghc { unGhc :: Session -> IO a }+  deriving stock (Functor)+  deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session IO)++-- | The Session is a handle to the complete state of a compilation+-- session.  A compilation session consists of a set of modules+-- constituting the current program or library, the context for+-- interactive evaluation, and various caches.+data Session = Session !(IORef HscEnv)++instance HasDynFlags Ghc where+  getDynFlags = getSessionDynFlags++instance HasLogger Ghc where+  getLogger = hsc_logger <$> getSession++instance GhcMonad Ghc where+  getSession = Ghc $ \(Session r) -> readIORef r+  setSession s' = Ghc $ \(Session r) -> writeIORef r s'++-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.+--+-- You can use this to call functions returning an action in the 'Ghc' monad+-- inside an 'IO' action.  This is needed for some (too restrictive) callback+-- arguments of some library functions:+--+-- > libFunc :: String -> (Int -> IO a) -> IO a+-- > ghcFunc :: Int -> Ghc a+-- >+-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a+-- > ghcFuncUsingLibFunc str =+-- >   reifyGhc $ \s ->+-- >     libFunc $ \i -> do+-- >       reflectGhc (ghcFunc i) s+--+reflectGhc :: Ghc a -> Session -> IO a+reflectGhc m = unGhc m++-- > Dual to 'reflectGhc'.  See its documentation.+reifyGhc :: (Session -> IO a) -> Ghc a+reifyGhc act = Ghc $ act++-- -----------------------------------------------------------------------------+-- | A monad transformer to add GHC specific features to another monad.+--+-- Note that the wrapped monad must support IO and handling of exceptions.+newtype GhcT m a = GhcT { unGhcT :: Session -> m a }+  deriving stock (Functor)+  deriving (Applicative, Monad, MonadFail, MonadFix, MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT Session m)++liftGhcT :: m a -> GhcT m a+liftGhcT m = GhcT $ \_ -> m++instance MonadIO m => HasDynFlags (GhcT m) where+  getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)++instance MonadIO m => HasLogger (GhcT m) where+  getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r)++instance ExceptionMonad m => GhcMonad (GhcT m) where+  getSession = GhcT $ \(Session r) -> liftIO $ readIORef r+  setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'+++-- | Print the all diagnostics in a 'SourceError'.  Useful inside exception+--   handlers.+printException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()+printException err = do+  dflags <- getDynFlags+  logger <- getLogger+  let !diag_opts = initDiagOpts dflags+      !print_config = initPrintConfig dflags+  liftIO $ printMessages logger print_config diag_opts (srcErrorMessages err)++-- | A function called to log warnings and errors.+type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()++defaultWarnErrLogger :: WarnErrLogger+defaultWarnErrLogger Nothing  = return ()+defaultWarnErrLogger (Just e) = printException e
+ GHC/Driver/Phases.hs view
@@ -0,0 +1,334 @@+-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2002+--+-----------------------------------------------------------------------------++module GHC.Driver.Phases (+   Phase(..),+   happensBefore, eqPhase, isStopLn,+   startPhase,+   phaseInputExt,++   StopPhase(..),+   stopPhaseToPhase,++   isHaskellishSuffix,+   isHaskellSrcSuffix,+   isBackpackishSuffix,+   isObjectSuffix,+   isCishSuffix,+   isDynLibSuffix,+   isHaskellUserSrcSuffix,+   isHaskellSigSuffix,+   isHaskellBootSuffix,+   isSourceSuffix,++   isHaskellishTarget,++   isHaskellishFilename,+   isHaskellSrcFilename,+   isHaskellSigFilename,+   isObjectFilename,+   isCishFilename,+   isDynLibFilename,+   isHaskellUserSrcFilename,+   isSourceFilename,++   phaseForeignLanguage+ ) where++import GHC.Prelude++import GHC.Platform++import GHC.ForeignSrcLang++import GHC.Types.SourceFile++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import System.FilePath++-----------------------------------------------------------------------------+-- Phases++{-+   Phase of the           | Suffix saying | Flag saying   | (suffix of)+   compilation system     | ``start here''| ``stop after''| output file++   literate pre-processor | .lhs          | -             | -+   C pre-processor (opt.) | -             | -E            | -+   Haskell compiler       | .hs           | -C, -S        | .hc, .s+   C compiler (opt.)      | .hc or .c     | -S            | .s+   assembler              | .s  or .S     | -c            | .o+   linker                 | other         | -             | a.out+   linker (merge objects) | other         | -             | .o+-}++-- Phases we can actually stop after+data StopPhase = StopPreprocess -- ^ @-E@+               | StopC          -- ^ @-C@+               | StopAs         -- ^ @-S@+               | NoStop         -- ^ @-c@++stopPhaseToPhase :: StopPhase -> Phase+stopPhaseToPhase StopPreprocess = anyHsc+stopPhaseToPhase StopC          = HCc+stopPhaseToPhase StopAs         = As False+stopPhaseToPhase NoStop         = StopLn++-- | Untyped Phase description+data Phase+        = Unlit HscSource+        | Cpp   HscSource+        | HsPp  HscSource+        | Hsc   HscSource+        | Ccxx          -- Compile C+++        | Cc            -- Compile C+        | Cobjc         -- Compile Objective-C+        | Cobjcxx       -- Compile Objective-C+++        | HCc           -- Haskellised C (as opposed to vanilla C) compilation+        | As Bool       -- Assembler for regular assembly files (Bool: with-cpp)+        | LlvmOpt       -- Run LLVM opt tool over llvm assembly+        | LlvmLlc       -- LLVM bitcode to native assembly+        | LlvmMangle    -- Fix up TNTC by processing assembly produced by LLVM+        | CmmCpp        -- pre-process Cmm source+        | Cmm           -- parse & compile Cmm code+        | MergeForeign  -- merge in the foreign object files+        | Js            -- pre-process Js source++        -- The final phase is a pseudo-phase that tells the pipeline to stop.+        | StopLn        -- Stop, but linking will follow, so generate .o file+  deriving (Eq, Show)++instance Outputable Phase where+    ppr p = text (show p)++anyHsc :: Phase+anyHsc = Hsc (panic "anyHsc")++isStopLn :: Phase -> Bool+isStopLn StopLn = True+isStopLn _      = False++eqPhase :: Phase -> Phase -> Bool+-- Equality of constructors, ignoring the HscSource field+-- NB: the HscSource field can be 'bot'; see anyHsc above+eqPhase (Unlit _)   (Unlit _)  = True+eqPhase (Cpp   _)   (Cpp   _)  = True+eqPhase (HsPp  _)   (HsPp  _)  = True+eqPhase (Hsc   _)   (Hsc   _)  = True+eqPhase Cc          Cc         = True+eqPhase Cobjc       Cobjc      = True+eqPhase HCc         HCc        = True+eqPhase (As x)      (As y)     = x == y+eqPhase LlvmOpt     LlvmOpt    = True+eqPhase LlvmLlc     LlvmLlc    = True+eqPhase LlvmMangle  LlvmMangle = True+eqPhase CmmCpp      CmmCpp     = True+eqPhase Cmm         Cmm        = True+eqPhase MergeForeign MergeForeign  = True+eqPhase StopLn      StopLn     = True+eqPhase Ccxx        Ccxx       = True+eqPhase Cobjcxx     Cobjcxx    = True+eqPhase Js          Js         = True+eqPhase _           _          = False++-- MP: happensBefore is only used in preprocessPipeline, that usage should+-- be refactored and this usage removed.+happensBefore :: Platform -> Phase -> Phase -> Bool+happensBefore platform p1 p2 = p1 `happensBefore'` p2+    where StopLn `happensBefore'` _ = False+          x      `happensBefore'` y = after_x `eqPhase` y+                                   || after_x `happensBefore'` y+              where after_x = nextPhase platform x++nextPhase :: Platform -> Phase -> Phase+nextPhase platform p+    -- A conservative approximation to the next phase, used in happensBefore+    = case p of+      Unlit sf   -> Cpp  sf+      Cpp   sf   -> HsPp sf+      HsPp  sf   -> Hsc  sf+      Hsc   _    -> maybeHCc+      LlvmOpt    -> LlvmLlc+      LlvmLlc    -> LlvmMangle+      LlvmMangle -> As False+      As _       -> MergeForeign+      Ccxx       -> MergeForeign+      Cc         -> MergeForeign+      Cobjc      -> MergeForeign+      Cobjcxx    -> MergeForeign+      CmmCpp     -> Cmm+      Cmm        -> maybeHCc+      HCc        -> MergeForeign+      MergeForeign -> StopLn+      Js         -> StopLn+      StopLn     -> panic "nextPhase: nothing after StopLn"+    where maybeHCc = if platformUnregisterised platform+                     then HCc+                     else As False++-- the first compilation phase for a given file is determined+-- by its suffix.+startPhase :: String -> Phase+startPhase "lhs"      = Unlit HsSrcFile+startPhase "lhs-boot" = Unlit HsBootFile+startPhase "lhsig"    = Unlit HsigFile+startPhase "hs"       = Cpp   HsSrcFile+startPhase "hs-boot"  = Cpp   HsBootFile+startPhase "hsig"     = Cpp   HsigFile+startPhase "hscpp"    = HsPp  HsSrcFile+startPhase "hspp"     = Hsc   HsSrcFile+startPhase "hc"       = HCc+startPhase "c"        = Cc+startPhase "cpp"      = Ccxx+startPhase "C"        = Cc+startPhase "m"        = Cobjc+startPhase "M"        = Cobjcxx+startPhase "mm"       = Cobjcxx+startPhase "cc"       = Ccxx+startPhase "cxx"      = Ccxx+startPhase "s"        = As False+startPhase "S"        = As True+startPhase "ll"       = LlvmOpt+startPhase "bc"       = LlvmLlc+startPhase "lm_s"     = LlvmMangle+startPhase "o"        = StopLn+startPhase "cmm"      = CmmCpp+startPhase "cmmcpp"   = Cmm+startPhase "js"       = Js+startPhase _          = StopLn     -- all unknown file types++-- This is used to determine the extension for the output from the+-- current phase (if it generates a new file).  The extension depends+-- on the next phase in the pipeline.+phaseInputExt :: Phase -> String+phaseInputExt (Unlit HsSrcFile)   = "lhs"+phaseInputExt (Unlit HsBootFile)  = "lhs-boot"+phaseInputExt (Unlit HsigFile)    = "lhsig"+phaseInputExt (Cpp   _)           = "lpp"       -- intermediate only+phaseInputExt (HsPp  _)           = "hscpp"     -- intermediate only+phaseInputExt (Hsc   _)           = "hspp"      -- intermediate only+        -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x+        --     because runPhase uses the StopBefore phase to pick the+        --     output filename.  That could be fixed, but watch out.+phaseInputExt HCc                 = "hc"+phaseInputExt Ccxx                = "cpp"+phaseInputExt Cobjc               = "m"+phaseInputExt Cobjcxx             = "mm"+phaseInputExt Cc                  = "c"+phaseInputExt (As True)           = "S"+phaseInputExt (As False)          = "s"+phaseInputExt LlvmOpt             = "ll"+phaseInputExt LlvmLlc             = "bc"+phaseInputExt LlvmMangle          = "lm_s"+phaseInputExt CmmCpp              = "cmmcpp"+phaseInputExt Cmm                 = "cmm"+phaseInputExt MergeForeign        = "o"+phaseInputExt Js                  = "js"+phaseInputExt StopLn              = "o"++haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,+    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes+ :: [String]+-- When a file with an extension in the haskellish_src_suffixes group is+-- loaded in --make mode, its imports will be loaded too.+haskellish_src_suffixes      = haskellish_user_src_suffixes +++                               [ "hspp", "hscpp" ]+haskellish_suffixes          = haskellish_src_suffixes +++                               [ "hc", "cmm", "cmmcpp" ]+cish_suffixes                = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ]+js_suffixes                  = [ "js" ]++-- Will not be deleted as temp files:+haskellish_user_src_suffixes =+  haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]+haskellish_boot_suffixes     = [ "hs-boot", "lhs-boot" ]+haskellish_sig_suffixes      = [ "hsig", "lhsig" ]+backpackish_suffixes         = [ "bkp" ]++objish_suffixes :: Platform -> [String]+-- Use the appropriate suffix for the system on which+-- the GHC-compiled code will run+objish_suffixes platform = case platformOS platform of+  OSMinGW32 -> [ "o", "O", "obj", "OBJ" ]+  _         -> [ "o" ]++dynlib_suffixes :: Platform -> [String]+dynlib_suffixes platform = case platformOS platform of+  OSMinGW32 -> ["dll", "DLL"]+  OSDarwin  -> ["dylib", "so"]+  _         -> ["so"]++isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,+    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix+ :: String -> Bool+isHaskellishSuffix     s = s `elem` haskellish_suffixes+isBackpackishSuffix    s = s `elem` backpackish_suffixes+isHaskellSigSuffix     s = s `elem` haskellish_sig_suffixes+isHaskellBootSuffix    s = s `elem` haskellish_boot_suffixes+isHaskellSrcSuffix     s = s `elem` haskellish_src_suffixes+isCishSuffix           s = s `elem` cish_suffixes+isJsSuffix             s = s `elem` js_suffixes+isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes++isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool+isObjectSuffix platform s = s `elem` objish_suffixes platform+isDynLibSuffix platform s = s `elem` dynlib_suffixes platform++isSourceSuffix :: String -> Bool+isSourceSuffix suff  = isHaskellishSuffix suff+                    || isCishSuffix suff+                    || isJsSuffix suff+                    || isBackpackishSuffix suff++-- | When we are given files (modified by -x arguments) we need+-- to determine if they are Haskellish or not to figure out+-- how we should try to compile it.  The rules are:+--+--      1. If no -x flag was specified, we check to see if+--         the file looks like a module name, has no extension,+--         or has a Haskell source extension.+--+--      2. If an -x flag was specified, we just make sure the+--         specified suffix is a Haskell one.+isHaskellishTarget :: (String, Maybe Phase) -> Bool+isHaskellishTarget (f,Nothing) =+  looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f)+isHaskellishTarget (_,Just phase) =+  phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js+                  , StopLn]++isHaskellishFilename, isHaskellSrcFilename, isCishFilename,+    isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename+ :: FilePath -> Bool+-- takeExtension return .foo, so we drop 1 to get rid of the .+isHaskellishFilename     f = isHaskellishSuffix     (drop 1 $ takeExtension f)+isHaskellSrcFilename     f = isHaskellSrcSuffix     (drop 1 $ takeExtension f)+isCishFilename           f = isCishSuffix           (drop 1 $ takeExtension f)+isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)+isSourceFilename         f = isSourceSuffix         (drop 1 $ takeExtension f)+isHaskellSigFilename     f = isHaskellSigSuffix     (drop 1 $ takeExtension f)++isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool+isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)+isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)++-- | Foreign language of the phase if the phase deals with a foreign code+phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang+phaseForeignLanguage phase = case phase of+  Cc           -> Just LangC+  Ccxx         -> Just LangCxx+  Cobjc        -> Just LangObjc+  Cobjcxx      -> Just LangObjcxx+  HCc          -> Just LangC+  As _         -> Just LangAsm+  MergeForeign -> Just RawObject+  Js           -> Just LangJs+  _            -> Nothing
+ GHC/Driver/Pipeline.hs view
@@ -0,0 +1,983 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+--+-- 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.Builtin.Names++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.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.Iface.Load          ( getGhcPrimIface )+import GHC.Runtime.Loader      ( initializePlugins )+++import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) )+import GHC.Types.Error       ( singleMessage, getMessages, mkSimpleUnknownDiagnostic, defaultDiagnosticOpts )+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))+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.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable++import System.Directory+import System.FilePath+import System.IO+import Control.Monad+import qualified Control.Monad.Catch as MC (handle)+import Data.Maybe+import qualified Data.Set as Set+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))++import Data.Time        ( getCurrentTime )+import GHC.Iface.Recomp+import GHC.Types.Unique.DSet++-- 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 $ mkSimpleUnknownDiagnostic $ 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]++   -- Initialise plugins here for any plugins enabled locally for a module.+   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 plugin_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 (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+     -> FinderCache+     -> 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 fc 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 fc 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+      -> FinderCache+      -> DynFlags                -- ^ dynamic flags+      -> UnitEnv                 -- ^ unit environment+      -> Bool                    -- ^ attempt linking in batch mode?+      -> Maybe (RecompileRequired -> IO ())+      -> HomePackageTable        -- ^ what to link+      -> IO SuccessFlag++link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt+   | batch_attempt_linking+   = do+        let+            staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++        -- the packages we depend on+        -- TODO: This should be a query on the 'ModuleGraph', since we need to+        -- know which packages are actually needed at the runtime stage.+        pkg_deps <- map snd . Set.toList <$> hptCollectDependencies hpt++        -- the linkables to link+        linkables <- hptCollectObjects hpt++        -- the home modules, for tracing+        home_modules <- hptCollectModules hpt++        debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map ppr home_modules))+        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 obj_files = concatMap linkableObjs 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 tmpfs fc 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 -> TmpFs -> FinderCache -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()+linkJSBinary logger tmpfs fc 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   = initJSLinkConfig dflags+  let cfg      = initStgToJSConfig dflags+  jsLinkBinary fc lc_cfg cfg logger tmpfs 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_homeUnitState 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 ]+        (errs,extra_times) <- partitionWithM (tryIO . getModificationUTCTime) extra_ld_inputs+        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.+        -- pkg_deps is just the direct dependencies so take the transitive closure here+        -- to decide if we need to relink or not.+        let pkg_hslibs acc uid+              | uid `elementOfUniqDSet` acc = acc+              | Just c <- lookupUnitId unit_state uid =+                  foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c)+              | otherwise = acc++            all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps++        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)+                          | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_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+        (lib_errs,lib_times) <- partitionWithM (tryIO . getModificationUTCTime) (catMaybes pkg_libfiles)+        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 orig_hsc_env stop_phase srcs = do+  -- In oneshot mode, initialise plugins specified on command line+  -- we also initialise in ghc/Main but this might be used as an entry point by API clients who+  -- should initialise their own plugins but may not.+  -- See Note [Timing of plugin initialization]+  hsc_env <- initializePlugins orig_hsc_env+  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+   let offset_file = augmentByWorkingDirectory dflags src+       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 offset_file mb_phase output+       pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) offset_file mb_phase++   exists <- doesFileExist offset_file+   when (not exists) $+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ offset_file))+   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+    fc       = hsc_FC       hsc_env++  case ghcLink dflags of+    NoLink        -> return ()+    LinkBinary+      | backendUseJSLinker (backend dflags)+                  -> linkJSBinary logger tmpfs fc 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 <$> foreignJsPipeline pe hsc_env ml fp+            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 <$> foreignJsPipeline 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 (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcDriverMessage <$> 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+      -- Only run dynamic-too if the backend generates object files+      -- See Note [Writing interface files]+      -- If we are writing a simple interface (not . backendWritesFiles), then+      -- hscMaybeWriteIface in the regular pipeline will write both the hi and+      -- dyn_hi files. This way we can avoid running the pipeline twice and+      -- generating a duplicate linkable.+      -- We must not run the backend a second time with `dynamicNow` enable because+      -- all the work has already been done in the first pipeline.+      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env) && backendWritesFiles (backend (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 NoStubs []) <*> pure emptyHomeModInfoLinkable++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+        part_time <- liftIO getCurrentTime+        final_object <- use (T_MergeForeign pipe_env hsc_env o_fp fos)+        let !linkable = Linkable part_time (ms_mod mod_sum) (NE.singleton (DotO final_object ModuleObject))+        -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.+        return (mlinkable { homeMod_object = Just linkable })++  -- when building ghc-internal with --make (e.g. with cabal-install), we want+  -- the virtual interface for gHC_PRIM in the cache, not the empty one.+  let miface_final+        | ms_mod mod_sum == gHC_PRIM = getGhcPrimIface (hsc_hooks hsc_env)+        | otherwise                  = miface+  return (miface_final, 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)++lasPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)+lasPipeline use_cpp pipe_env hsc_env location input_fn =+  case stop_phase pipe_env of+    StopAs -> return Nothing+    _ -> Just <$> use (T_LlvmAs 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)+  lasPipeline False pipe_env hsc_env location mangled_fn++cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe 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 (Maybe 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 -> return Nothing+    Just mo_fn -> Just <$> 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)++foreignJsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath+foreignJsPipeline pipe_env hsc_env location input_fn = do+  use (T_ForeignJs pipe_env hsc_env location input_fn)++hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+hscPostBackendPipeline _ _ (HsBootOrSig _) _ _ _ = return Nothing+hscPostBackendPipeline pipe_env hsc_env HsSrcFile 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 (Linkable _ _ (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     = cmmCppPipeline pipe_env hsc_env input_fn+   fromPhase Cmm        = cmmPipeline pipe_env hsc_env input_fn+   fromPhase Js         = Just <$> foreignJsPipeline 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.++-}
+ GHC/Driver/Pipeline.hs-boot view
@@ -0,0 +1,24 @@+module GHC.Driver.Pipeline where+++import GHC.Driver.Env.Types ( HscEnv )+import GHC.ForeignSrcLang ( ForeignSrcLang )+import GHC.Prelude (FilePath, IO, Maybe, Either)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Driver.Session (DynFlags)+import GHC.Driver.Phases (Phase)+import GHC.Driver.Errors.Types (DriverMessages)+import GHC.Types.Target (InputFileBuffer)++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 ()++preprocess :: HscEnv+           -> FilePath+           -> Maybe InputFileBuffer+           -> Maybe Phase+           -> IO (Either DriverMessages (DynFlags, FilePath))+
+ GHC/Driver/Pipeline/Execute.hs view
@@ -0,0 +1,1307 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+#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.Unit.Module.ModGuts (cg_foreign, cg_foreign_files)+import GHC.Driver.Phases+import GHC.Unit.Types+import GHC.Types.ForeignStubs (ForeignStubs (NoStubs))+import GHC.Types.SourceFile+import GHC.Unit.Module.Status+import GHC.Unit.Module.ModIface+import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.Unit.Module.ModSummary+import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.SrcLoc+import GHC.Driver.Main+import GHC.Driver.Downsweep+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 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.Data.OsPath (unsafeEncodeUtf)+import GHC.Types.SourceError+import GHC.Unit.Finder+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.Utils.Touch+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+import GHC.Runtime.Loader (initializePlugins)++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+          { sourceCodePreprocessor  = SCPCmmCpp+          , cppLinePragmas          = True+          })+        input_fn output_fn+  return output_fn+runPhase (T_Js pipe_env hsc_env location js_src) =+  runJsPhase pipe_env hsc_env location js_src+runPhase (T_ForeignJs pipe_env hsc_env location js_src) =+  runForeignJsPhase pipe_env hsc_env location 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_LlvmAs cpp pipe_env hsc_env location input_fn) = do+  runLlvmAsPhase cpp pipe_env hsc_env location 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+++-- Run either 'clang' or 'gcc' phases+runGenericAsPhase :: (Logger -> DynFlags -> [Option] -> IO ()) -> [Option] -> Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runGenericAsPhase run_as extra_opts 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 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)++        -- add package include paths+        all_includes <- if not with_cpp+          then pure []+          else do+            pkg_include_dirs <- mayThrowUnitErr (collectIncludeDirs <$> preloadUnitsInfo unit_env)+            let global_includes = [ GHC.SysTools.Option ("-I" ++ p)+                                  | p <- includePathsGlobal cmdline_include_paths ++ pkg_include_dirs]+            let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)+                                 | p <- includePathsQuote cmdline_include_paths ++ includePathsQuoteImplicit cmdline_include_paths]+            pure (local_includes ++ global_includes)+        let runAssembler inputFilename outputFilename+              = withAtomicRename outputFilename $ \temp_outputFilename ->+                    run_as+                       logger dflags+                       (all_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]++                       ++ [ 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+                          ] ++ extra_opts)++        debugTraceMsg logger 4 (text "Running the assembler")+        runAssembler input_fn output_fn++        return output_fn++-- Invoke `clang` to assemble a .S file produced by LLvm toolchain+runLlvmAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runLlvmAsPhase =+  runGenericAsPhase runLlvmAs [ GHC.SysTools.Option "-Wno-unused-command-line-argument" ]++-- Invoke 'gcc' to assemble a .S file+runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runAsPhase =+  runGenericAsPhase runAs []++++-- 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 -> Maybe ModLocation -> FilePath -> IO FilePath+runJsPhase _pipe_env _hsc_env _location input_fn = do+  -- The object file is already generated. We only touch it to ensure the+  -- timestamp is refreshed, see Note [JS Backend .o file procedure].+  touchObjectFile input_fn+  return input_fn++-- | Deal with foreign JS files (embed them into .o files)+runForeignJsPhase :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runForeignJsPhase pipe_env hsc_env _location 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+  embedJsFile logger dflags tmpfs unit_env input_fn output_fn+  return output_fn++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_maybe 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++  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 <- getGhcVersionIncludeFlags 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)+                    ]++                 -- if -fsplit-sections is enabled, we should also+                 -- build with these flags.+                 ++ (if gopt Opt_SplitSections dflags &&+                      platformOS (targetPlatform dflags) /= OSDarwin+                        then ["-ffunction-sections", "-fdata-sections"]+                        else [])++          -- 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.+                 ++ (case home_unit of+                        Just hu+                          | isHomeUnitId hu ghcInternalUnitId+                          , platformOS platform == OSMinGW32+                          -> ["-DCOMPILING_GHC_INTERNAL_PACKAGE"]+                        _ -> [])++                 -- 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+                 ++ ghcVersionH+                 ++ framework_paths+                 ++ include_paths+                 ++ 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 ->+          if | not (backendGeneratesCode (backend dflags))  ->+                panic "HscUpdate not relevant for NoBackend"+             | not (backendGeneratesCodeForHsBoot (backend dflags)) -> do+                -- In Interpreter way, there is just no linkable for hs-boot files+                -- and we don't want to write an empty `o-boot` file when we're not+                -- supposed to be writing any .o files (#22669)+                return ([], iface, emptyHomeModInfoLinkable, o_file)+             | otherwise -> 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 (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 o_file+                   HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"++                 -- MP: I wonder if there are any lurking bugs here because we+                 -- return Linkable == emptyHomeModInfoLinkable, despite the fact that there is a+                 -- linkable (.o-boot) which we check for in `Iface/Recomp.hs` and+                 -- then will carry around the linkable if we're doing+                 -- recompilation.+                 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++              stub_o <- mapM (compileStub hsc_env) mStub+              foreign_os <-+                mapM (uncurry (compileForeign hsc_env)) foreign_files+              let fos = maybe [] return stub_o ++ foreign_os+                  (iface_stubs, iface_files)+                    | gopt Opt_WriteIfSimplifiedCore dflags = (cg_foreign cgguts, cg_foreign_files cgguts)+                    | otherwise = (NoStubs, [])++              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos iface_stubs iface_files++              -- See Note [Writing interface files]+              hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location+              mlinkable <-+                if 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++              -- 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 NoStubs []+              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:+       -- testsuite/tests/hpc/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, Messages DriverMessage))+getFileArgs hsc_env input_fn = do+  let dflags0 = hsc_dflags hsc_env+      logger  = hsc_logger hsc_env+      parser_opts = initParserOpts dflags0+  (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn+  (dflags1, unhandled_flags, warns)+    <- parseDynamicFilePragma logger 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+              { sourceCodePreprocessor  = SCPHsCpp+              , 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_env1 = hscSetFlags dflags hsc_env0++  -- Initialise plugins as the flags passed into runHscPhase might have local plugins just+  -- specific to this module.+  hsc_env <- initializePlugins hsc_env1++  -- gather the imports and module name+  (hspp_buf,mod_name,imps,src_imps) <- 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 (\(s, rpk, lmn@(L _ mn)) -> (s, 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, L _ mod_name) -> return+              (Just buf, mod_name, rn_imps 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 <- 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 src_flavour++  -- 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_textual_imps = imps,+                                ms_srcimps      = src_imps }+++  -- run the compiler!+  let msg :: Messager+      msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what++  -- A lazy module graph thunk, don't force it unless you need it!+  mg <- downsweepThunk hsc_env mod_summary++  -- 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 hsc_env' =+        setModuleGraph mg+          hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }++++  status <- hscRecompStatus (Just msg) hsc_env' mod_summary+                        Nothing emptyHomeModInfoLinkable (1, 1)++  return (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 = mkHomeModLocation fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff) src_flavour++    -- 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+        location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }+                  | otherwise      = location1++    let dynohi = dynOutputHi dflags+        location3 | Just fn <- dynohi = location2{ ml_dyn_hi_file_ospath = unsafeEncodeUtf 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+        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)+                  = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile+                              , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }+                  | Just dyn_ofile <- expl_dyn_o_file+                  = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }+                  | otherwise = location3+    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 =+       [("-relocation-model=" ++ rmodel+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]++    -- 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+        target_os = platformOS (targetPlatform dflags)+        LlvmTarget _ mcpu mattr = expectJust $ lookup target (llvmTargets llvm_config)++        -- Relocation models+        rmodel |  gopt Opt_PIC dflags+               || positionIndependent dflags+               || target_os == OSMinGW32 -- #22487: use PIC on (64-bit) Windows+               = "pic"+               | ways dflags `hasWay` WayDyn+               = "dynamic-no-pic"+               | otherwise+               = "static"++        platform = targetPlatform dflags+        arch = platformArch platform++        attrs :: String+        attrs = intercalate "," $ mattr+              ++ ["+sse4.2"  | isSse4_2Enabled dflags   ]+              ++ ["+popcnt"  | isSse4_2Enabled dflags   ]+                   -- LLVM gates POPCNT instructions behind the popcnt flag,+                   -- while the GHC NCG (as well as GCC, Clang) gates it+                   -- behind SSE4.2 instead.+              ++ ["+sse4.1"  | isSse4_1Enabled dflags   ]+              ++ ["+ssse3"   | isSsse3Enabled dflags    ]+              ++ ["+sse3"    | isSse3Enabled 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 ]+              -- For Arch64 +fma is not a option (it's unconditionally available).+              ++ ["+fma"     | isFmaEnabled dflags && (arch /= ArchAArch64) ]+              ++ ["+bmi"     | isBmiEnabled dflags      ]+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]++        abi :: String+        abi = case platformArch (targetPlatform dflags) of+                ArchRISCV64 -> "lp64d"+                ArchLoongArch64 -> "lp64d"+                _           -> ""++-- | What phase to run after one of the backend code generators has run+hscPostBackendPhase :: HscSource -> Backend -> Phase+hscPostBackendPhase (HsBootOrSig _) _ =  StopLn+hscPostBackendPhase HsSrcFile 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.++However, `ld -r` is broken in some cases:++ * 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.++In these cases, we bundle a module's own object file with its foreign+stub's object file, instead of merging them. Consequently, we can end+up producing `.o` files which are in fact static archives. This can+only work if `ar -L` is supported, so the archive `.o` files can be+properly added to the final static library.++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 = 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 :: FilePath -> IO ()+touchObjectFile path = do+  createDirectoryIfMissing True $ takeDirectory path+  GHC.Utils.Touch.touch 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.+-}
+ GHC/Driver/Pipeline/LogQueue.hs view
@@ -0,0 +1,123 @@+{-# 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 :: 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))
+ GHC/Driver/Pipeline/Monad.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE MultiParamTypeClasses #-}+-- | The 'TPipelineClass' and 'MonadUse' classes and associated types+module GHC.Driver.Pipeline.Monad (+  TPipelineClass, MonadUse(..)++  , PipeEnv(..)+  , PipelineOutput(..)+  ) where++import GHC.Prelude+import Control.Monad.IO.Class+import qualified Data.Kind as K+import GHC.Driver.Phases+import GHC.Utils.TmpFs++-- The interface that the pipeline monad must implement.+type TPipelineClass (f :: K.Type -> K.Type) (m :: K.Type -> K.Type)+  = (Functor m, MonadIO m, Applicative m, Monad m, MonadUse f m)++-- | Lift a `f` action into an `m` action.+class MonadUse f m where+  use :: f a -> m a++-- PipeEnv: invariant information passed down through the pipeline+data PipeEnv = PipeEnv {+       stop_phase   :: StopPhase,   -- ^ Stop just after this phase+       src_filename :: String,      -- ^ basename of original input source+       src_basename :: String,      -- ^ basename of original input source+       src_suffix   :: String,      -- ^ its extension+       start_phase  :: Phase,+       output_spec  :: PipelineOutput -- ^ says where to put the pipeline output+  }+++data PipelineOutput+  = Temporary TempFileLifetime+        -- ^ Output should be to a temporary file: we're going to+        -- run more compilation steps on this output later.+  | Persistent+        -- ^ We want a persistent file, i.e. a file in the current directory+        -- derived from the input filename, but with the appropriate extension.+        -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.+  | SpecificFile+        -- ^ The output must go into the specific outputFile in DynFlags.+        -- We don't store the filename in the constructor as it changes+        -- when doing -dynamic-too.+  | NoOutputFile+        -- ^ No output should be created, like in Interpreter or NoBackend.+    deriving Show
+ GHC/Driver/Pipeline/Phases.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++module GHC.Driver.Pipeline.Phases (TPhase(..), PhaseHook(..)) where++import GHC.Prelude+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Env.Types+import GHC.Driver.DynFlags+import GHC.Types.SourceFile+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Status+import GHC.Tc.Types ( FrontendResult )+import GHC.Types.Error+import GHC.Driver.Errors.Types+import GHC.Fingerprint.Type+import GHC.Unit.Module.Location ( ModLocation )+import GHC.Unit.Module.ModIface+import GHC.Driver.Phases++import Language.Haskell.Syntax.Module.Name ( ModuleName )+import GHC.Unit.Home.ModInfo++-- Typed Pipeline Phases+-- MP: TODO: We need to refine the arguments to each of these phases so recompilation+-- can be smarter. For example, rather than passing a whole HscEnv, just pass the options+-- which each phase depends on, then recompilation checking can decide to only rerun each+-- phase if the inputs have been modified.+data TPhase res where+  T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, Messages DriverMessage)+  T_Cpp   :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_HsPp  :: PipeEnv -> HscEnv -> FilePath -> FilePath -> TPhase FilePath+  T_HscRecomp :: PipeEnv -> HscEnv -> FilePath -> HscSource -> TPhase (HscEnv, ModSummary, HscRecompStatus)+  T_Hsc :: HscEnv -> ModSummary -> TPhase (FrontendResult, Messages GhcMessage)+  T_HscPostTc :: HscEnv -> ModSummary+              -> FrontendResult+              -> Messages GhcMessage+              -> Maybe Fingerprint+              -> TPhase HscBackendAction+  T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, HomeModLinkable, FilePath)+  T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath)+  T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_Js :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_LlvmAs :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath+  T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_MergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath++-- | A wrapper around the interpretation function for phases.+data PhaseHook = PhaseHook (forall a . TPhase a -> IO a)
+ GHC/Driver/Plugins.hs view
@@ -0,0 +1,436 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL)+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE UnboxedTuples #-}+#endif+++-- | Definitions for writing /plugins/ for GHC. Plugins can hook into+-- several areas of the compiler. See the 'Plugin' type. These plugins+-- include type-checker plugins, source plugins, and core-to-core plugins.++module GHC.Driver.Plugins (+      -- * Plugins+      Plugins (..)+    , emptyPlugins+    , Plugin(..)+    , defaultPlugin+    , CommandLineOption+    , PsMessages(..)+    , ParsedResult(..)++      -- * External plugins+    , loadExternalPlugins++      -- ** Recompilation checking+    , purePlugin, impurePlugin, flagRecompile+    , PluginRecompile(..)++      -- * Plugin types+      -- ** Frontend plugins+    , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction+      -- ** Core plugins+      -- | Core plugins allow plugins to register as a Core-to-Core pass.+    , CorePlugin+      -- ** Typechecker plugins+      -- | Typechecker plugins allow plugins to provide evidence to the+      -- typechecker.+    , TcPlugin+      -- ** Source plugins+      -- | GHC offers a number of points where plugins can access and modify its+      -- front-end (\"source\") representation. These include:+      --+      -- - access to the parser result with 'parsedResultAction'+      -- - access to the renamed AST with 'renamedResultAction'+      -- - access to the typechecked AST with 'typeCheckResultAction'+      -- - access to the Template Haskell splices with 'spliceRunAction'+      -- - access to loaded interface files with 'interfaceLoadAction'+      --+    , keepRenamedSource+      -- ** Defaulting plugins+      -- | Defaulting plugins can add candidate types to the defaulting+      -- mechanism.+    , DefaultingPlugin+      -- ** Hole fit plugins+      -- | hole fit plugins allow plugins to change the behavior of valid hole+      -- fit suggestions+    , HoleFitPluginR+      -- ** Late plugins+      -- | Late plugins can access and modify the core of a module after+      -- optimizations have been applied and after interface creation.+    , LatePlugin++      -- * Internal+    , PluginWithArgs(..), pluginsWithArgs, pluginRecompile'+    , LoadedPlugin(..), lpModuleName+    , StaticPlugin(..)+    , ExternalPlugin(..)+    , mapPlugins, withPlugins, withPlugins_+    ) where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Monad+import GHC.Driver.Phases+import GHC.Driver.Plugins.External++import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary++import GHC.Parser.Errors.Types (PsWarning, PsError)++import qualified GHC.Tc.Types+import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  )+import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR )++import GHC.Core.Opt.Monad ( CoreM )+import GHC.Core.Opt.Pipeline.Types ( CoreToDo )+import GHC.Hs+import GHC.Types.Error (Messages)+import GHC.Linker.Types+import GHC.Types.CostCentre.State+import GHC.Types.Unique.DFM++import GHC.Unit.Module.ModGuts (CgGuts)+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List (sort)++--Qualified import so we can define a Semigroup instance+-- but it doesn't clash with Outputable.<>+import qualified Data.Semigroup++import Control.Monad++#if defined(HAVE_INTERNAL_INTERPRETER) && defined(CAN_LOAD_DLL)+import GHCi.ObjLink+import GHC.Exts (addrToAny#, Ptr(..))+import GHC.Utils.Encoding+#endif+++-- | Command line options gathered from the -PModule.Name:stuff syntax+-- are given to you as this type+type CommandLineOption = String++-- | Errors and warnings produced by the parser+data PsMessages = PsMessages { psWarnings :: Messages PsWarning+                             , psErrors   :: Messages PsError+                             }++-- | Result of running the parser and the parser plugin+data ParsedResult = ParsedResult+  { -- | Parsed module, potentially modified by a plugin+    parsedResultModule :: HsParsedModule+  , -- | Warnings and errors from parser, potentially modified by a plugin+    parsedResultMessages :: PsMessages+  }++-- | 'Plugin' is the compiler plugin data type. Try to avoid+-- constructing one of these directly, and just modify some fields of+-- 'defaultPlugin' instead: this is to try and preserve source-code+-- compatibility when we add fields to this.+--+-- Nonetheless, this API is preliminary and highly likely to change in+-- the future.+data Plugin = Plugin {+    installCoreToDos :: CorePlugin+    -- ^ Modify the Core pipeline that will be used for compilation.+    -- This is called as the Core pipeline is built for every module+    -- being compiled, and plugins get the opportunity to modify the+    -- pipeline in a nondeterministic order.+  , tcPlugin :: TcPlugin+    -- ^ An optional typechecker plugin, which may modify the+    -- behaviour of the constraint solver.+  , defaultingPlugin :: DefaultingPlugin+    -- ^ An optional defaulting plugin, which may specify the+    -- additional type-defaulting rules.+  , holeFitPlugin :: HoleFitPlugin+    -- ^ An optional plugin to handle hole fits, which may re-order+    --   or change the list of valid hole fits and refinement hole fits.++  , driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv+    -- ^ An optional plugin to update 'HscEnv', right after plugin loading. This+    -- can be used to register hooks or tweak any field of 'DynFlags' before+    -- doing actual work on a module.+    --+    --   @since 8.10.1++  , latePlugin :: LatePlugin+    -- ^ A plugin that runs after interface creation and after late cost centre+    -- insertion. Useful for transformations that should not impact interfaces+    -- or optimization at all.+    --+    -- @since 9.10.1++  , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile+    -- ^ Specify how the plugin should affect recompilation.+  , parsedResultAction :: [CommandLineOption] -> ModSummary+                       -> ParsedResult -> Hsc ParsedResult+    -- ^ Modify the module when it is parsed. This is called by+    -- "GHC.Driver.Main" when the parser has produced no or only non-fatal+    -- errors.+    -- Compilation will fail if the messages produced by this function contain+    -- any errors.+  , renamedResultAction :: [CommandLineOption] -> TcGblEnv+                                -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)+    -- ^ Modify each group after it is renamed. This is called after each+    -- `HsGroup` has been renamed.+  , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv+                               -> TcM TcGblEnv+    -- ^ Modify the module when it is type checked. This is called at the+    -- very end of typechecking.+  , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc+                         -> TcM (LHsExpr GhcTc)+    -- ^ Modify the TH splice or quasiqoute before it is run.+  , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface+                                          -> IfM lcl ModIface+    -- ^ Modify an interface that have been loaded. This is called by+    -- "GHC.Iface.Load" when an interface is successfully loaded. Not applied to+    -- the loading of the plugin interface. Tools that rely on information from+    -- modules other than the currently compiled one should implement this+    -- function.+  }++-- Note [Source plugins]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The `Plugin` datatype have been extended by fields that allow access to the+-- different inner representations that are generated during the compilation+-- process. These fields are `parsedResultAction`, `renamedResultAction`,+-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`.+--+-- The main purpose of these plugins is to help tool developers. They allow+-- development tools to extract the information about the source code of a big+-- Haskell project during the normal build procedure. In this case the plugin+-- acts as the tools access point to the compiler that can be controlled by+-- compiler flags. This is important because the manipulation of compiler flags+-- is supported by most build environment.+--+-- For the full discussion, check the full proposal at:+-- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal++data PluginWithArgs = PluginWithArgs+  { paPlugin :: Plugin+    -- ^ the actual callable plugin+  , paArguments :: [CommandLineOption]+    -- ^ command line arguments for the plugin+  }++-- | A plugin with its arguments. The result of loading the plugin.+data LoadedPlugin = LoadedPlugin+  { lpPlugin :: PluginWithArgs+  -- ^ the actual plugin together with its commandline arguments+  , lpModule :: ModIface+  -- ^ the module containing the plugin+  }++-- | External plugin loaded directly from a library without loading module+-- interfaces+data ExternalPlugin = ExternalPlugin+  { epPlugin :: PluginWithArgs -- ^ Plugin with its arguments+  , epUnit   :: String         -- ^ UnitId+  , epModule :: String         -- ^ Module name+  }++-- | A static plugin with its arguments. For registering compiled-in plugins+-- through the GHC API.+data StaticPlugin = StaticPlugin+  { spPlugin :: PluginWithArgs+  -- ^ the actual plugin together with its commandline arguments+  , spInitialised :: Bool+  -- ^ has this plugin been initialised (i.e. driverPlugin has been run)+  }++lpModuleName :: LoadedPlugin -> ModuleName+lpModuleName = moduleName . mi_module . lpModule++pluginRecompile' :: PluginWithArgs -> IO PluginRecompile+pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args++data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint++instance Outputable PluginRecompile where+  ppr ForceRecompile = text "ForceRecompile"+  ppr NoForceRecompile = text "NoForceRecompile"+  ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp++instance Semigroup PluginRecompile where+  ForceRecompile <> _ = ForceRecompile+  NoForceRecompile <> r = r+  MaybeRecompile fp <> NoForceRecompile   = MaybeRecompile fp+  MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp'])+  MaybeRecompile _fp <> ForceRecompile     = ForceRecompile++instance Monoid PluginRecompile where+  mempty = NoForceRecompile++type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]+type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin+type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin+type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR+type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)++purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile+purePlugin _args = return NoForceRecompile++impurePlugin _args = return ForceRecompile++flagRecompile =+  return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort++-- | Default plugin: does nothing at all, except for marking that safe+-- inference has failed unless @-fplugin-trustworthy@ is passed. For+-- compatibility reason you should base all your plugin definitions on this+-- default value.+defaultPlugin :: Plugin+defaultPlugin = Plugin {+        installCoreToDos      = const return+      , tcPlugin              = const Nothing+      , defaultingPlugin      = const Nothing+      , holeFitPlugin         = const Nothing+      , driverPlugin          = const return+      , latePlugin            = \_ -> const return+      , pluginRecompile       = impurePlugin+      , renamedResultAction   = \_ env grp -> return (env, grp)+      , parsedResultAction    = \_ _ -> return+      , typeCheckResultAction = \_ _ -> return+      , spliceRunAction       = \_ -> return+      , interfaceLoadAction   = \_ -> return+    }+++-- | A renamer plugin which mades the renamed source available in+-- a typechecker plugin.+keepRenamedSource :: [CommandLineOption] -> TcGblEnv+                  -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)+keepRenamedSource _ gbl_env group =+  return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env)+                  , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group)+  where+    update_exports Nothing = Just []+    update_exports m = m++    update Nothing = Just emptyRnGroup+    update m       = m+++type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a+type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()++data Plugins = Plugins+  { staticPlugins :: ![StaticPlugin]+      -- ^ Static plugins which do not need dynamic loading. These plugins are+      -- intended to be added by GHC API users directly to this list.+      --+      -- To add dynamically loaded plugins through the GHC API see+      -- 'addPluginModuleName' instead.++  , externalPlugins :: ![ExternalPlugin]+      -- ^ External plugins loaded directly from libraries without loading+      -- module interfaces.++  , loadedPlugins :: ![LoadedPlugin]+      -- ^ Plugins dynamically loaded after processing arguments. What+      -- will be loaded here is directed by DynFlags.pluginModNames.+      -- Arguments are loaded from DynFlags.pluginModNameOpts.+      --+      -- The purpose of this field is to cache the plugins so they+      -- don't have to be loaded each time they are needed.  See+      -- 'GHC.Runtime.Loader.initializePlugins'.+  , loadedPluginDeps :: !([Linkable], PkgsLoaded)+  -- ^ The object files required by the loaded plugins+  -- See Note [Plugin dependencies]+  }++emptyPlugins :: Plugins+emptyPlugins = Plugins+  { staticPlugins    = []+  , externalPlugins  = []+  , loadedPlugins    = []+  , loadedPluginDeps = ([], emptyUDFM)+  }++pluginsWithArgs :: Plugins -> [PluginWithArgs]+pluginsWithArgs plugins =+  map lpPlugin (loadedPlugins plugins) +++  map epPlugin (externalPlugins plugins) +++  map spPlugin (staticPlugins plugins)++-- | Perform an operation by using all of the plugins in turn.+withPlugins :: Monad m => Plugins -> PluginOperation m a -> a -> m a+withPlugins plugins transformation input = foldM go input (pluginsWithArgs plugins)+  where+    go arg (PluginWithArgs p opts) = transformation p opts arg++mapPlugins :: Plugins -> (Plugin -> [CommandLineOption] -> a) -> [a]+mapPlugins plugins f = map (\(PluginWithArgs p opts) -> f p opts) (pluginsWithArgs plugins)++-- | Perform a constant operation by using all of the plugins in turn.+withPlugins_ :: Monad m => Plugins -> ConstPluginOperation m a -> a -> m ()+withPlugins_ plugins transformation input+  = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)+          (pluginsWithArgs plugins)++type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()+data FrontendPlugin = FrontendPlugin {+      frontend :: FrontendPluginAction+    }+defaultFrontendPlugin :: FrontendPlugin+defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () }+++-- | Load external plugins+loadExternalPlugins :: [ExternalPluginSpec] -> IO [ExternalPlugin]+loadExternalPlugins [] = return []+#if !defined(HAVE_INTERNAL_INTERPRETER)+loadExternalPlugins _ = do+  panic "loadExternalPlugins: can't load external plugins with GHC built without internal interpreter"+#elif !defined(CAN_LOAD_DLL)+loadExternalPlugins _ = do+  panic "loadExternalPlugins: loading shared libraries isn't supported by this compiler"+#else+loadExternalPlugins ps = do+  -- initialize the linker+  initObjLinker RetainCAFs+  -- load plugins+  forM ps $ \(ExternalPluginSpec path unit mod_name opts) -> do+    loadExternalPluginLib path+    -- lookup symbol+    let ztmp = zEncodeString mod_name ++ "_plugin_closure"+        symbol+          | null unit = ztmp+          | otherwise = zEncodeString unit ++ "_" ++ ztmp+    plugin <- lookupSymbol symbol >>= \case+      Nothing -> pprPanic "loadExternalPlugins"+                  (vcat [ text "Symbol not found"+                        , text "  Library path: " <> text path+                        , text "  Symbol      : " <> text symbol+                        ])+      Just (Ptr addr) -> case addrToAny# addr of+        (# a #) -> pure a++    pure $ ExternalPlugin (PluginWithArgs plugin opts) unit mod_name++loadExternalPluginLib :: FilePath -> IO ()+loadExternalPluginLib path = do+  -- load library+  loadDLL path >>= \case+    Left errmsg -> pprPanic "loadExternalPluginLib"+                     (vcat [ text "Can't load plugin library"+                           , text "  Library path: " <> text path+                           , text "  Error       : " <> text errmsg+                           ])+    Right _ -> do+      -- resolve objects+      resolveObjs >>= \case+        True -> return ()+        False -> pprPanic "loadExternalPluginLib" (text "Unable to resolve objects for library: " <> text path)++#endif
+ GHC/Driver/Plugins.hs-boot view
@@ -0,0 +1,13 @@+-- The plugins datatype is stored in DynFlags, so it needs to be+-- exposed without importing all of its implementation.+module GHC.Driver.Plugins where++import GHC.Prelude ()++data Plugin+data Plugins++emptyPlugins :: Plugins++data LoadedPlugin+data StaticPlugin
+ GHC/Driver/Plugins/External.hs view
@@ -0,0 +1,79 @@+-- | External plugins+--+-- GHC supports two kinds of "static" plugins:+--  1. internal: setup with GHC-API+--  2. external: setup as explained below and loaded from shared libraries+--+-- The intended use case for external static plugins is with cross compilers: at+-- the time of writing, GHC is mono-target and a GHC cross-compiler (i.e. when+-- host /= target) can't build nor load plugins for the host using the+-- "non-static" plugin approach. Fixing this is tracked in #14335. If you're not+-- using a cross-compiler, you'd better use non-static plugins which are easier+-- to build and and safer to use (see below).+--+-- External static plugins can be configured via the command-line with+-- the -fplugin-library flag. Syntax is:+--+--   -fplugin-library=⟨file-path⟩;⟨unit-id⟩;⟨module⟩;⟨args⟩+--+-- Example:+--    -fplugin-library=path/to/plugin;package-123;Plugin.Module;["Argument","List"]+--+-- Building the plugin library:+--  1. link with the libraries used to build the compiler you target.  If you+--  target a cross-compiler (stage2), you can't directly use it to build the+--  plugin library. Use the stage1 compiler instead.+--+--  2. if you use cabal to build the library, its unit-id will be set by cabal+--  and will contain a hash (e.g. "my-plugin-unit-1345656546ABCDEF"). To force+--  the unit id, use GHC's `-this-unit-id` command line flag:+--    e.g. -this-unit-id my-plugin-unit+--  You can set this in the .cabal file of your library with the following+--  stanza: `ghc-options: -this-unit-id my-plugin-unit`+--+--  3. To make your plugin easier to distribute, you may want to link it+--  statically with all its dependencies. You would need to use `-shared`+--  without `-dynamic` when building your library.+--+--  However, all the static dependencies have to be built with `-fPIC` and it's+--  not done by default. See+--  https://www.hobson.space/posts/haskell-foreign-library/ for a way to modify+--  the compiler to do it.+--+--  In any case, don't link your plugin library statically with the RTS (e.g.+--  use `-fno-link-rts`) as there are some global variables in the RTS that must+--  be shared between the plugin and the compiler.+--+-- With external static plugins we don't check the type of the `plugin` closure+-- we look up. If it's not a valid `Plugin` value, it will probably crash badly.+--++module GHC.Driver.Plugins.External+  ( ExternalPluginSpec (..)+  , parseExternalPluginSpec+  )+where++import GHC.Prelude+import Text.Read++-- | External plugin spec+data ExternalPluginSpec = ExternalPluginSpec+  { esp_lib     :: !FilePath+  , esp_unit_id :: !String+  , esp_module  :: !String+  , esp_args    :: ![String]+  }++-- | Parser external static plugin specification from command-line flag+parseExternalPluginSpec :: String -> Maybe ExternalPluginSpec+parseExternalPluginSpec optflag =+  case break (== ';') optflag of+    (libPath, _:rest) -> case break (== ';') rest of+      (libName, _:pack) -> case break (== ';') pack of+        (modName, _:args) -> case readMaybe args of+          Just as -> Just (ExternalPluginSpec libPath libName modName as)+          Nothing -> Nothing+        _ -> Nothing+      _ -> Nothing+    _ -> Nothing
+ GHC/Driver/Ppr.hs view
@@ -0,0 +1,47 @@+-- | Printing related functions that depend on session state (DynFlags)+module GHC.Driver.Ppr+   ( showSDoc+   , showSDocUnsafe+   , showSDocForUser+   , showPpr+   , showPprUnsafe+   , printForUser+   , printForUserColoured+   )+where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Unit.State++import GHC.Utils.Outputable+import GHC.Utils.Ppr       ( Mode(..) )++import System.IO ( Handle )++-- | Show a SDoc as a String with the default user style+showSDoc :: DynFlags -> SDoc -> String+showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc++showPpr :: Outputable a => DynFlags -> a -> String+showPpr dflags thing = showSDoc dflags (ppr thing)++-- | Allows caller to specify the NamePprCtx to use+showSDocForUser :: DynFlags -> UnitState -> NamePprCtx -> SDoc -> String+showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDocContext dflags sty) doc'+   where+      sty  = mkUserStyle name_ppr_ctx AllTheWay+      doc' = pprWithUnitState unit_state doc++printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()+printForUser = printForUser' False++printForUserColoured :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()+printForUserColoured = printForUser' True++printForUser' :: Bool -> DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO ()+printForUser' colour dflags handle name_ppr_ctx depth doc+  = printSDocLn ctx (PageMode False) handle doc+    where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth)+
+ GHC/Driver/Session.hs view
@@ -0,0 +1,3845 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}++-------------------------------------------------------------------------------+--+-- | Dynamic flags+--+-- Most flags are dynamic flags, which means they can change from compilation+-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each+-- session can be using different dynamic flags. Dynamic flags can also be set+-- at the prompt in GHCi.+--+-- (c) The University of Glasgow 2005+--+-------------------------------------------------------------------------------++module GHC.Driver.Session (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        glasgowExtsFlags,+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        sccProfilingEnabled,+        needSourceNotes,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        outputFile, objectSuf, ways,+        FlagSpec(..),+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        fFlags, fLangFlags, xFlags,+        wWarningFlags,+        makeDynFlagsConsistent,+        positionIndependent,+        optimisationFlags,+        codeGenFlags,+        setFlagsFromEnvFile,+        pprDynFlagsDiff,+        flagSpecOf,++        targetProfile,++        -- ** Safe Haskell+        safeHaskellOn, safeHaskellModeEnabled,+        safeImportsOn, safeLanguageOn, safeInferOn,+        packageTrustOn,+        safeDirectImpsReq, safeImplicitImpsReq,+        unsafeFlags, unsafeFlagsForInfer,++        -- ** base+        baseUnitId,++        -- ** System tool settings and locations+        Settings(..),+        sProgramName,+        sProjectVersion,+        sGhcUsagePath,+        sGhciUsagePath,+        sToolDir,+        sTopDir,+        sGlobalPackageDatabasePath,+        sLdSupportsCompactUnwind,+        sLdSupportsFilelist,+        sLdIsGnuLd,+        sGccSupportsNoPie,+        sPgm_L,+        sPgm_P,+        sPgm_F,+        sPgm_c,+        sPgm_cxx,+        sPgm_cpp,+        sPgm_a,+        sPgm_l,+        sPgm_lm,+        sPgm_windres,+        sPgm_ar,+        sPgm_ranlib,+        sPgm_lo,+        sPgm_lc,+        sPgm_las,+        sPgm_i,+        sOpt_L,+        sOpt_P,+        sOpt_P_fingerprint,+        sOpt_JSP,+        sOpt_JSP_fingerprint,+        sOpt_CmmP,+        sOpt_CmmP_fingerprint,+        sOpt_F,+        sOpt_c,+        sOpt_cxx,+        sOpt_a,+        sOpt_l,+        sOpt_lm,+        sOpt_windres,+        sOpt_lo,+        sOpt_lc,+        sOpt_i,+        sExtraGccViaCFlags,+        sTargetPlatformString,+        sGhcWithInterpreter,+        sLibFFI,+        sTargetRTSLinkerOnlySupportsSharedLibs,+        GhcNameVersion(..),+        FileSettings(..),+        PlatformMisc(..),+        settings,+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,+        pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l,+        pgm_lm, pgm_windres, pgm_ar,+        pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i,+        opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,+        opt_P_signature, opt_JSP_signature, opt_CmmP_signature,+        opt_windres, opt_lo, opt_lc, opt_las,+        updatePlatformConstants,++        -- ** Manipulating DynFlags+        addPluginModuleName,+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,+        augmentByWorkingDirectory,++        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]+        getVerbFlags,+        updOptLevel,+        setTmpDir,+        setUnitId,+        setHomeUnitId,++        TurnOnFlag,+        turnOn,+        turnOff,+        impliedGFlags,+        impliedOffGFlags,+        impliedXFlags,++        -- ** State+        CmdLineP(..), runCmdLineP,+        getCmdLineState, putCmdLineState,+        processCmdLineP,++        -- ** Parsing DynFlags+        parseDynamicFlagsCmdLine,+        parseDynamicFilePragma,+        parseDynamicFlagsFull,+        flagSuggestions,++        -- ** Available DynFlags+        allNonDeprecatedFlags,+        flagsAll,+        flagsDynamic,+        flagsPackage,+        flagsForCompletion,++        supportedLanguagesAndExtensions,+        languageExtensions,++        -- ** DynFlags C compiler options+        picCCOpts, picPOpts,++        -- ** DynFlags C linker options+        pieCCLDOpts,++        -- * Compiler configuration suitable for display to the user+        compilerInfo,++        wordAlignment,++        setUnsafeGlobalDynFlags,++        -- * SSE and AVX+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isBmiEnabled,+        isBmi2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,++        -- * Linker/compiler information+        useXLinkerRPath,++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile+import GHC.Platform.ArchOS++import GHC.Unit.Types+import GHC.Unit.Parser+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Driver.DynFlags+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Driver.Errors.Types+import GHC.Driver.Plugins.External+import GHC.Settings.Config+import GHC.Core.Unfold+import GHC.Driver.CmdLine+import GHC.Utils.Logger+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.GlobalVars+import GHC.Data.Maybe+import GHC.Data.Bool+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Types.Error+import GHC.Types.Name.Reader (RdrName(..))+import GHC.Types.Name.Occurrence (isVarOcc, occNameString)+import GHC.Utils.Monad+import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell+import GHC.Types.Basic ( treatZeroAsInf )+import GHC.Data.FastString+import GHC.Utils.TmpFs+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import GHC.Utils.Error (emptyDiagOpts, logInfo)+import GHC.Settings+import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Opt.CallerCC+import GHC.Parser (parseIdentifier)+import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))++import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )++import Data.IORef+import Control.Arrow ((&&&))+import Control.Monad+import Control.Monad.Trans.State as State+import Data.Functor.Identity++import Data.Ord+import Data.Char+import Data.List (intercalate, sortBy, partition)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Word+import System.FilePath+import Text.ParserCombinators.ReadP hiding (char)+import Text.ParserCombinators.ReadP as R++import qualified GHC.Data.EnumSet as EnumSet++import qualified GHC.LanguageExtensions as LangExt+++-- Note [Updating flag description in the User's Guide]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you modify anything in this file please make sure that your changes are+-- described in the User's Guide. Please update the flag description in the+-- users guide (docs/users_guide) whenever you add or change a flag.+-- Please make sure you add ":since:" information to new flags.++-- Note [Supporting CLI completion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The command line interface completion (in for example bash) is an easy way+-- for the developer to learn what flags are available from GHC.+-- GHC helps by separating which flags are available when compiling with GHC,+-- and which flags are available when using GHCi.+-- A flag is assumed to either work in both these modes, or only in one of them.+-- When adding or changing a flag, please consider for which mode the flag will+-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,+-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.++-- Note [Adding a language extension]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are a few steps to adding (or removing) a language extension,+--+--  * Adding the extension to GHC.LanguageExtensions+--+--    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs+--    is the canonical list of language extensions known by GHC.+--+--  * Adding a flag to DynFlags.xFlags+--+--    This is fairly self-explanatory. The name should be concise, memorable,+--    and consistent with any previous implementations of the similar idea in+--    other Haskell compilers.+--+--  * Adding the flag to the documentation+--+--    This is the same as any other flag. See+--    Note [Updating flag description in the User's Guide]+--+--  * Adding the flag to Cabal+--+--    The Cabal library has its own list of all language extensions supported+--    by all major compilers. This is the list that user code being uploaded+--    to Hackage is checked against to ensure language extension validity.+--    Consequently, it is very important that this list remains up-to-date.+--+--    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)+--    whose job it is to ensure these GHC's extensions are consistent with+--    Cabal.+--+--    The recommended workflow is,+--+--     1. Temporarily add your new language extension to the+--        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't+--        break while Cabal is updated.+--+--     2. After your GHC change is accepted, submit a Cabal pull request adding+--        your new extension to Cabal's list (found in+--        Cabal/Language/Haskell/Extension.hs).+--+--     3. After your Cabal change is accepted, let the GHC developers know so+--        they can update the Cabal submodule and remove the extensions from+--        expectedGhcOnlyExtensions.+--+--  * Adding the flag to the GHC Wiki+--+--    There is a change log tracking language extension additions and removals+--    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history+--+--  See #4437 and #8176.++-- -----------------------------------------------------------------------------+-- DynFlags++{- Note [RHS Floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to+  'doFloatFromRhs'; with this we can control floating out with GHC flags.++  This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and+  allows for experimentation.+-}++-----------------------------------------------------------------------------+-- Accessors from 'DynFlags'++-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the+-- vast majority of code. But GHCi questionably uses this to produce a default+-- 'DynFlags' from which to compute a flags diff for printing.+settings :: DynFlags -> Settings+settings dflags = Settings+  { sGhcNameVersion = ghcNameVersion dflags+  , sFileSettings = fileSettings dflags+  , sUnitSettings = unitSettings dflags+  , sTargetPlatform = targetPlatform dflags+  , sToolSettings = toolSettings dflags+  , sPlatformMisc = platformMisc dflags+  , sRawSettings = rawSettings dflags+  }++pgm_L                 :: DynFlags -> String+pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags+pgm_P                 :: DynFlags -> (String,[Option])+pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags+pgm_JSP               :: DynFlags -> (String,[Option])+pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags+pgm_CmmP              :: DynFlags -> (String,[Option])+pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags+pgm_F                 :: DynFlags -> String+pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags+pgm_c                 :: DynFlags -> String+pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags+pgm_cxx               :: DynFlags -> String+pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags+pgm_cpp               :: DynFlags -> (String,[Option])+pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags+pgm_a                 :: DynFlags -> (String,[Option])+pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags+pgm_l                 :: DynFlags -> (String,[Option])+pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags+pgm_lm                 :: DynFlags -> Maybe (String,[Option])+pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags+pgm_windres           :: DynFlags -> String+pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags+pgm_ar                :: DynFlags -> String+pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags+pgm_ranlib            :: DynFlags -> String+pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags+pgm_lo                :: DynFlags -> (String,[Option])+pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags+pgm_lc                :: DynFlags -> (String,[Option])+pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags+pgm_las               :: DynFlags -> (String,[Option])+pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags+pgm_i                 :: DynFlags -> String+pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags+opt_L                 :: DynFlags -> [String]+opt_L dflags = toolSettings_opt_L $ toolSettings dflags+opt_P                 :: DynFlags -> [String]+opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_P (toolSettings dflags)+opt_JSP               :: DynFlags -> [String]+opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_JSP (toolSettings dflags)+opt_CmmP              :: DynFlags -> [String]+opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags++-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_P_signature       :: DynFlags -> ([String], Fingerprint)+opt_P_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_P_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_JSP_signature     :: DynFlags -> ([String], Fingerprint)+opt_JSP_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_JSP_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_CmmP+-- flags. See Note [Repeated -optP hashing].+opt_CmmP_signature     :: DynFlags -> Fingerprint+opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings++opt_F                 :: DynFlags -> [String]+opt_F dflags= toolSettings_opt_F $ toolSettings dflags+opt_c                 :: DynFlags -> [String]+opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_c (toolSettings dflags)+opt_cxx               :: DynFlags -> [String]+opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags)+           ++ toolSettings_opt_cxx (toolSettings dflags)+opt_a                 :: DynFlags -> [String]+opt_a dflags= toolSettings_opt_a $ toolSettings dflags+opt_l                 :: DynFlags -> [String]+opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_l (toolSettings dflags)+opt_lm                :: DynFlags -> [String]+opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags+opt_windres           :: DynFlags -> [String]+opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags+opt_lo                :: DynFlags -> [String]+opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags+opt_lc                :: DynFlags -> [String]+opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags+opt_las               :: DynFlags -> [String]+opt_las dflags = toolSettings_opt_las $ toolSettings dflags+opt_i                 :: DynFlags -> [String]+opt_i dflags= toolSettings_opt_i $ toolSettings dflags+++setBaseUnitId :: String -> DynP ()+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }++-----------------------------------------------------------------------------++{-+Note [Verbosity levels]+~~~~~~~~~~~~~~~~~~~~~~~+    0   |   print errors & warnings only+    1   |   minimal verbosity: print "compiling M ... done." for each module.+    2   |   equivalent to -dshow-passes+    3   |   equivalent to existing "ghc -v"+    4   |   "ghc -v -ddump-most"+    5   |   "ghc -v -ddump-all"+-}++-- | Set the Haskell language standard to use+setLanguage :: Language -> DynP ()+setLanguage l = upd (`lang_set` Just l)++-- | Is the -fpackage-trust mode on+packageTrustOn :: DynFlags -> Bool+packageTrustOn = gopt Opt_PackageTrust++-- | Is Safe Haskell on in some way (including inference mode)+safeHaskellOn :: DynFlags -> Bool+safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags++safeHaskellModeEnabled :: DynFlags -> Bool+safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy+                                                   , Sf_Safe ]+++-- | Is the Safe Haskell safe language in use+safeLanguageOn :: DynFlags -> Bool+safeLanguageOn dflags = safeHaskell dflags == Sf_Safe++-- | Is the Safe Haskell safe inference mode active+safeInferOn :: DynFlags -> Bool+safeInferOn = safeInfer++-- | Test if Safe Imports are on in some form+safeImportsOn :: DynFlags -> Bool+safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||+                       safeHaskell dflags == Sf_Trustworthy ||+                       safeHaskell dflags == Sf_Safe++-- | Set a 'Safe Haskell' flag+setSafeHaskell :: SafeHaskellMode -> DynP ()+setSafeHaskell s = updM f+    where f dfs = do+              let sf = safeHaskell dfs+              safeM <- combineSafeFlags sf s+              case s of+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }+                -- leave safe inference on in Trustworthy mode so we can warn+                -- if it could have been inferred safe.+                Sf_Trustworthy -> do+                  l <- getCurLoc+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }+                -- leave safe inference on in Unsafe mode as well.+                _ -> return $ dfs { safeHaskell = safeM }++-- | Are all direct imports required to be safe for this Safe Haskell mode?+-- Direct imports are when the code explicitly imports a module+safeDirectImpsReq :: DynFlags -> Bool+safeDirectImpsReq d = safeLanguageOn d++-- | Are all implicit imports required to be safe for this Safe Haskell mode?+-- Implicit imports are things in the prelude. e.g System.IO when print is used.+safeImplicitImpsReq :: DynFlags -> Bool+safeImplicitImpsReq d = safeLanguageOn d++-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.+-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't+-- want to export this functionality from the module but do want to export the+-- type constructors.+combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode+combineSafeFlags a b | a == Sf_None         = return b+                     | b == Sf_None         = return a+                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore+                     | a == b               = return a+                     | otherwise            = addErr errm >> pure a+    where errm = "Incompatible Safe Haskell flags! ("+                    ++ show a ++ ", " ++ show b ++ ")"++-- | A list of unsafe flags under Safe Haskell. Tuple elements are:+--     * name of the flag+--     * function to get srcspan that enabled the flag+--     * function to test if the flag is on+--     * function to turn the flag off+unsafeFlags, unsafeFlagsForInfer+  :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]+unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc,+                    xopt LangExt.GeneralizedNewtypeDeriving,+                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+              , (LangExt.DerivingVia, deriveViaOnLoc,+                    xopt LangExt.DerivingVia,+                    flip xopt_unset LangExt.DerivingVia)+              , (LangExt.TemplateHaskell, thOnLoc,+                    xopt LangExt.TemplateHaskell,+                    flip xopt_unset LangExt.TemplateHaskell)+              ]+unsafeFlagsForInfer = unsafeFlags+++-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order+getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from+        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors+        -> [a]                  -- ^ Correctly ordered extracted options+getOpts dflags opts = reverse (opts dflags)+        -- We add to the options from the front, so we need to reverse the list++-- | Gets the verbosity flag for the current verbosity level. This is fed to+-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included+getVerbFlags :: DynFlags -> [String]+getVerbFlags dflags+  | verbosity dflags >= 4 = ["-v"]+  | otherwise             = []++setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,+         setDynObjectSuf, setDynHiSuf,+         setDylibInstallName,+         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,+         setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP,+         addOptJSP, addOptCmmP,+         addCmdlineFramework, addHaddockOpts, addGhciScript,+         setInteractivePrint+   :: String -> DynFlags -> DynFlags+setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce+   :: Maybe String -> DynFlags -> DynFlags++setObjectDir  f d = d { objectDir  = Just f}+setHiDir      f d = d { hiDir      = Just f}+setHieDir     f d = d { hieDir     = Just f}+setStubDir    f d = d { stubDir    = Just f+                      , includePaths = addGlobalInclude (includePaths d) [f] }+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+  -- \#included from the .hc file when compiling via C (i.e. unregisterised+  -- builds).+setDumpDir    f d = d { dumpDir    = Just f}+setOutputDir  f = setObjectDir f+                . setHieDir f+                . setHiDir f+                . setStubDir f+                . setDumpDir f+setDylibInstallName  f d = d { dylibInstallName = Just f}++setObjectSuf    f d = d { objectSuf_    = f}+setDynObjectSuf f d = d { dynObjectSuf_ = f}+setHiSuf        f d = d { hiSuf_        = f}+setHieSuf       f d = d { hieSuf        = f}+setDynHiSuf     f d = d { dynHiSuf_     = f}+setHcSuf        f d = d { hcSuf         = f}++setOutputFile    f d = d { outputFile_    = f}+setDynOutputFile f d = d { dynOutputFile_ = f}+setOutputHi      f d = d { outputHi       = f}+setDynOutputHi   f d = d { dynOutputHi    = f}++parseUnitInsts :: String -> Instantiations+parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)+  where parse = sepBy parseEntry (R.char ',')+        parseEntry = do+            n <- parseModuleName+            _ <- R.char '='+            m <- parseHoleyModule+            return (n, m)++setUnitInstantiations :: String -> DynFlags -> DynFlags+setUnitInstantiations s d =+    d { homeUnitInstantiations_ = parseUnitInsts s }++setUnitInstanceOf :: String -> DynFlags -> DynFlags+setUnitInstanceOf s d =+    d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) }++addPluginModuleName :: String -> DynFlags -> DynFlags+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }++clearPluginModuleNames :: DynFlags -> DynFlags+clearPluginModuleNames d =+    d { pluginModNames = []+      , pluginModNameOpts = []+      }++addPluginModuleNameOption :: String -> DynFlags -> DynFlags+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }+  where (m, rest) = break (== ':') optflag+        option = case rest of+          [] -> "" -- should probably signal an error+          (_:plug_opt) -> plug_opt -- ignore the ':' from break++addExternalPlugin :: String -> DynFlags -> DynFlags+addExternalPlugin optflag d = case parseExternalPluginSpec optflag of+  Just r  -> d { externalPluginSpecs = r : externalPluginSpecs d }+  Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag++addFrontendPluginOption :: String -> DynFlags -> DynFlags+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }++parseDynLibLoaderMode f d =+ case splitAt 8 f of+   ("deploy", "")       -> d { dynLibLoader = Deployable }+   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }+   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))++setDumpPrefixForce f d = d { dumpPrefixForce = f}++-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmP   f = alterToolSettings (\s -> s { toolSettings_pgm_P   = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmJSP   f = alterToolSettings (\s -> s { toolSettings_pgm_JSP   = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+addOptl   f = alterToolSettings (\s -> s { toolSettings_opt_l   = f : toolSettings_opt_l s})+addOptc   f = alterToolSettings (\s -> s { toolSettings_opt_c   = f : toolSettings_opt_c s})+addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})+addOptP   f = alterToolSettings $ \s -> s+          { toolSettings_opt_P   = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+          -- See Note [Repeated -optP hashing]+addOptJSP f = alterToolSettings $ \s -> s+          { toolSettings_opt_JSP   = f : toolSettings_opt_JSP s+          , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s)+          }+          -- See Note [Repeated -optP hashing]+addOptCmmP f = alterToolSettings $ \s -> s+          { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s+          , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s)+          }++setDepMakefile :: FilePath -> DynFlags -> DynFlags+setDepMakefile f d = d { depMakefile = f }++setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags+setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }++setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags+setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }++addDepExcludeMod :: String -> DynFlags -> DynFlags+addDepExcludeMod m d+    = d { depExcludeMods = mkModuleName m : depExcludeMods d }++addDepSuffix :: FilePath -> DynFlags -> DynFlags+addDepSuffix s d = d { depSuffixes = s : depSuffixes d }++addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}++addGhcVersionFile :: FilePath -> DynFlags -> DynFlags+addGhcVersionFile f d = d { ghcVersionFile = Just f }++addHaddockOpts f d = d { haddockOptions = Just f}++addGhciScript f d = d { ghciScripts = f : ghciScripts d}++setInteractivePrint f d = d { interactivePrint = Just f}++-----------------------------------------------------------------------------+-- Setting the optimisation level++updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool)+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place+updOptLevelChanged n dfs+  = (dfs3, changed1 || changed2 || changed3)+  where+   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2+   (dfs1, changed1) = foldr unset (dfs , False) remove_gopts+   (dfs2, changed2) = foldr set   (dfs1, False) extra_gopts+   (dfs3, changed3) = setLlvmOptLevel dfs2++   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]+   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]++   set f (dfs, changed)+     | gopt f dfs = (dfs, changed)+     | otherwise = (gopt_set dfs f, True)++   unset f (dfs, changed)+     | not (gopt f dfs) = (dfs, changed)+     | otherwise = (gopt_unset dfs f, True)++   setLlvmOptLevel dfs+     | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True)+     | otherwise = (dfs, False)++updOptLevel :: Int -> DynFlags -> DynFlags+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level+updOptLevel n = fst . updOptLevelChanged n++{- **********************************************************************+%*                                                                      *+                DynFlags parser+%*                                                                      *+%********************************************************************* -}++-- -----------------------------------------------------------------------------+-- Parsing the dynamic flags.+++-- | Parse dynamic flags from a list of command line arguments.  Returns+-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.+-- Throws a 'UsageError' if errors occurred during parsing (such as unknown+-- flags or missing arguments).+parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]+                         -> m (DynFlags, [Located String], Messages DriverMessage)+                            -- ^ Updated 'DynFlags', left-over arguments, and+                            -- list of warnings.+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True+++-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags+-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).+-- Used to parse flags set in a modules pragma.+parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]+                       -> m (DynFlags, [Located String], Messages DriverMessage)+                          -- ^ Updated 'DynFlags', left-over arguments, and+                          -- list of warnings.+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False++newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)+  deriving (Functor)++instance Monad (CmdLineP s) where+    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)+    return = pure++instance Applicative (CmdLineP s) where+    pure x = CmdLineP (pure x)+    (<*>) = ap++getCmdLineState :: CmdLineP s s+getCmdLineState = CmdLineP State.get++putCmdLineState :: s -> CmdLineP s ()+putCmdLineState x = CmdLineP (State.put x)++runCmdLineP :: CmdLineP s a -> s -> (a, s)+runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0++-- | A helper to parse a set of flags from a list of command-line arguments, handling+-- response files.+processCmdLineP+    :: forall s m. MonadIO m+    => [Flag (CmdLineP s)]  -- ^ valid flags to match against+    -> s                    -- ^ current state+    -> [Located String]     -- ^ arguments to parse+    -> m (([Located String], [Err], [Warn]), s)+                            -- ^ (leftovers, errors, warnings)+processCmdLineP activeFlags s0 args =+    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0+  where+    getCmdLineP :: CmdLineP s a -> StateT s m a+    getCmdLineP (CmdLineP k) = k++-- | Parses the dynamically set flags for GHC. This is the most general form of+-- the dynamic flag parser that the other methods simply wrap. It allows+-- saying which flags are valid flags and indicating if we are parsing+-- arguments from the command line or from a file pragma.+parseDynamicFlagsFull+    :: forall m. MonadIO m+    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against+    -> Bool                          -- ^ are the arguments from the command line?+    -> Logger                        -- ^ logger+    -> DynFlags                      -- ^ current dynamic flags+    -> [Located String]              -- ^ arguments to parse+    -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do+  ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args++  -- See Note [Handling errors when parsing command-line flags]+  let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)+  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $+    map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs++  -- check for disabled flags in safe haskell+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1+      theWays = ways dflags2++  unless (allowed_combination theWays) $ liftIO $+      throwGhcExceptionIO (CmdLineError ("combination not supported: " +++                               intercalate "/" (map wayDesc (Set.toAscList theWays))))++  let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2++  -- Set timer stats & heap size+  when (enableTimeStats dflags3) $ liftIO enableTimingStats+  case (ghcHeapSize dflags3) of+    Just x -> liftIO (setHeapSize x)+    _      -> return ()++  liftIO $ setUnsafeGlobalDynFlags dflags3++  -- create message envelopes using final DynFlags: #23402+  let diag_opts = initDiagOpts dflags3+      warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns]++  when (logVerbAtLeast logger 3) $+    mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb++  return (dflags3, leftover, warns)++-- | Check (and potentially disable) any extensions that aren't allowed+-- in safe mode.+--+-- The bool is to indicate if we are parsing command line flags (false means+-- file pragma). This allows us to generate better warnings.+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn])+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)+  where+    -- Handle illegal flags under safe language.+    (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags++    check_method (df, warns) (ext,loc,test,fix)+        | test df   = (fix df, safeFailure (loc df) ext :  warns)+        | otherwise = (df, warns)++    safeFailure loc ext+       = L loc $ DriverSafeHaskellIgnoredExtension ext++safeFlagCheck cmdl dflags =+  case safeInferOn dflags of+    True   -> (dflags' { safeInferred = safeFlags }, warn)+    False  -> (dflags', warn)++  where+    -- dynflags and warn for when -fpackage-trust by itself with no safe+    -- haskell flag+    (dflags', warn)+      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags+      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)+      | otherwise = (dflags, mempty)++    pkgWarnMsg :: [Warn]+    pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ]++    -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main+    -- Force this to avoid retaining reference to old DynFlags value+    !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer++-- | Produce a list of suggestions for a user provided flag that is invalid.+flagSuggestions+  :: [String] -- valid flags to match against+  -> String+  -> [String]+flagSuggestions flags userInput+  -- fixes #11789+  -- If the flag contains '=',+  -- this uses both the whole and the left side of '=' for comparing.+  | elem '=' userInput =+        let (flagsWithEq, flagsWithoutEq) = partition (elem '=') flags+            fName = takeWhile (/= '=') userInput+        in (fuzzyMatch userInput flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+  | otherwise = fuzzyMatch userInput flags++{- **********************************************************************+%*                                                                      *+                DynFlags specifications+%*                                                                      *+%********************************************************************* -}++-- | All dynamic flags option strings without the deprecated ones.+-- These are the user facing strings for enabling and disabling options.+allNonDeprecatedFlags :: [String]+allNonDeprecatedFlags = allFlagsDeps False++-- | All flags with possibility to filter deprecated ones+allFlagsDeps :: Bool -> [String]+allFlagsDeps keepDeprecated = [ '-':flagName flag+                              | (deprecated, flag) <- flagsAllDeps+                              , keepDeprecated || not (isDeprecated deprecated)]+  where isDeprecated Deprecated = True+        isDeprecated _ = False++{-+ - Below we export user facing symbols for GHC dynamic flags for use with the+ - GHC API.+ -}++-- All dynamic flags present in GHC.+flagsAll :: [Flag (CmdLineP DynFlags)]+flagsAll = map snd flagsAllDeps++-- All dynamic flags present in GHC with deprecation information.+flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]+flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps+++-- All dynamic flags, minus package flags, present in GHC.+flagsDynamic :: [Flag (CmdLineP DynFlags)]+flagsDynamic = map snd dynamic_flags_deps++-- ALl package flags present in GHC.+flagsPackage :: [Flag (CmdLineP DynFlags)]+flagsPackage = map snd package_flags_deps++----------------Helpers to make flags and keep deprecation information----------++type FlagMaker m = String -> OptKind m -> Flag m+type DynFlagMaker = FlagMaker (CmdLineP DynFlags)++-- Make a non-deprecated flag+make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)+              -> (Deprecation, Flag (CmdLineP DynFlags))+make_ord_flag fm name kind = (NotDeprecated, fm name kind)++-- Make a deprecated flag+make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String+                 -> (Deprecation, Flag (CmdLineP DynFlags))+make_dep_flag fm name kind message = (Deprecated,+                                      fm name $ add_dep_message kind message)++add_dep_message :: OptKind (CmdLineP DynFlags) -> String+                -> OptKind (CmdLineP DynFlags)+add_dep_message (NoArg f) message = NoArg $ f >> deprecate message+add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message+add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message+add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message+add_dep_message (OptPrefix f) message =+                                  OptPrefix $ \s -> f s >> deprecate message+add_dep_message (OptIntSuffix f) message =+                               OptIntSuffix $ \oi -> f oi >> deprecate message+add_dep_message (IntSuffix f) message =+                                  IntSuffix $ \i -> f i >> deprecate message+add_dep_message (Word64Suffix f) message =+                                  Word64Suffix $ \i -> f i >> deprecate message+add_dep_message (FloatSuffix f) message =+                                FloatSuffix $ \fl -> f fl >> deprecate message+add_dep_message (PassFlag f) message =+                                   PassFlag $ \s -> f s >> deprecate message+add_dep_message (AnySuffix f) message =+                                  AnySuffix $ \s -> f s >> deprecate message++----------------------- The main flags themselves ------------------------------+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+dynamic_flags_deps = [+    make_dep_flag defFlag "n" (NoArg $ return ())+        "The -n flag is deprecated and no longer has any effect"+  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))+  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))+  , (Deprecated, defFlag "#include"+      (HasArg (\_s ->+         deprecate ("-#include and INCLUDE pragmas are " +++                    "deprecated: They no longer have any effect"))))+  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)++  , make_ord_flag defGhcFlag "j"     (OptIntSuffix+        (\n -> case n of+                 Just n+                     | n > 0     -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) })+                     | otherwise -> addErr "Syntax: -j[n] where n > 0"+                 Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors })))+                 -- When the number of parallel builds+                 -- is omitted, it is the same+                 -- as specifying that the number of+                 -- parallel builds is equal to the+                 -- result of getNumProcessors+  , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) }++  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)+  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)++    -- RTS options -------------------------------------------------------------+  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->+          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))++  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->+                                               d { enableTimeStats = True })))++    ------- ways ---------------------------------------------------------------+  , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))+  , (Deprecated, defFlag     "eventlog"+     $ noArgM $ \d -> do+         deprecate "the eventlog is now enabled in all runtime system ways"+         return d)+  , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))+  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))+  , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded))++  , make_ord_flag defGhcFlag "ticky"+      (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))++    -- -ticky enables ticky-ticky code generation, and also implies -debug which+    -- is required to get the RTS ticky support.++        ----- Linker --------------------------------------------------------+  , make_ord_flag defGhcFlag "static"         (NoArg (removeWayDynP WayDyn))+  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))+  , make_ord_flag defGhcFlag "rdynamic" $ noArg $+#if defined(linux_HOST_OS)+                              addOptl "-rdynamic"+#elif defined(mingw32_HOST_OS)+                              addOptl "-Wl,--export-all-symbols"+#else+    -- ignored for compat w/ gcc:+                              id+#endif+  , make_ord_flag defGhcFlag "relative-dynlib-paths"+      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))+  , make_ord_flag defGhcFlag "copy-libs-when-linking"+      (NoArg (setGeneralFlag Opt_SingleLibFolder))+  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))+  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))++        ------- Specific phases  --------------------------------------------+    -- need to appear before -pgmL to be parsed as LLVM flags.+  , make_ord_flag defFlag "pgmlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }+  , make_ord_flag defFlag "pgmlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }+  , make_ord_flag defFlag "pgmlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las  = (f,[]) }+  , make_ord_flag defFlag "pgmlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  =+          if null f then Nothing else Just (f,[]) }+  , make_ord_flag defFlag "pgmi"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }+  , make_ord_flag defFlag "pgmL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }+  , make_ord_flag defFlag "pgmP"+      (hasArg setPgmP)+  , make_ord_flag defFlag "pgmJSP"+      (hasArg setPgmJSP)+  , make_ord_flag defFlag "pgmCmmP"+      (hasArg setPgmCmmP)+  , make_ord_flag defFlag "pgmF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }+  , make_ord_flag defFlag "pgmc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c   = f }+  , make_ord_flag defFlag "pgmcxx"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f }+  , (Deprecated, defFlag  "pgmc-supports-no-pie"+      $ noArgM  $ \d -> do+        deprecate $ "use -pgml-supports-no-pie instead"+        pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d)+  , make_ord_flag defFlag "pgms"+      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))+  , make_ord_flag defFlag "pgma"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }+  , make_ord_flag defFlag "pgml"+      $ hasArg $ \f -> alterToolSettings $ \s -> s+         { toolSettings_pgm_l   = (f,[])+         , -- Don't pass -no-pie with custom -pgml (see #15319). Note+           -- that this could break when -no-pie is actually needed.+           -- But the CC_SUPPORTS_NO_PIE check only happens at+           -- buildtime, and -pgml is a runtime option. A better+           -- solution would be running this check for each custom+           -- -pgml.+           toolSettings_ccSupportsNoPie = False+         }+  , make_ord_flag defFlag "pgml-supports-no-pie"+      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }+  , make_ord_flag defFlag "pgmwindres"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }+  , make_ord_flag defFlag "pgmar"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }+  , make_ord_flag defFlag "pgmotool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}+  , make_ord_flag defFlag "pgminstall_name_tool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}+  , make_ord_flag defFlag "pgmranlib"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }+++    -- need to appear before -optl/-opta to be parsed as LLVM flags.+  , make_ord_flag defFlag "optlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }+  , make_ord_flag defFlag "optlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }+  , make_ord_flag defFlag "optlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }+  , make_ord_flag defFlag "optlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las  = f : toolSettings_opt_las s }+  , make_ord_flag defFlag "opti"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }+  , make_ord_flag defFlag "optL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }+  , make_ord_flag defFlag "optP"+      (hasArg addOptP)+  , make_ord_flag defFlag "optJSP"+      (hasArg addOptJSP)+  , make_ord_flag defFlag "optCmmP"+      (hasArg addOptCmmP)+  , make_ord_flag defFlag "optF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }+  , make_ord_flag defFlag "optc"+      (hasArg addOptc)+  , make_ord_flag defFlag "optcxx"+      (hasArg addOptcxx)+  , make_ord_flag defFlag "opta"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }+  , make_ord_flag defFlag "optl"+      (hasArg addOptl)+  , make_ord_flag defFlag "optwindres"+      $ hasArg $ \f ->+        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }++    -- N.B. We may someday deprecate this in favor of -fsplit-sections,+    -- which has the benefit of also having a negating -fno-split-sections.+  , make_ord_flag defGhcFlag "split-sections"+      (NoArg $ setGeneralFlag Opt_SplitSections)++        -------- ghc -M -----------------------------------------------------+  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)+  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)+  , make_ord_flag defGhcFlag "include-cpp-deps"+        (noArg (setDepIncludeCppDeps True))+  , make_ord_flag defGhcFlag "include-pkg-deps"+        (noArg (setDepIncludePkgDeps True))+  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)++        -------- Linking ----------------------------------------------------+  , make_ord_flag defGhcFlag "no-link"+        (noArg (\d -> d { ghcLink=NoLink }))+  , make_ord_flag defGhcFlag "shared"+        (noArg (\d -> d { ghcLink=LinkDynLib }))+  , make_ord_flag defGhcFlag "staticlib"+        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))+  , make_ord_flag defGhcFlag "-merge-objs"+        (noArg (\d -> d { ghcLink=LinkMergedObj }))+  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)+  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)++        ------- Libraries ---------------------------------------------------+  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)+  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))++        ------- Frameworks --------------------------------------------------+        -- -framework-path should really be -F ...+  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)+  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)++        ------- Output Redirection ------------------------------------------+  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)+  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))+  , make_ord_flag defGhcFlag "dyno"+        (sepArg (setDynOutputFile . Just))+  , make_ord_flag defGhcFlag "ohi"+        (hasArg (setOutputHi . Just ))+  , make_ord_flag defGhcFlag "dynohi"+        (hasArg (setDynOutputHi . Just ))+  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)+  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)+  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)+  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)+  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)+  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)+  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)+  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)+  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)+  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)+  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)+  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)+  , make_ord_flag defGhcFlag "ddump-file-prefix"+        (hasArg (setDumpPrefixForce . Just . flip (++) "."))++  , make_ord_flag defGhcFlag "dynamic-too"+        (NoArg (setGeneralFlag Opt_BuildDynamicToo))++        ------- Keeping temporary files -------------------------------------+     -- These can be singular (think ghc -c) or plural (think ghc --make)+  , make_ord_flag defGhcFlag "keep-hc-file"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hc-files"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-file"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-files"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-s-file"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-s-files"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-llvm-file"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+  , make_ord_flag defGhcFlag "keep-llvm-files"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+     -- This only makes sense as plural+  , make_ord_flag defGhcFlag "keep-tmp-files"+        (NoArg (setGeneralFlag Opt_KeepTmpFiles))+  , make_ord_flag defGhcFlag "keep-hi-file"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-file"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-hi-files"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-files"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-o-file"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-file"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "keep-o-files"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-files"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))++        ------- Miscellaneous ----------------------------------------------+  , make_ord_flag defGhcFlag "no-auto-link-packages"+        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))+  , make_ord_flag defGhcFlag "no-hs-main"+        (NoArg (setGeneralFlag Opt_NoHsMain))+  , make_ord_flag defGhcFlag "fno-state-hack"+        (NoArg (setGeneralFlag Opt_G_NoStateHack))+  , make_ord_flag defGhcFlag "fno-opt-coercion"+        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))+  , make_ord_flag defGhcFlag "with-rtsopts"+        (HasArg setRtsOpts)+  , make_ord_flag defGhcFlag "rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=all"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=some"+        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))+  , make_ord_flag defGhcFlag "rtsopts=none"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "rtsopts=ignore"+        (NoArg (setRtsOptsEnabled RtsOptsIgnore))+  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"+        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))+  , make_ord_flag defGhcFlag "no-rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"+      (noArg (\d -> d {rtsOptsSuggestions = False}))+  , make_ord_flag defGhcFlag "dhex-word-literals"+        (NoArg (setGeneralFlag Opt_HexWordLiterals))++  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)+  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)+  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)+  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)+  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)+  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)+  , make_ord_flag defGhcFlag "ticky-allocd"+        (NoArg (setGeneralFlag Opt_Ticky_Allocd))+  , make_ord_flag defGhcFlag "ticky-LNE"+        (NoArg (setGeneralFlag Opt_Ticky_LNE))+  , make_ord_flag defGhcFlag "ticky-ap-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_AP))+  , make_ord_flag defGhcFlag "ticky-dyn-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))+  , make_ord_flag defGhcFlag "ticky-tag-checks"+        (NoArg (setGeneralFlag Opt_Ticky_Tag))+        ------- recompilation checker --------------------------------------+  , make_dep_flag defGhcFlag "recomp"+        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)+             "Use -fno-force-recomp instead"+  , make_dep_flag defGhcFlag "no-recomp"+        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"+  , make_ord_flag defFlag "fmax-errors"+      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))+  , make_ord_flag defFlag "fno-max-errors"+      (noArg (\d -> d { maxErrors = Nothing }))+  , make_ord_flag defFlag "freverse-errors"+        (noArg (\d -> d {reverseErrors = True} ))+  , make_ord_flag defFlag "fno-reverse-errors"+        (noArg (\d -> d {reverseErrors = False} ))++        ------ HsCpp opts ---------------------------------------------------+  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))+  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))++        ------- Include/Import Paths ----------------------------------------+  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)+  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)++        ------ Output style options -----------------------------------------+  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->+                                                       d { pprUserLength = n }))+  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->+                                                             d { pprCols = n }))+  , make_ord_flag defFlag "fdiagnostics-color=auto"+      (NoArg (upd (\d -> d { useColor = Auto })))+  , make_ord_flag defFlag "fdiagnostics-color=always"+      (NoArg (upd (\d -> d { useColor = Always })))+  , make_ord_flag defFlag "fdiagnostics-color=never"+      (NoArg (upd (\d -> d { useColor = Never })))++  , make_ord_flag defFlag "fprint-error-index-links=auto"+      (NoArg (upd (\d -> d { useErrorLinks = Auto })))+  , make_ord_flag defFlag "fprint-error-index-links=always"+      (NoArg (upd (\d -> d { useErrorLinks = Always })))+  , make_ord_flag defFlag "fprint-error-index-links=never"+      (NoArg (upd (\d -> d { useErrorLinks = Never })))++  -- Suppress all that is suppressible in core dumps.+  -- Except for uniques, as some simplifier phases introduce new variables that+  -- have otherwise identical names.+  , make_ord_flag defGhcFlag "dsuppress-all"+      (NoArg $ do setGeneralFlag Opt_SuppressCoercions+                  setGeneralFlag Opt_SuppressCoercionTypes+                  setGeneralFlag Opt_SuppressVarKinds+                  setGeneralFlag Opt_SuppressModulePrefixes+                  setGeneralFlag Opt_SuppressTypeApplications+                  setGeneralFlag Opt_SuppressIdInfo+                  setGeneralFlag Opt_SuppressTicks+                  setGeneralFlag Opt_SuppressStgExts+                  setGeneralFlag Opt_SuppressStgReps+                  setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressCoreSizes+                  setGeneralFlag Opt_SuppressTimestamps)++        ------ Debugging ----------------------------------------------------+  , make_ord_flag defGhcFlag "dstg-stats"+        (NoArg (setGeneralFlag Opt_StgStats))++  , make_ord_flag defGhcFlag "ddump-cmm"+        (setDumpFlag Opt_D_dump_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"+        (setDumpFlag Opt_D_dump_cmm_from_stg)+  , make_ord_flag defGhcFlag "ddump-cmm-raw"+        (setDumpFlag Opt_D_dump_cmm_raw)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"+        (setDumpFlag Opt_D_dump_cmm_verbose)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"+        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-cfg"+        (setDumpFlag Opt_D_dump_cmm_cfg)+  , make_ord_flag defGhcFlag "ddump-cmm-cbe"+        (setDumpFlag Opt_D_dump_cmm_cbe)+  , make_ord_flag defGhcFlag "ddump-cmm-switch"+        (setDumpFlag Opt_D_dump_cmm_switch)+  , make_ord_flag defGhcFlag "ddump-cmm-proc"+        (setDumpFlag Opt_D_dump_cmm_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-sp"+        (setDumpFlag Opt_D_dump_cmm_sp)+  , make_ord_flag defGhcFlag "ddump-cmm-sink"+        (setDumpFlag Opt_D_dump_cmm_sink)+  , make_ord_flag defGhcFlag "ddump-cmm-caf"+        (setDumpFlag Opt_D_dump_cmm_caf)+  , make_ord_flag defGhcFlag "ddump-cmm-procmap"+        (setDumpFlag Opt_D_dump_cmm_procmap)+  , make_ord_flag defGhcFlag "ddump-cmm-split"+        (setDumpFlag Opt_D_dump_cmm_split)+  , make_ord_flag defGhcFlag "ddump-cmm-info"+        (setDumpFlag Opt_D_dump_cmm_info)+  , make_ord_flag defGhcFlag "ddump-cmm-cps"+        (setDumpFlag Opt_D_dump_cmm_cps)+  , make_ord_flag defGhcFlag "ddump-cmm-opt"+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer"+        (setDumpFlag Opt_D_dump_cmm_thread_sanitizer)+  , make_ord_flag defGhcFlag "ddump-cfg-weights"+        (setDumpFlag Opt_D_dump_cfg_weights)+  , make_ord_flag defGhcFlag "ddump-core-stats"+        (setDumpFlag Opt_D_dump_core_stats)+  , make_ord_flag defGhcFlag "ddump-asm"+        (setDumpFlag Opt_D_dump_asm)+  , make_ord_flag defGhcFlag "ddump-js"+        (setDumpFlag Opt_D_dump_js)+  , make_ord_flag defGhcFlag "ddump-asm-native"+        (setDumpFlag Opt_D_dump_asm_native)+  , make_ord_flag defGhcFlag "ddump-asm-liveness"+        (setDumpFlag Opt_D_dump_asm_liveness)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc"+        (setDumpFlag Opt_D_dump_asm_regalloc)+  , make_ord_flag defGhcFlag "ddump-asm-conflicts"+        (setDumpFlag Opt_D_dump_asm_conflicts)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"+        (setDumpFlag Opt_D_dump_asm_regalloc_stages)+  , make_ord_flag defGhcFlag "ddump-asm-stats"+        (setDumpFlag Opt_D_dump_asm_stats)+  , make_ord_flag defGhcFlag "ddump-llvm"+        (NoArg $ setDumpFlag' Opt_D_dump_llvm)+  , make_ord_flag defGhcFlag "ddump-c-backend"+        (NoArg $ setDumpFlag' Opt_D_dump_c_backend)+  , make_ord_flag defGhcFlag "ddump-deriv"+        (setDumpFlag Opt_D_dump_deriv)+  , make_ord_flag defGhcFlag "ddump-ds"+        (setDumpFlag Opt_D_dump_ds)+  , make_ord_flag defGhcFlag "ddump-ds-preopt"+        (setDumpFlag Opt_D_dump_ds_preopt)+  , make_ord_flag defGhcFlag "ddump-foreign"+        (setDumpFlag Opt_D_dump_foreign)+  , make_ord_flag defGhcFlag "ddump-inlinings"+        (setDumpFlag Opt_D_dump_inlinings)+  , make_ord_flag defGhcFlag "ddump-verbose-inlinings"+        (setDumpFlag Opt_D_dump_verbose_inlinings)+  , make_ord_flag defGhcFlag "ddump-rule-firings"+        (setDumpFlag Opt_D_dump_rule_firings)+  , make_ord_flag defGhcFlag "ddump-rule-rewrites"+        (setDumpFlag Opt_D_dump_rule_rewrites)+  , make_ord_flag defGhcFlag "ddump-simpl-trace"+        (setDumpFlag Opt_D_dump_simpl_trace)+  , make_ord_flag defGhcFlag "ddump-occur-anal"+        (setDumpFlag Opt_D_dump_occur_anal)+  , make_ord_flag defGhcFlag "ddump-parsed"+        (setDumpFlag Opt_D_dump_parsed)+  , make_ord_flag defGhcFlag "ddump-parsed-ast"+        (setDumpFlag Opt_D_dump_parsed_ast)+  , make_ord_flag defGhcFlag "dkeep-comments"+        (NoArg (setGeneralFlag Opt_KeepRawTokenStream))+  , make_ord_flag defGhcFlag "ddump-rn"+        (setDumpFlag Opt_D_dump_rn)+  , make_ord_flag defGhcFlag "ddump-rn-ast"+        (setDumpFlag Opt_D_dump_rn_ast)+  , make_ord_flag defGhcFlag "ddump-simpl"+        (setDumpFlag Opt_D_dump_simpl)+  , make_ord_flag defGhcFlag "ddump-simpl-iterations"+      (setDumpFlag Opt_D_dump_simpl_iterations)+  , make_ord_flag defGhcFlag "ddump-spec"+        (setDumpFlag Opt_D_dump_spec)+  , make_ord_flag defGhcFlag "ddump-spec-constr"+        (setDumpFlag Opt_D_dump_spec_constr)+  , make_ord_flag defGhcFlag "ddump-prep"+        (setDumpFlag Opt_D_dump_prep)+  , make_ord_flag defGhcFlag "ddump-late-cc"+        (setDumpFlag Opt_D_dump_late_cc)+  , make_ord_flag defGhcFlag "ddump-stg-from-core"+        (setDumpFlag Opt_D_dump_stg_from_core)+  , make_ord_flag defGhcFlag "ddump-stg-unarised"+        (setDumpFlag Opt_D_dump_stg_unarised)+  , make_ord_flag defGhcFlag "ddump-stg-final"+        (setDumpFlag Opt_D_dump_stg_final)+  , make_ord_flag defGhcFlag "ddump-stg-cg"+        (setDumpFlag Opt_D_dump_stg_cg)+  , make_dep_flag defGhcFlag "ddump-stg"+        (setDumpFlag Opt_D_dump_stg_from_core)+        "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"+  , make_ord_flag defGhcFlag "ddump-stg-tags"+        (setDumpFlag Opt_D_dump_stg_tags)+  , make_ord_flag defGhcFlag "ddump-stg-from-js-sinker"+        (setDumpFlag Opt_D_dump_stg_from_js_sinker)+  , make_ord_flag defGhcFlag "ddump-call-arity"+        (setDumpFlag Opt_D_dump_call_arity)+  , make_ord_flag defGhcFlag "ddump-exitify"+        (setDumpFlag Opt_D_dump_exitify)+  , make_dep_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_dmdanal)+        "Use `-ddump-dmdanal` instead"+  , make_dep_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+        "Use `-ddump-dmd-signatures` instead"+  , make_ord_flag defGhcFlag "ddump-dmdanal"+        (setDumpFlag Opt_D_dump_dmdanal)+  , make_ord_flag defGhcFlag "ddump-dmd-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+  , make_ord_flag defGhcFlag "ddump-cpranal"+        (setDumpFlag Opt_D_dump_cpranal)+  , make_ord_flag defGhcFlag "ddump-cpr-signatures"+        (setDumpFlag Opt_D_dump_cpr_signatures)+  , make_ord_flag defGhcFlag "ddump-tc"+        (setDumpFlag Opt_D_dump_tc)+  , make_ord_flag defGhcFlag "ddump-tc-ast"+        (setDumpFlag Opt_D_dump_tc_ast)+  , make_ord_flag defGhcFlag "ddump-hie"+        (setDumpFlag Opt_D_dump_hie)+  , make_ord_flag defGhcFlag "ddump-types"+        (setDumpFlag Opt_D_dump_types)+  , make_ord_flag defGhcFlag "ddump-rules"+        (setDumpFlag Opt_D_dump_rules)+  , make_ord_flag defGhcFlag "ddump-cse"+        (setDumpFlag Opt_D_dump_cse)+  , make_ord_flag defGhcFlag "ddump-float-out"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-full-laziness"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-float-in"+        (setDumpFlag Opt_D_dump_float_in)+  , make_ord_flag defGhcFlag "ddump-liberate-case"+        (setDumpFlag Opt_D_dump_liberate_case)+  , make_ord_flag defGhcFlag "ddump-static-argument-transformation"+        (setDumpFlag Opt_D_dump_static_argument_transformation)+  , make_ord_flag defGhcFlag "ddump-worker-wrapper"+        (setDumpFlag Opt_D_dump_worker_wrapper)+  , make_ord_flag defGhcFlag "ddump-rn-trace"+        (setDumpFlag Opt_D_dump_rn_trace)+  , make_ord_flag defGhcFlag "ddump-if-trace"+        (setDumpFlag Opt_D_dump_if_trace)+  , make_ord_flag defGhcFlag "ddump-cs-trace"+        (setDumpFlag Opt_D_dump_cs_trace)+  , make_ord_flag defGhcFlag "ddump-tc-trace"+        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace+                   setDumpFlag' Opt_D_dump_cs_trace))+  , make_ord_flag defGhcFlag "ddump-ec-trace"+        (setDumpFlag Opt_D_dump_ec_trace)+  , make_ord_flag defGhcFlag "ddump-splices"+        (setDumpFlag Opt_D_dump_splices)+  , make_ord_flag defGhcFlag "dth-dec-file"+        (setDumpFlag Opt_D_th_dec_file)++  , make_ord_flag defGhcFlag "ddump-rn-stats"+        (setDumpFlag Opt_D_dump_rn_stats)+  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-simpl-stats"+        (setDumpFlag Opt_D_dump_simpl_stats)+  , make_ord_flag defGhcFlag "ddump-bcos"+        (setDumpFlag Opt_D_dump_BCOs)+  , make_ord_flag defGhcFlag "dsource-stats"+        (setDumpFlag Opt_D_source_stats)+  , make_ord_flag defGhcFlag "dverbose-core2core"+        (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core)+  , make_ord_flag defGhcFlag "dverbose-stg2stg"+        (setDumpFlag Opt_D_verbose_stg2stg)+  , make_ord_flag defGhcFlag "ddump-hi"+        (setDumpFlag Opt_D_dump_hi)+  , make_ord_flag defGhcFlag "ddump-minimal-imports"+        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))+  , make_ord_flag defGhcFlag "ddump-hpc"+        (setDumpFlag Opt_D_dump_ticked) -- back compat+  , make_ord_flag defGhcFlag "ddump-ticked"+        (setDumpFlag Opt_D_dump_ticked)+  , make_ord_flag defGhcFlag "ddump-mod-cycles"+        (setDumpFlag Opt_D_dump_mod_cycles)+  , make_ord_flag defGhcFlag "ddump-mod-map"+        (setDumpFlag Opt_D_dump_mod_map)+  , make_ord_flag defGhcFlag "ddump-timings"+        (setDumpFlag Opt_D_dump_timings)+  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"+        (setDumpFlag Opt_D_dump_view_pattern_commoning)+  , make_ord_flag defGhcFlag "ddump-to-file"+        (NoArg (setGeneralFlag Opt_DumpToFile))+  , make_ord_flag defGhcFlag "ddump-hi-diffs"+        (setDumpFlag Opt_D_dump_hi_diffs)+  , make_ord_flag defGhcFlag "ddump-rtti"+        (setDumpFlag Opt_D_dump_rtti)+  , make_ord_flag defGhcFlag "dlint"+        (NoArg enableDLint)+  , make_ord_flag defGhcFlag "dcore-lint"+        (NoArg (setGeneralFlag Opt_DoCoreLinting))+  , make_ord_flag defGhcFlag "dlinear-core-lint"+        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))+  , make_ord_flag defGhcFlag "dstg-lint"+        (NoArg (setGeneralFlag Opt_DoStgLinting))+  , make_ord_flag defGhcFlag "dcmm-lint"+        (NoArg (setGeneralFlag Opt_DoCmmLinting))+  , make_ord_flag defGhcFlag "dasm-lint"+        (NoArg (setGeneralFlag Opt_DoAsmLinting))+  , make_ord_flag defGhcFlag "dannot-lint"+        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))+  , make_ord_flag defGhcFlag "dtag-inference-checks"+        (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))+  , make_ord_flag defGhcFlag "dshow-passes"+        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dipe-stats"+        (setDumpFlag Opt_D_ipe_stats)+  , make_ord_flag defGhcFlag "dfaststring-stats"+        (setDumpFlag Opt_D_faststring_stats)+  , make_ord_flag defGhcFlag "dno-llvm-mangler"+        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag+  , make_ord_flag defGhcFlag "dno-typeable-binds"+        (NoArg (setGeneralFlag Opt_NoTypeableBinds))+  , make_ord_flag defGhcFlag "ddump-debug"+        (setDumpFlag Opt_D_dump_debug)+  , make_dep_flag defGhcFlag "ddump-json"+        (setDumpFlag Opt_D_dump_json)+        "Use `-fdiagnostics-as-json` instead"+  , make_ord_flag defGhcFlag "dppr-debug"+        (setDumpFlag Opt_D_ppr_debug)+  , make_ord_flag defGhcFlag "ddebug-output"+        (noArg (flip dopt_unset Opt_D_no_debug_output))+  , make_ord_flag defGhcFlag "dno-debug-output"+        (setDumpFlag Opt_D_no_debug_output)+  , make_ord_flag defGhcFlag "ddump-faststrings"+        (setDumpFlag Opt_D_dump_faststrings)++        ------ Machine dependent (-m<blah>) stuff ---------------------------++  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->+                                                  d { sseVersion = Just SSE1 }))+  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->+                                                  d { sseVersion = Just SSE2 }))+  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->+                                                  d { sseVersion = Just SSE3 }))+  , make_ord_flag defGhcFlag "mssse3"       (noArg (\d ->+                                                  d { sseVersion = Just SSSE3 }))+  , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->+                                                  d { sseVersion = Just SSE4 }))+  , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->+                                                 d { sseVersion = Just SSE42 }))+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->+                                                 d { bmiVersion = Just BMI1 }))+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->+                                                 d { bmiVersion = Just BMI2 }))+  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))+  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))+  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->+                                                         d { avx512cd = True }))+  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->+                                                         d { avx512er = True }))+  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))+  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->+                                                         d { avx512pf = True }))+  , make_ord_flag defGhcFlag "mfma"         (noArg (\d -> d { fma = True }))++        ------ Plugin flags ------------------------------------------------+  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)+  , make_ord_flag defGhcFlag "fplugin-trustworthy"+      (NoArg (setGeneralFlag Opt_PluginTrustworthy))+  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)+  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)+  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)++  , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin)++        ------ Optimisation flags ------------------------------------------+  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )+                                                            "Use -O0 instead"+  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->+                                                setOptLevel (mb_n `orElse` 1)))+                -- If the number is missing, use 1++  , make_ord_flag defFlag "fbinary-blob-threshold"+      (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of+                                                    0 -> Nothing+                                                    x -> Just x}))+  , make_ord_flag defFlag "fmax-relevant-binds"+      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))+  , make_ord_flag defFlag "fno-max-relevant-binds"+      (noArg (\d -> d { maxRelevantBinds = Nothing }))++  , make_ord_flag defFlag "fmax-valid-hole-fits"+      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-valid-hole-fits"+      (noArg (\d -> d { maxValidHoleFits = Nothing }))+  , make_ord_flag defFlag "fmax-refinement-hole-fits"+      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-refinement-hole-fits"+      (noArg (\d -> d { maxRefHoleFits = Nothing }))+  , make_ord_flag defFlag "frefinement-level-hole-fits"+      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))+  , make_ord_flag defFlag "fno-refinement-level-hole-fits"+      (noArg (\d -> d { refLevelHoleFits = Nothing }))++  , make_ord_flag defFlag "fwrite-if-compression"+      (intSuffix (\n d -> d { ifCompression = n }))++  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"+            (noArg id)+            "vectors registers are now passed in registers by default."+  , make_ord_flag defFlag "fmax-uncovered-patterns"+      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))+  , make_ord_flag defFlag "fmax-pmcheck-models"+      (intSuffix (\n d -> d { maxPmCheckModels = n }))+  , make_ord_flag defFlag "fsimplifier-phases"+      (intSuffix (\n d -> d { simplPhases = n }))+  , make_ord_flag defFlag "fmax-simplifier-iterations"+      (intSuffix (\n d -> d { maxSimplIterations = n }))+  , (Deprecated, defFlag "fmax-pmcheck-iterations"+      (intSuffixM (\_ d ->+       do { deprecate $ "use -fmax-pmcheck-models instead"+          ; return d })))+  , make_ord_flag defFlag "fsimpl-tick-factor"+      (intSuffix (\n d -> d { simplTickFactor = n }))+  , make_ord_flag defFlag "fdmd-unbox-width"+      (intSuffix (\n d -> d { dmdUnboxWidth = n }))+  , make_ord_flag defFlag "fspec-constr-threshold"+      (intSuffix (\n d -> d { specConstrThreshold = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-threshold"+      (noArg (\d -> d { specConstrThreshold = Nothing }))+  , make_ord_flag defFlag "fspec-constr-count"+      (intSuffix (\n d -> d { specConstrCount = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-count"+      (noArg (\d -> d { specConstrCount = Nothing }))+  , make_ord_flag defFlag "fspec-constr-recursive"+      (intSuffix (\n d -> d { specConstrRecursive = n }))+  , make_ord_flag defFlag "fliberate-case-threshold"+      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))+  , make_ord_flag defFlag "fno-liberate-case-threshold"+      (noArg (\d -> d { liberateCaseThreshold = Nothing }))+  , make_ord_flag defFlag "drule-check"+      (sepArg (\s d -> d { ruleCheck = Just s }))+  , make_ord_flag defFlag "dinline-check"+      (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)}))+  , make_ord_flag defFlag "freduction-depth"+      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))+  , make_ord_flag defFlag "fconstraint-solver-iterations"+      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))+  , make_ord_flag defFlag "fgivens-expansion-fuel"+      (intSuffix (\n d -> d { givensFuel = n }))+  , make_ord_flag defFlag "fwanteds-expansion-fuel"+      (intSuffix (\n d -> d { wantedsFuel = n }))+  , make_ord_flag defFlag "fqcs-expansion-fuel"+      (intSuffix (\n d -> d { qcsFuel = n }))+  , (Deprecated, defFlag "fcontext-stack"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , (Deprecated, defFlag "ftype-function-depth"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , make_ord_flag defFlag "fstrictness-before"+      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))+  , make_ord_flag defFlag "ffloat-lam-args"+      (intSuffix (\n d -> d { floatLamArgs = Just n }))+  , make_ord_flag defFlag "ffloat-all-lams"+      (noArg (\d -> d { floatLamArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args"+      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"+      (noArg (\d -> d { liftLamsRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"+      (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"+      (noArg (\d -> d { liftLamsNonRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = True }))+  , make_ord_flag defFlag "fno-stg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = False }))+  , make_ord_flag defFlag "fproc-alignment"+      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))+  , make_ord_flag defFlag "fblock-layout-weights"+        (HasArg (\s ->+            upd (\d -> d { cfgWeights =+                parseWeights s (cfgWeights d)})))+  , make_ord_flag defFlag "fhistory-size"+      (intSuffix (\n d -> d { historySize = n }))++  , make_ord_flag defFlag "funfolding-creation-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-use-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-fun-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-dict-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))++  , make_ord_flag defFlag "funfolding-case-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-case-scaling"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))++  , make_dep_flag defFlag "funfolding-keeness-factor"+      (floatSuffix (\_ d -> d))+      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"++  , make_ord_flag defFlag "fmax-worker-args"+      (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defFlag "fmax-forced-spec-args"+      (intSuffix (\n d -> d {maxForcedSpecArgs = n}))+  , make_ord_flag defGhciFlag "fghci-hist-size"+      (intSuffix (\n d -> d {ghciHistSize = n}))++  -- wasm ghci browser mode+  , make_ord_flag defGhciFlag "fghci-browser-host"+      $ hasArg $ \f d -> d { ghciBrowserHost = f }+  , make_ord_flag defGhciFlag "fghci-browser-port"+      $ intSuffix $ \n d -> d { ghciBrowserPort = n }+  , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightBrowserType = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightLaunchOpts = Just f }++  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"+      (intSuffix (\n d -> d { maxInlineAllocSize = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"+      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"+      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))+  , make_ord_flag defGhcFlag "dinitial-unique"+      (word64Suffix (\n d -> d { initialUnique = n }))+  , make_ord_flag defGhcFlag "dunique-increment"+      (intSuffix (\n d -> d { uniqueIncrement = n }))++        ------ Profiling ----------------------------------------------------++        -- OLD profiling flags+  , make_dep_flag defGhcFlag "auto-all"+                    (noArg (\d -> d { profAuto = ProfAutoAll } ))+                    "Use -fprof-auto instead"+  , make_dep_flag defGhcFlag "no-auto-all"+                    (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "auto"+                    (noArg (\d -> d { profAuto = ProfAutoExports } ))+                    "Use -fprof-auto-exported instead"+  , make_dep_flag defGhcFlag "no-auto"+            (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "caf-all"+            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fprof-cafs instead"+  , make_dep_flag defGhcFlag "no-caf-all"+            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fno-prof-cafs instead"++        -- NEW profiling flags+  , make_ord_flag defGhcFlag "fprof-auto"+      (noArg (\d -> d { profAuto = ProfAutoAll } ))+  , make_ord_flag defGhcFlag "fprof-auto-top"+      (noArg (\d -> d { profAuto = ProfAutoTop } ))+  , make_ord_flag defGhcFlag "fprof-auto-exported"+      (noArg (\d -> d { profAuto = ProfAutoExports } ))+  , make_ord_flag defGhcFlag "fprof-auto-calls"+      (noArg (\d -> d { profAuto = ProfAutoCalls } ))+  , make_ord_flag defGhcFlag "fno-prof-auto"+      (noArg (\d -> d { profAuto = NoProfAuto } ))++        -- Caller-CC+  , make_ord_flag defGhcFlag "fprof-callers"+         (HasArg setCallerCcFilters)+        ------ Compiler flags -----------------------------------------------++  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))+  , make_ord_flag defGhcFlag "fvia-c"           (NoArg+         (deprecate $ "The -fvia-c flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fvia-C"           (NoArg+         (deprecate $ "The -fvia-C flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend llvmBackend))++  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->+                  d { ghcLink=NoLink }) >> setBackend noBackend))+  , make_ord_flag defFlag "fbyte-code"+      (noArgM $ \dflags -> do+        setBackend interpreterBackend+        pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode))+  , make_ord_flag defFlag "fobject-code"     $ noArgM $ \dflags -> do+      setBackend $ platformDefaultBackend (targetPlatform dflags)+      dflags' <- liftEwM getCmdLineState+      pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode++  , make_dep_flag defFlag "fglasgow-exts"+      (NoArg enableGlasgowExts) "Use individual extensions instead"+  , make_dep_flag defFlag "fno-glasgow-exts"+      (NoArg disableGlasgowExts) "Use individual extensions instead"++        ------ Safe Haskell flags -------------------------------------------+  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)+  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->+                                                    d { safeInfer = False }))+  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))++        ------ position independent flags  ----------------------------------+  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))+  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))++         ------ Debugging flags ----------------------------------------------+  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)+ ]+ ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps+ ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps+ ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps+ ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps+ ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps+ ++++        ------ Warning flags -------------------------------------------------+  [ make_ord_flag defFlag "W"       (NoArg (setWarningGroup W_extra))+  , make_ord_flag defFlag "Werror"+               (NoArg (do { setGeneralFlag Opt_WarnIsError+                          ; setFatalWarningGroup W_everything }))+  , make_ord_flag defFlag "Wwarn"+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError+                          ; unSetFatalWarningGroup W_everything }))+                          -- Opt_WarnIsError is still needed to pass -Werror+                          -- to CPP; see runCpp in SysTools+  , make_dep_flag defFlag "Wnot"    (NoArg (unSetWarningGroup W_everything))+                                             "Use -w or -Wno-everything instead"+  , make_ord_flag defFlag "w"       (NoArg (unSetWarningGroup W_everything))+  ]++     -- New-style uniform warning sets+     --+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything+ ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps+ ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps+ ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag+      [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)]+      -- See Note [Warning categories] in GHC.Unit.Module.Warnings.++ ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-"       unSetCustomWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Werror="    setCustomWErrorFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wwarn="     unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "W"          setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fwarn-"     setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fno-warn-"  unSetCustomWarningFlag)+    ]++     ------ JavaScript flags -----------------------------------------------+ ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))+    , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources))+    ]++     ------ Language flags -------------------------------------------------+ ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps+ ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps+ ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps+ ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps+ ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps++-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@,+-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@).  We+-- define these uniformly for individual warning flags and groups of warnings.+warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning+                -> (warn_flag -> DynP ()) -- ^ Unset the warning+                -> (warn_flag -> DynP ()) -- ^ Make the warning an error+                -> (warn_flag -> DynP ()) -- ^ Clear the error status+                -> [(Deprecation, FlagSpec warn_flag)]+                -> [(Deprecation, Flag (CmdLineP DynFlags))]+warningControls set unset set_werror unset_fatal xs =+    map (mkFlag turnOn  "W"          set             ) xs+ ++ map (mkFlag turnOff "Wno-"       unset           ) xs+ ++ map (mkFlag turnOn  "Werror="    set_werror      ) xs+ ++ map (mkFlag turnOn  "Wwarn="     unset_fatal     ) xs+ ++ map (mkFlag turnOn  "Wno-error=" unset_fatal     ) xs+ ++ map (mkFlag turnOn  "fwarn-"     set   . hideFlag) xs+ ++ map (mkFlag turnOff "fno-warn-"  unset . hideFlag) xs++-- | This is where we handle unrecognised warning flags. If the flag is valid as+-- an extended warning category, we call the supplied action. Otherwise, issue a+-- warning if -Wunrecognised-warning-flags is set. See #11429 for context.+-- See Note [Warning categories] in GHC.Unit.Module.Warnings.+customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags)+customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action)+  where+    action :: String -> DynP ()+    action flag+      | validWarningCategory cat = custom cat+      | otherwise = unrecognised flag+      where+        cat = mkWarningCategory (mkFastString flag)++    unrecognised flag = do+      -- #23402 and #12056+      -- for unrecognised flags we consider current dynflags, not the final one.+      -- But if final state says to not report unrecognised flags, they won't anyway.+      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState+      when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag))++-- See Note [Supporting CLI completion]+package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+package_flags_deps = [+        ------- Packages ----------------------------------------------------+    make_ord_flag defFlag "package-db"+      (HasArg (addPkgDbRef . PkgDbPath))+  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)+  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)+  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)+  , make_ord_flag defFlag "global-package-db"+      (NoArg (addPkgDbRef GlobalPkgDb))+  , make_ord_flag defFlag "user-package-db"+      (NoArg (addPkgDbRef UserPkgDb))+    -- backwards compat with GHC<=7.4 :+  , make_dep_flag defFlag "package-conf"+      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"+  , make_dep_flag defFlag "no-user-package-conf"+      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"+  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->+                                      upd (setUnitId name))+  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)++  , make_ord_flag defGhcFlag "working-dir"       (hasArg setWorkingDirectory)+  , make_ord_flag defGhcFlag "this-package-name"  (hasArg setPackageName)+  , make_ord_flag defGhcFlag "hidden-module"      (HasArg addHiddenModule)+  , make_ord_flag defGhcFlag "reexported-module"  (HasArg addReexportedModule)++  , make_ord_flag defFlag "package"               (HasArg exposePackage)+  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)+  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)+  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)+  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)+  , make_ord_flag defFlag "hide-all-packages"+      (NoArg (setGeneralFlag Opt_HideAllPackages))+  , make_ord_flag defFlag "hide-all-plugin-packages"+      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))+  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)+  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)+  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"+  , make_ord_flag defFlag "distrust-all-packages"+      (NoArg (setGeneralFlag Opt_DistrustAllPackages))+  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)+  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)+  , make_ord_flag defFlag "base-unit-id"          (HasArg setBaseUnitId)+  ]+  where+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }++-- | Make a list of flags for shell completion.+-- Filter all available flags into two groups, for interactive GHC vs all other.+flagsForCompletion :: Bool -> [String]+flagsForCompletion isInteractive+    = [ '-':flagName flag+      | flag <- flagsAll+      , modeFilter (flagGhcMode flag)+      ]+    where+      modeFilter AllModes = True+      modeFilter OnlyGhci = isInteractive+      modeFilter OnlyGhc = not isInteractive+      modeFilter HiddenFlag = False++data FlagSpec flag+   = FlagSpec+       { flagSpecName :: String   -- ^ Flag in string form+       , flagSpecFlag :: flag     -- ^ Flag in internal form+       , flagSpecAction :: (TurnOnFlag -> DynP ())+           -- ^ Extra action to run when the flag is found+           -- Typically, emit a warning or error+       , flagSpecGhcMode :: GhcFlagMode+           -- ^ In which ghc mode the flag has effect+       }++-- | Define a new flag.+flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagSpec name flag = flagSpec' name flag nop++-- | Define a new flag with an effect.+flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+          -> (Deprecation, FlagSpec flag)+flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)++-- | Define a warning flag.+warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec flag = warnSpec' flag nop++-- | Define a warning flag with an effect.+warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ())+          -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes)+                     | name <- NE.toList (warnFlagNames flag)+                     ]++-- | Define a new deprecated flag with an effect.+depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpecOp name flag act dep =+    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))++-- | Define a new deprecated flag.+depFlagSpec :: String -> flag -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpec name flag dep = depFlagSpecOp name flag nop dep++-- | Define a deprecated warning flag.+depWarnSpec :: WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep+                       | name <- NE.toList (warnFlagNames flag)+                       ]++-- | Define a deprecated warning name substituted by another.+subWarnSpec :: String -> WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ]+++-- | Define a new deprecated flag with an effect where the deprecation message+-- depends on the flag value+depFlagSpecOp' :: String+             -> flag+             -> (TurnOnFlag -> DynP ())+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpecOp' name flag act dep =+    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))+                                                                       AllModes)++-- | Define a new deprecated flag where the deprecation message+-- depends on the flag value+depFlagSpec' :: String+             -> flag+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep++-- | Define a new flag for GHCi.+flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagGhciSpec name flag = flagGhciSpec' name flag nop++-- | Define a new flag for GHCi with an effect.+flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+              -> (Deprecation, FlagSpec flag)+flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)++-- | Define a new flag invisible to CLI completion.+flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagHiddenSpec name flag = flagHiddenSpec' name flag nop++-- | Define a new flag invisible to CLI completion with an effect.+flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+                -> (Deprecation, FlagSpec flag)+flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act+                                                                     HiddenFlag)++-- | Hide a 'FlagSpec' from being displayed in @--show-options@.+--+-- This is for example useful for flags that are obsolete, but should not+-- (yet) be deprecated for compatibility reasons.+hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)+hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })++mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on+       -> String                -- ^ The flag prefix+       -> (flag -> DynP ())     -- ^ What to do when the flag is found+       -> (Deprecation, FlagSpec flag)  -- ^ Specification of+                                        -- this particular flag+       -> (Deprecation, Flag (CmdLineP DynFlags))+mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))+    = (dep,+       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)++deprecate :: String -> DynP ()+deprecate s = do+    arg <- getArg+    addFlagWarn (DriverDeprecatedFlag arg s)++deprecatedForExtension :: String -> TurnOnFlag -> String+deprecatedForExtension lang turn_on+    = "use -X" ++ flag +++      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"+    where+      flag | turn_on   = lang+           | otherwise = "No" ++ lang++deprecatedForExtensions :: [String] -> TurnOnFlag -> String+deprecatedForExtensions [] _ = panic "new extension has not been specified"+deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on+deprecatedForExtensions langExts turn_on+    = "use " ++ xExt flags ++ " instead"+    where+      flags | turn_on = langExts+            | otherwise = ("No" ++) <$> langExts++      xExt fls = intercalate " and "  $ (\flag -> "-X" ++ flag) <$> fls++useInstead :: String -> String -> TurnOnFlag -> String+useInstead prefix flag turn_on+  = "Use " ++ prefix ++ no ++ flag ++ " instead"+  where+    no = if turn_on then "" else "no-"++nop :: TurnOnFlag -> DynP ()+nop _ = return ()++-- | Find the 'FlagSpec' for a 'WarningFlag'.+flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)+flagSpecOf = flip Map.lookup wWarningFlagMap++wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)+wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags++-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@+wWarningFlags :: [FlagSpec WarningFlag]+wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)++wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x+  Opt_WarnAmbiguousFields -> warnSpec x+  Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"+  Opt_WarnCPPUndef -> warnSpec x+  Opt_WarnBadlyLevelledTypes ->+    warnSpec x +++    subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types"+  Opt_WarnUnbangedStrictPatterns -> warnSpec x+  Opt_WarnDeferredTypeErrors -> warnSpec x+  Opt_WarnDeferredOutOfScopeVariables -> warnSpec x+  Opt_WarnDeprecatedFlags -> warnSpec x+  Opt_WarnDerivingDefaults -> warnSpec x+  Opt_WarnDerivingTypeable -> warnSpec x+  Opt_WarnDodgyExports -> warnSpec x+  Opt_WarnDodgyForeignImports -> warnSpec x+  Opt_WarnDodgyImports -> warnSpec x+  Opt_WarnEmptyEnumerations -> warnSpec x+  Opt_WarnDuplicateConstraints+    -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"+  Opt_WarnRedundantConstraints -> warnSpec x+  Opt_WarnDuplicateExports -> warnSpec x+  Opt_WarnHiShadows+    -> depWarnSpec x "it is not used, and was never implemented"+  Opt_WarnInaccessibleCode -> warnSpec x+  Opt_WarnImplicitPrelude -> warnSpec x+  Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"+  Opt_WarnIncompletePatterns -> warnSpec x+  Opt_WarnIncompletePatternsRecUpd -> warnSpec x+  Opt_WarnIncompleteUniPatterns -> warnSpec x+  Opt_WarnInconsistentFlags -> warnSpec x+  Opt_WarnInlineRuleShadowing -> warnSpec x+  Opt_WarnIdentities -> warnSpec x+  Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error"+  Opt_WarnMissingFields -> warnSpec x+  Opt_WarnMissingImportList -> warnSpec x+  Opt_WarnMissingExportList -> warnSpec x+  Opt_WarnMissingLocalSignatures+    -> subWarnSpec "missing-local-sigs" x+                   "it is replaced by -Wmissing-local-signatures"+       ++ warnSpec x+  Opt_WarnMissingMethods -> warnSpec x+  Opt_WarnMissingMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid"+  Opt_WarnMissingSignatures -> warnSpec x+  Opt_WarnMissingKindSignatures -> warnSpec x+  Opt_WarnMissingPolyKindSignatures -> warnSpec x+  Opt_WarnMissingExportedSignatures+    -> subWarnSpec "missing-exported-sigs" x+                   "it is replaced by -Wmissing-exported-signatures"+       ++ warnSpec x+  Opt_WarnMonomorphism -> warnSpec x+  Opt_WarnNameShadowing -> warnSpec x+  Opt_WarnNonCanonicalMonadInstances -> warnSpec x+  Opt_WarnNonCanonicalMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnNonCanonicalMonoidInstances -> warnSpec x+  Opt_WarnOrphans -> warnSpec x+  Opt_WarnOverflowedLiterals -> warnSpec x+  Opt_WarnOverlappingPatterns -> warnSpec x+  Opt_WarnMissedSpecs -> warnSpec x+  Opt_WarnAllMissedSpecs -> warnSpec x+  Opt_WarnSafe -> warnSpec' x setWarnSafe+  Opt_WarnTrustworthySafe -> warnSpec x+  Opt_WarnInferredSafeImports -> warnSpec x+  Opt_WarnMissingSafeHaskellMode -> warnSpec x+  Opt_WarnTabs -> warnSpec x+  Opt_WarnTypeDefaults -> warnSpec x+  Opt_WarnTypedHoles -> warnSpec x+  Opt_WarnPartialTypeSignatures -> warnSpec x+  Opt_WarnUnrecognisedPragmas -> warnSpec x+  Opt_WarnMisplacedPragmas -> warnSpec x+  Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe+  Opt_WarnUnsupportedCallingConventions -> warnSpec x+  Opt_WarnUnsupportedLlvmVersion -> warnSpec x+  Opt_WarnMissedExtraSharedLib -> warnSpec x+  Opt_WarnUntickedPromotedConstructors -> warnSpec x+  Opt_WarnUnusedDoBind -> warnSpec x+  Opt_WarnUnusedForalls -> warnSpec x+  Opt_WarnUnusedImports -> warnSpec x+  Opt_WarnUnusedLocalBinds -> warnSpec x+  Opt_WarnUnusedMatches -> warnSpec x+  Opt_WarnUnusedPatternBinds -> warnSpec x+  Opt_WarnUnusedTopBinds -> warnSpec x+  Opt_WarnUnusedTypePatterns -> warnSpec x+  Opt_WarnUnusedRecordWildcards -> warnSpec x+  Opt_WarnRedundantBangPatterns -> warnSpec x+  Opt_WarnRedundantRecordWildcards -> warnSpec x+  Opt_WarnRedundantStrictnessFlags -> warnSpec x+  Opt_WarnWrongDoBind -> warnSpec x+  Opt_WarnMissingPatternSynonymSignatures -> warnSpec x+  Opt_WarnMissingDerivingStrategies -> warnSpec x+  Opt_WarnSimplifiableClassConstraints -> warnSpec x+  Opt_WarnMissingHomeModules -> warnSpec x+  Opt_WarnUnrecognisedWarningFlags -> warnSpec x+  Opt_WarnStarBinder -> warnSpec x+  Opt_WarnStarIsType -> warnSpec x+  Opt_WarnSpaceAfterBang+    -> depWarnSpec x "bang patterns can no longer be written with a space"+  Opt_WarnPartialFields -> warnSpec x+  Opt_WarnPrepositiveQualifiedModule -> warnSpec x+  Opt_WarnUnusedPackages -> warnSpec x+  Opt_WarnCompatUnqualifiedImports ->+    depWarnSpec x "This warning no longer does anything; see GHC #24904"+  Opt_WarnInvalidHaddock -> warnSpec x+  Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x+  Opt_WarnOperatorWhitespace -> warnSpec x+  Opt_WarnImplicitLift -> warnSpec x+  Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x+  Opt_WarnForallIdentifier+    -> depWarnSpec x "forall is no longer a valid identifier"+  Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x+  Opt_WarnGADTMonoLocalBinds -> warnSpec x+  Opt_WarnTypeEqualityOutOfScope -> warnSpec x+  Opt_WarnTypeEqualityRequiresOperators -> warnSpec x+  Opt_WarnTermVariableCapture -> warnSpec x+  Opt_WarnMissingRoleAnnotations -> warnSpec x+  Opt_WarnImplicitRhsQuantification -> warnSpec x+  Opt_WarnIncompleteExportWarnings -> warnSpec x+  Opt_WarnIncompleteRecordSelectors -> warnSpec x+  Opt_WarnDataKindsTC+    -> depWarnSpec x "DataKinds violations are now always an error"+  Opt_WarnDefaultedExceptionContext -> warnSpec x+  Opt_WarnViewPatternSignatures -> warnSpec x+  Opt_WarnUselessSpecialisations -> warnSpec x+  Opt_WarnDeprecatedPragmas -> warnSpec x+  Opt_WarnRuleLhsEqualities -> warnSpec x+  Opt_WarnUnusableUnpackPragmas -> warnSpec x+  Opt_WarnPatternNamespaceSpecifier -> warnSpec x++warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]+warningGroupsDeps = map mk warningGroups+  where+    mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes)++-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@+negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+negatableFlagsDeps = [+  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]++-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@+dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+dFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,+  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks+     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),+  flagSpec "suppress-ticks"             Opt_SuppressTicks,+  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts+     (useInstead "-d" "suppress-stg-exts"),+  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,+  flagSpec "suppress-stg-reps"          Opt_SuppressStgReps,+  flagSpec "suppress-coercions"         Opt_SuppressCoercions,+  flagSpec "suppress-coercion-types"    Opt_SuppressCoercionTypes,+  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,+  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,+  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,+  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,+  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,+  flagSpec "suppress-uniques"           Opt_SuppressUniques,+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds,+  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fFlags :: [FlagSpec GeneralFlag]+fFlags = map snd fFlagsDeps++fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+fFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,+  flagGhciSpec "break-on-error"               Opt_BreakOnError,+  flagGhciSpec "break-on-exception"           Opt_BreakOnException,+  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,+  flagSpec "call-arity"                       Opt_CallArity,+  flagSpec "exitification"                    Opt_Exitification,+  flagSpec "case-merge"                       Opt_CaseMerge,+  flagSpec "case-folding"                     Opt_CaseFolding,+  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,+  flagSpec "cmm-sink"                         Opt_CmmSink,+  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,+  flagSpec "cse"                              Opt_CSE,+  flagSpec "stg-cse"                          Opt_StgCSE,+  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,+  flagSpec "cpr-anal"                         Opt_CprAnal,+  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,+  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,+  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,+  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "diagnostics-as-json"              Opt_DiagnosticsAsJSON,+  -- With-ways needs to be reversible hence why its made via flagSpec unlike+  -- other debugging flags.+  flagSpec "dump-with-ways"                   Opt_DumpWithWays,+  flagSpec "dicts-cheap"                      Opt_DictsCheap,+  flagSpec "dicts-strict"                     Opt_DictsStrict,+  depFlagSpec "dmd-tx-dict-sel"+      Opt_DmdTxDictSel "effect is now unconditionally enabled",+  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,+  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "do-clever-arg-eta-expansion"      Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep]+  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "orig-thunk-info"                  Opt_OrigThunkInfo,+  flagSpec "embed-manifest"                   Opt_EmbedManifest,+  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,+  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,+  flagSpec "error-spans"                      Opt_ErrorSpans,+  flagSpec "excess-precision"                 Opt_ExcessPrecision,+  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "expose-overloaded-unfoldings"     Opt_ExposeOverloadedUnfoldings,+  flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,+  flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,+  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,+  flagSpec "family-application-cache"         Opt_FamAppCache,+  flagSpec "float-in"                         Opt_FloatIn,+  flagSpec "force-recomp"                     Opt_ForceRecomp,+  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,+  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,+  flagSpec "full-laziness"                    Opt_FullLaziness,+  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk+      (useInstead "-f" "full-laziness"),+  flagSpec "local-float-out"                  Opt_LocalFloatOut,+  flagSpec "local-float-out-top-level"        Opt_LocalFloatOutTopLevel,+  flagSpec "gen-manifest"                     Opt_GenManifest,+  flagSpec "ghci-history"                     Opt_GhciHistory,+  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "inter-module-far-jumps"               Opt_InterModuleFarJumps,+  flagSpec "validate-ide-info"                Opt_ValidateHie,+  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,+  flagGhciSpec "no-it"                        Opt_NoIt,+  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,++  -- wasm ghci browser mode+  flagGhciSpec "ghci-browser"                 Opt_GhciBrowser,+  flagGhciSpec "ghci-browser-redirect-wasi-console" Opt_GhciBrowserRedirectWasiConsole,++  -- load all targets on GHCi startup+  flagGhciSpec "load-initial-targets"         Opt_GhciDoLoadTargets,++  flagSpec "helpful-errors"                   Opt_HelpfulErrors,+  flagSpec "hpc"                              Opt_Hpc,+  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,+  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,+  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,+  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,+  flagSpec "keep-going"                       Opt_KeepGoing,+  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,+  flagSpec "late-specialise"                  Opt_LateSpecialise,+  flagSpec "liberate-case"                    Opt_LiberateCase,+  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,+  flagSpec "loopification"                    Opt_Loopification,+  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,+  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,+  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,+  flagSpec "omit-yields"                      Opt_OmitYields,+  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,+  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,+  flagSpec "pre-inlining"                     Opt_SimplPreInlining,+  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,+  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,+  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,+  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,+  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,+  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,+  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,+  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,+  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,+  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,+  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,+  flagSpec "print-redundant-promotion-ticks"  Opt_PrintRedundantPromotionTicks,+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,+  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,+  flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "prof-late"                        Opt_ProfLateCcs,+  flagSpec "prof-late-overloaded"             Opt_ProfLateOverloadedCcs,+  flagSpec "prof-late-overloaded-calls"       Opt_ProfLateoverloadedCallsCCs,+  flagSpec "prof-manual"                      Opt_ProfManualCcs,+  flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,+  flagSpec "regs-graph"                       Opt_RegsGraph,+  flagSpec "regs-iterative"                   Opt_RegsIterative,+  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules+   (useInstead "-f" "enable-rewrite-rules"),+  flagSpec "shared-implib"                    Opt_SharedImplib,+  flagSpec "spec-constr"                      Opt_SpecConstr,+  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,+  flagSpec "specialise"                       Opt_Specialise,+  flagSpec "specialize"                       Opt_Specialise,+  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,+  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "polymorphic-specialisation"       Opt_PolymorphicSpecialisation,+  flagSpec "specialise-incoherents"           Opt_SpecialiseIncoherents,+  flagSpec "inline-generics"                  Opt_InlineGenerics,+  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,+  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,+  flagSpec "strictness"                       Opt_Strictness,+  flagSpec "use-rpaths"                       Opt_RPath,+  flagSpec "write-interface"                  Opt_WriteInterface,+  flagSpec "write-if-simplified-core"         Opt_WriteIfSimplifiedCore,+  flagSpec "write-if-self-recomp"             Opt_WriteSelfRecompInfo,+  flagSpec "write-if-self-recomp-flags"       Opt_WriteSelfRecompFlags,+  flagSpec "write-ide-info"                   Opt_WriteHie,+  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,+  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,+  flagSpec "unoptimized-core-for-interpreter" Opt_UnoptimizedCoreForInterpreter,+  flagSpec "version-macros"                   Opt_VersionMacros,+  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments]+  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,+  flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,+  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,+  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,+  flagSpec "add-bco-name"                     Opt_AddBcoName,+  flagSpec "num-constant-folding"             Opt_NumConstantFolding,+  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,+  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,+  flagSpec "spec-eval"                        Opt_SpecEval,+  flagSpec "spec-eval-dictfun"                Opt_SpecEvalDictFun,+  flagSpec "cmm-control-flow"                 Opt_CmmControlFlow,+  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,+  flagSpec "hide-source-paths"                Opt_HideSourcePaths,+  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,+  flagSpec "keep-cafs"                        Opt_KeepCAFs,+  flagSpec "link-rts"                         Opt_LinkRts,+  flagSpec "byte-code-and-object-code"        Opt_ByteCodeAndObjectCode,+  flagSpec "prefer-byte-code"                 Opt_UseBytecodeRatherThanObjects,+  flagSpec "object-determinism"               Opt_ObjectDeterminism,+  flagSpec' "compact-unwind"                  Opt_CompactUnwind+      (\turn_on -> updM (\dflags -> do+        unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)+               (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")+        return dflags)),+  flagSpec "show-error-context"               Opt_ShowErrorContext,+  flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,+  flagSpec "split-sections"                   Opt_SplitSections,+  flagSpec "break-points"                     Opt_InsertBreakpoints,+  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,+  flagSpec "info-table-map"                   Opt_InfoTableMap,+  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,+  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback+  ]+  ++ fHoleFlags++-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or+-- the valid hole fits in that message. See Note [Valid hole fits include ...]+-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with+-- @-fno-\<blah\>@+fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]+fHoleFlags = [+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,+  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits+   (useInstead "-f" "show-valid-hole-fits"),+  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,+  -- Sorting settings+  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,+  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,+  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,+  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,+  -- Output format settings+  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,+  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,+  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,+  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,+  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,+  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fLangFlags :: [FlagSpec LangExt.Extension]+fLangFlags = map snd fLangFlagsDeps++fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+fLangFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  depFlagSpecOp' "th"                           LangExt.TemplateHaskell+    checkTemplateHaskellOk+    (deprecatedForExtension "TemplateHaskell"),+  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "arrows"                         LangExt.Arrows+    (deprecatedForExtension "Arrows"),+  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude+    (deprecatedForExtension "ImplicitPrelude"),+  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns+    (deprecatedForExtension "BangPatterns"),+  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction+    (deprecatedForExtension "MonomorphismRestriction"),+  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules+    (deprecatedForExtension "ExtendedDefaultRules"),+  depFlagSpec' "implicit-params"                LangExt.ImplicitParams+    (deprecatedForExtension "ImplicitParams"),+  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances+    (deprecatedForExtension "OverlappingInstances"),+  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances+    (deprecatedForExtension "UndecidableInstances"),+  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances+    (deprecatedForExtension "IncoherentInstances")+  ]++supportedLanguages :: [String]+supportedLanguages = map (flagSpecName . snd) languageFlagsDeps++supportedLanguageOverlays :: [String]+supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps++supportedExtensions :: ArchOS -> [String]+supportedExtensions (ArchOS arch os) = concatMap toFlagSpecNamePair xFlags+  where+    toFlagSpecNamePair flg+      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits+      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the+      -- box. See also GHC #11102 and #16331 for more details about+      -- the rationale+      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]+      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]+      -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend+      | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName]+      | otherwise = [name, noName]+      where+        isAIX = os == OSAIX+        notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ]+        noName = "No" ++ name+        name = flagSpecName flg++supportedLanguagesAndExtensions :: ArchOS -> [String]+supportedLanguagesAndExtensions arch_os =+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+languageFlagsDeps :: [(Deprecation, FlagSpec Language)]+languageFlagsDeps = [+  flagSpec "Haskell98"   Haskell98,+  flagSpec "Haskell2010" Haskell2010,+  flagSpec "GHC2021"     GHC2021,+  flagSpec "GHC2024"     GHC2024+  ]++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+-- They are used to place hard requirements on what GHC Haskell language+-- features can be used.+safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]+safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]+    where mkF flag = flagSpec (show flag) flag++-- | These -X<blah> flags can all be reversed with -XNo<blah>+xFlags :: [FlagSpec LangExt.Extension]+xFlags = map snd xFlagsDeps++makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)]+makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ]++xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound]++makeExtensionFlag :: String -> ExtensionDeprecation -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension)+makeExtensionFlag name depr ext = (deprecation depr, spec)+  where effect = extensionEffect ext+        spec = FlagSpec name ext (\f -> effect f >> act f) AllModes+        act = case depr of+                ExtensionNotDeprecated -> nop+                ExtensionDeprecatedFor xs+                  -> deprecate . deprecatedForExtensions (map extensionName xs)+                ExtensionFlagDeprecatedCond cond str+                  -> \f -> when (f == cond) (deprecate str)+                ExtensionFlagDeprecated str+                  -> const (deprecate str)++extensionEffect :: LangExt.Extension -> (TurnOnFlag -> DynP ())+extensionEffect = \case+  LangExt.TemplateHaskell+    -> checkTemplateHaskellOk+  LangExt.OverlappingInstances+    -> setOverlappingInsts+  LangExt.GeneralizedNewtypeDeriving+    -> setGenDeriving+  LangExt.IncoherentInstances+    -> setIncoherentInsts+  LangExt.DerivingVia+    -> setDeriveVia+  _ -> nop++-- | Things you get with `-dlint`.+enableDLint :: DynP ()+enableDLint = do+    mapM_ setGeneralFlag dLintFlags+    addWayDynP WayDebug+  where+    dLintFlags :: [GeneralFlag]+    dLintFlags =+        [ Opt_DoCoreLinting+        , Opt_DoStgLinting+        , Opt_DoCmmLinting+        , Opt_DoAsmLinting+        , Opt_CatchNonexhaustiveCases+        , Opt_LlvmFillUndefWithGarbage+        ]++enableGlasgowExts :: DynP ()+enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls+                       mapM_ setExtensionFlag glasgowExtsFlags++disableGlasgowExts :: DynP ()+disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls+                        mapM_ unSetExtensionFlag glasgowExtsFlags+++setWarnSafe :: Bool -> DynP ()+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })+setWarnSafe False = return ()++setWarnUnsafe :: Bool -> DynP ()+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })+setWarnUnsafe False = return ()++setPackageTrust :: DynP ()+setPackageTrust = do+    setGeneralFlag Opt_PackageTrust+    l <- getCurLoc+    upd $ \d -> d { pkgTrustOnLoc = l }++setGenDeriving :: TurnOnFlag -> DynP ()+setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })+setGenDeriving False = return ()++setDeriveVia :: TurnOnFlag -> DynP ()+setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })+setDeriveVia False = return ()++setOverlappingInsts :: TurnOnFlag -> DynP ()+setOverlappingInsts False = return ()+setOverlappingInsts True = do+  l <- getCurLoc+  upd (\d -> d { overlapInstLoc = l })++setIncoherentInsts :: TurnOnFlag -> DynP ()+setIncoherentInsts False = return ()+setIncoherentInsts True = do+  l <- getCurLoc+  upd (\d -> d { incoherentOnLoc = l })++checkTemplateHaskellOk :: TurnOnFlag -> DynP ()+checkTemplateHaskellOk _turn_on+  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })++{- **********************************************************************+%*                                                                      *+                DynFlags constructors+%*                                                                      *+%********************************************************************* -}++type DynP = EwM (CmdLineP DynFlags)++upd :: (DynFlags -> DynFlags) -> DynP ()+upd f = liftEwM (do dflags <- getCmdLineState+                    putCmdLineState $! f dflags)++updM :: (DynFlags -> DynP DynFlags) -> DynP ()+updM f = do dflags <- liftEwM getCmdLineState+            dflags' <- f dflags+            liftEwM $ putCmdLineState $! dflags'++--------------- Constructor functions for OptKind -----------------+noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+noArg fn = NoArg (upd fn)++noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+noArgM fn = NoArg (updM fn)++hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+hasArg fn = HasArg (upd . fn)++sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+sepArg fn = SepArg (upd . fn)++intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffix fn = IntSuffix (\n -> upd (fn n))++intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffixM fn = IntSuffix (\n -> updM (fn n))++word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+word64Suffix fn = Word64Suffix (\n -> upd (fn n))++floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+floatSuffix fn = FloatSuffix (\n -> upd (fn n))++optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)+              -> OptKind (CmdLineP DynFlags)+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))++setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)+setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)++--------------------------+addWayDynP :: Way -> DynP ()+addWayDynP = upd . addWay'++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 =+   let platform = targetPlatform dflags0+       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }+       dflags2 = foldr setGeneralFlag' dflags1+                       (wayGeneralFlags platform w)+       dflags3 = foldr unSetGeneralFlag' dflags2+                       (wayUnsetGeneralFlags platform w)+   in dflags3++removeWayDynP :: Way -> DynP ()+removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) })++--------------------------+setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()+setGeneralFlag   f = upd (setGeneralFlag' f)+unSetGeneralFlag f = upd (unSetGeneralFlag' f)++setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag'   d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedGFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setGeneralFlag recursively, in case the implied flags+        --     implies further flags++unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag' d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]+   -- In general, when you un-set f, we don't un-set the things it implies.+   -- There are however some exceptions, e.g., -fno-strictness implies+   -- -fno-worker-wrapper.+   --+   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags+   --     imply further flags.++--------------------------+setWarningGroup :: WarningGroup -> DynP ()+setWarningGroup g = do+    mapM_ setWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom++unSetWarningGroup :: WarningGroup -> DynP ()+unSetWarningGroup g = do+    mapM_ unSetWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom++setWErrorWarningGroup :: WarningGroup -> DynP ()+setWErrorWarningGroup g =+  do { setWarningGroup g+     ; setFatalWarningGroup g }++setFatalWarningGroup :: WarningGroup -> DynP ()+setFatalWarningGroup g = do+    mapM_ setFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom++unSetFatalWarningGroup :: WarningGroup -> DynP ()+unSetFatalWarningGroup g = do+    mapM_ unSetFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom+++setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()+setWarningFlag   f = upd (\dfs -> wopt_set dfs f)+unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)++setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)++setWErrorFlag :: WarningFlag -> DynP ()+setWErrorFlag flag =+  do { setWarningFlag flag+     ; setFatalWarningFlag flag }+++setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP ()+setCustomWarningFlag   f = upd (\dfs -> wopt_set_custom dfs f)+unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f)++setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP ()+setCustomFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal_custom dfs f)+unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f)++setCustomWErrorFlag :: WarningCategory -> DynP ()+setCustomWErrorFlag flag =+  do { setCustomWarningFlag flag+     ; setCustomFatalWarningFlag flag }+++--------------------------+setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()+setExtensionFlag f = upd (setExtensionFlag' f)+unSetExtensionFlag f = upd (unSetExtensionFlag' f)++setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags+setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps+  where+    deps :: [DynFlags -> DynFlags]+    deps = [ setExtension d+           | (f', d) <- impliedXFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setExtensionFlag recursively, in case the implied flags+        --     implies further flags++    setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags+    setExtension = \ case+      On extension -> setExtensionFlag' extension+      Off extension -> unSetExtensionFlag' extension++unSetExtensionFlag' f dflags = xopt_unset dflags f+   -- When you un-set f, however, we don't un-set the things it implies+   --      (except for -fno-glasgow-exts, which is treated specially)++--------------------------++alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags+alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }++--------------------------+setDumpFlag' :: DumpFlag -> DynP ()+setDumpFlag' dump_flag+  = do upd (\dfs -> dopt_set dfs dump_flag)+       when want_recomp forceRecompile+    where -- Certain dumpy-things are really interested in what's going+          -- on during recompilation checking, so in those cases we+          -- don't want to turn it off.+          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,+                                             Opt_D_dump_hi_diffs,+                                             Opt_D_no_debug_output]++forceRecompile :: DynP ()+-- Whenever we -ddump, force recompilation (by switching off the+-- recompilation checker), else you don't see the dump! However,+-- don't switch it off in --make mode, else *everything* gets+-- recompiled which probably isn't what you want+forceRecompile = do dfs <- liftEwM getCmdLineState+                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)+        where+          force_recomp dfs = isOneShot (ghcMode dfs)+++setVerbosity :: Maybe Int -> DynP ()+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })++setDebugLevel :: Maybe Int -> DynP ()+setDebugLevel mb_n =+  upd (\dfs -> exposeSyms $ dfs{ debugLevel = n })+  where+    n = mb_n `orElse` 2+    exposeSyms+      | n > 2     = setGeneralFlag' Opt_ExposeInternalSymbols+      | otherwise = id++addPkgDbRef :: PkgDbRef -> DynP ()+addPkgDbRef p = upd $ \s ->+  s { packageDBFlags = PackageDB p : packageDBFlags s }++removeUserPkgDb :: DynP ()+removeUserPkgDb = upd $ \s ->+  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }++removeGlobalPkgDb :: DynP ()+removeGlobalPkgDb = upd $ \s ->+ s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }++clearPkgDb :: DynP ()+clearPkgDb = upd $ \s ->+  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }++parsePackageFlag :: String                 -- the flag+                 -> ReadP PackageArg       -- type of argument+                 -> String                 -- string to parse+                 -> PackageFlag+parsePackageFlag flag arg_parse str+ = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)+  where doc = flag ++ " " ++ str+        parse = do+            pkg_arg <- tok arg_parse+            let mk_expose = ExposePackage doc pkg_arg+            ( do _ <- tok $ string "with"+                 fmap (mk_expose . ModRenaming True) parseRns+             <++ fmap (mk_expose . ModRenaming False) parseRns+             <++ return (mk_expose (ModRenaming True [])))+        parseRns = do _ <- tok $ R.char '('+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')+                      _ <- tok $ R.char ')'+                      return rns+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (orig, new)+              ++++             return (orig, orig))+        tok m = m >>= \x -> skipSpaces >> return x++exposePackage, exposePackageId, hidePackage,+        exposePluginPackage, exposePluginPackageId,+        ignorePackage,+        trustPackage, distrustPackage :: String -> DynP ()+exposePackage p = upd (exposePackage' p)+exposePackageId p =+  upd (\s -> s{ packageFlags =+    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })+exposePluginPackage p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })+exposePluginPackageId p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })+hidePackage p =+  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })+ignorePackage p =+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })++trustPackage p = exposePackage p >> -- both trust and distrust also expose a package+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })+distrustPackage p = exposePackage p >>+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })++exposePackage' :: String -> DynFlags -> DynFlags+exposePackage' p dflags+    = dflags { packageFlags =+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }++parsePackageArg :: ReadP PackageArg+parsePackageArg =+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))++parseUnitArg :: ReadP PackageArg+parseUnitArg =+    fmap UnitIdArg parseUnit++setUnitId :: String -> DynFlags -> DynFlags+setUnitId p d = d { homeUnitId_ = stringToUnitId p }++setHomeUnitId :: UnitId -> DynFlags -> DynFlags+setHomeUnitId p d = d { homeUnitId_ = p }++setWorkingDirectory :: String -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory =  Just p }++{-+Note [Filepaths and Multiple Home Units]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is common to assume that a package is compiled in the directory where its+cabal file resides. Thus, all paths used in the compiler are assumed to be relative+to this directory. When there are multiple home units the compiler is often+not operating in the standard directory and instead where the cabal.project+file is located. In this case the `-working-dir` option can be passed which specifies+the path from the current directory to the directory the unit assumes to be it's root,+normally the directory which contains the cabal file.++When the flag is passed, any relative paths used by the compiler are offset+by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and+the location of input files.++-}++augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath+augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp+augmentByWorkingDirectory _ fp = fp++setPackageName :: String -> DynFlags -> DynFlags+setPackageName p d = d { thisPackageName =  Just p }++addHiddenModule :: String -> DynP ()+addHiddenModule p =+  upd (\s -> s{ hiddenModules  = Set.insert (mkModuleName p) (hiddenModules s) })++addReexportedModule :: String -> DynP ()+addReexportedModule p =+  upd (\s -> s{ reexportedModules  = (parseReexportedModule p) : (reexportedModules s) })++parseReexportedModule :: String                 -- string to parse+                      -> ReexportedModule+parseReexportedModule str+ = case filter ((=="").snd) (readP_to_S parseItem str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str)+  where+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (ReexportedModule orig new))+              ++++             return (ReexportedModule orig orig)++        tok m = m >>= \x -> skipSpaces >> return x+++-- If we're linking a binary, then only backends that produce object+-- code are allowed (requests for other target types are ignored).+setBackend :: Backend -> DynP ()+setBackend l = upd $ \ dfs ->+  if ghcLink dfs /= LinkBinary || backendWritesFiles l+  then dfs{ backend = l }+  else dfs++-- Changes the target only if we're compiling object code.  This is+-- used by -fasm and -fllvm, which switch from one to the other, but+-- not from bytecode to object-code.  The idea is that -fasm/-fllvm+-- can be safely used in an OPTIONS_GHC pragma.+setObjBackend :: Backend -> DynP ()+setObjBackend l = updM set+  where+   set dflags+     | backendWritesFiles (backend dflags)+       = return $ dflags { backend = l }+     | otherwise = return dflags++setOptLevel :: Int -> DynFlags -> DynP DynFlags+setOptLevel n dflags = return (updOptLevel n dflags)++setCallerCcFilters :: String -> DynP ()+setCallerCcFilters arg =+  case parseCallerCcFilter arg of+    Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d }+    Left err -> addErr err++setMainIs :: String -> DynP ()+setMainIs arg = parse parse_main_f arg+  where+    parse callback str = case unP parseIdentifier (p_state str) of+      PFailed _      -> addErr $ "Can't parse -main-is \"" ++ arg ++ "\" as an identifier or module."+      POk _ (L _ re) -> callback re++    -- dummy parser state.+    p_state str = initParserState+              (mkParserOpts mempty emptyDiagOpts False False False True)+              (stringToStringBuffer str)+              (mkRealSrcLoc (mkFastString []) 1 1)++    parse_main_f (Unqual occ)+      | isVarOcc occ = upd $ \d -> d { mainFunIs = main_f occ }+    parse_main_f (Qual (ModuleName mod) occ)+      | isVarOcc occ = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod+                                     , mainFunIs = main_f occ }+    -- append dummy "function" to parse A.B as the module A.B+    -- and not the Data constructor B from the module A+    parse_main_f _ = parse parse_mod (arg ++ ".main")++    main_f = Just . occNameString++    parse_mod (Qual (ModuleName mod) _) = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod }+    -- we appended ".m" and any parse error was caught. We are Qual or something went very wrong+    parse_mod _ = error "unreachable"++addLdInputs :: Option -> DynFlags -> DynFlags+addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}++-- -----------------------------------------------------------------------------+-- Load dynflags from environment files.++setFlagsFromEnvFile :: FilePath -> String -> DynP ()+setFlagsFromEnvFile envfile content = do+  setGeneralFlag Opt_HideAllPackages+  parseEnvFile envfile content++parseEnvFile :: FilePath -> String -> DynP ()+parseEnvFile envfile = mapM_ parseEntry . lines+  where+    parseEntry str = case words str of+      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))+        -- relative package dbs are interpreted relative to the env file+        where envdir = takeDirectory envfile+              db     = drop 11 str+      ["clear-package-db"]  -> clearPkgDb+      ["hide-package", pkg]  -> hidePackage pkg+      ["global-package-db"] -> addPkgDbRef GlobalPkgDb+      ["user-package-db"]   -> addPkgDbRef UserPkgDb+      ["package-id", pkgid] -> exposePackageId pkgid+      (('-':'-':_):_)       -> return () -- comments+      -- and the original syntax introduced in 7.10:+      [pkgid]               -> exposePackageId pkgid+      []                    -> return ()+      _                     -> throwGhcException $ CmdLineError $+                                    "Can't parse environment file entry: "+                                 ++ envfile ++ ": " ++ str+++-----------------------------------------------------------------------------+-- Paths & Libraries++addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()++-- -i on its own deletes the import paths+addImportPath "" = upd (\s -> s{importPaths = []})+addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})++addLibraryPath p =+  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})++addIncludePath p =+  upd (\s -> s{includePaths =+                  addGlobalInclude (includePaths s) (splitPathList p)})++addFrameworkPath p =+  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})++#if !defined(mingw32_HOST_OS)+split_marker :: Char+split_marker = ':'   -- not configurable (ToDo)+#endif++splitPathList :: String -> [String]+splitPathList s = filter notNull (splitUp s)+                -- empty paths are ignored: there might be a trailing+                -- ':' in the initial list, for example.  Empty paths can+                -- cause confusion when they are translated into -I options+                -- for passing to gcc.+  where+#if !defined(mingw32_HOST_OS)+    splitUp xs = split split_marker xs+#else+     -- Windows: 'hybrid' support for DOS-style paths in directory lists.+     --+     -- That is, if "foo:bar:baz" is used, this interpreted as+     -- consisting of three entries, 'foo', 'bar', 'baz'.+     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted+     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"+     --+     -- Notice that no attempt is made to fully replace the 'standard'+     -- split marker ':' with the Windows / DOS one, ';'. The reason being+     -- that this will cause too much breakage for users & ':' will+     -- work fine even with DOS paths, if you're not insisting on being silly.+     -- So, use either.+    splitUp []             = []+    splitUp (x:':':div:xs) | div `elem` dir_markers+                           = ((x:':':div:p): splitUp rs)+                           where+                              (p,rs) = findNextPath xs+          -- we used to check for existence of the path here, but that+          -- required the IO monad to be threaded through the command-line+          -- parser which is quite inconvenient.  The+    splitUp xs = cons p (splitUp rs)+               where+                 (p,rs) = findNextPath xs++                 cons "" xs = xs+                 cons x  xs = x:xs++    -- will be called either when we've consumed nought or the+    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of+    -- finding the next split marker.+    findNextPath xs =+        case break (`elem` split_markers) xs of+           (p, _:ds) -> (p, ds)+           (p, xs)   -> (p, xs)++    split_markers :: [Char]+    split_markers = [':', ';']++    dir_markers :: [Char]+    dir_markers = ['/', '\\']+#endif++-- -----------------------------------------------------------------------------+-- tmpDir, where we store temporary files.++setTmpDir :: FilePath -> DynFlags -> DynFlags+setTmpDir dir d = d { tmpDir = TempDir (normalise dir) }+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't+  -- seem necessary now --SDM 7/2/2008++-----------------------------------------------------------------------------+-- RTS opts++setRtsOpts :: String -> DynP ()+setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}++setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}++-----------------------------------------------------------------------------+-- Hpc stuff++setOptHpcDir :: String -> DynP ()+setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}++-----------------------------------------------------------------------------+-- Via-C compilation stuff++-- There are some options that we need to pass to gcc when compiling+-- Haskell code via C, but are only supported by recent versions of+-- gcc.  The configure script decides which of these options we need,+-- and puts them in the "settings" file in $topdir. The advantage of+-- having these in a separate file is that the file can be created at+-- install-time depending on the available gcc version, and even+-- re-generated later if gcc is upgraded.+--+-- The options below are not dependent on the version of gcc, only the+-- platform.++picCCOpts :: DynFlags -> [String]+picCCOpts dflags =+      case platformOS (targetPlatform dflags) of+      OSDarwin+          -- Apple prefers to do things the other way round.+          -- PIC is on by default.+          -- -mdynamic-no-pic:+          --     Turn off PIC code generation.+          -- -fno-common:+          --     Don't generate "common" symbols - these are unwanted+          --     in dynamic libraries.++       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]+       | otherwise           -> ["-mdynamic-no-pic"]+      OSMinGW32 -- no -fPIC for Windows+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]+       | otherwise           -> []+      _+      -- we need -fPIC for C files when we are compiling with -dynamic,+      -- otherwise things like stub.c files don't get compiled+      -- correctly.  They need to reference data in the Haskell+      -- objects, but can't without -fPIC.  See+      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code+       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->+          ["-fPIC", "-U__PIC__", "-D__PIC__"] +++          -- Clang defaults to -fvisibility=hidden for wasm targets,+          -- but we need these compile-time flags to generate PIC+          -- objects that can be properly linked by wasm-ld using+          -- --export-dynamic; without these flags we would need+          -- -Wl,--export-all at .so link-time which will export+          -- internal symbols as well, and that severely pollutes the+          -- global symbol namespace.+          (if platformArch (targetPlatform dflags) == ArchWasm32+            then [ "-fvisibility=default", "-fvisibility-inlines-hidden" ]+            else [])+      -- gcc may be configured to have PIC on by default, let's be+      -- explicit here, see #15847+       | otherwise -> ["-fno-PIC"]++pieCCLDOpts :: DynFlags -> [String]+pieCCLDOpts dflags+      | gopt Opt_PICExecutable dflags       = ["-pie"]+        -- See Note [No PIE when linking]+      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]+      | otherwise                           = []+++{-+Note [No PIE when linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by+default in their gcc builds. This is incompatible with -r as it implies that we+are producing an executable. Consequently, we must manually pass -no-pie to gcc+when joining object files or linking dynamic libraries. Unless, of course, the+user has explicitly requested a PIE executable with -pie. See #12759.+-}++picPOpts :: DynFlags -> [String]+picPOpts dflags+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]+ | otherwise           = []++-- -----------------------------------------------------------------------------+-- Compiler Info++compilerInfo :: DynFlags -> [(String, String)]+compilerInfo dflags+    = -- We always make "Project name" be first to keep parsing in+      -- other languages simple, i.e. when looking for other fields,+      -- you don't have to worry whether there is a leading '[' or not+      ("Project name",                 cProjectName)+      -- Next come the settings, so anything else can be overridden+      -- in the settings file (as "lookup" uses the first match for the+      -- key)+    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))+          (rawSettings dflags)+   ++ [("Project version",             projectVersion dflags),+       ("Project Git commit id",       cProjectGitCommitId),+       ("Project Version Int",         cProjectVersionInt),+       ("Project Patch Level",         cProjectPatchLevel),+       ("Project Patch Level1",        cProjectPatchLevel1),+       ("Project Patch Level2",        cProjectPatchLevel2),+       ("Project Unit Id",             cProjectUnitId),+       ("ghc-internal Unit Id",        cGhcInternalUnitId), -- See Note [Special unit-ids]+       ("Booter version",              cBooterVersion),+       ("Stage",                       cStage),+       ("Build platform",              cBuildPlatformString),+       ("Host platform",               cHostPlatformString),+       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),+       ("target os string",            stringEncodeOS (platformOS (targetPlatform dflags))),+       ("target arch string",          stringEncodeArch (platformArch (targetPlatform dflags))),+       ("target word size in bits",    show (platformWordSizeInBits (targetPlatform dflags))),+       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),+       ("Object splitting supported",  showBool False),+       ("Have native code generator",  showBool $ platformNcgSupported platform),+       ("target has RTS linker",       showBool $ platformHasRTSLinker platform),+       ("Target default backend",      show     $ platformDefaultBackend platform),+       -- Whether or not we support @-dynamic-too@+       ("Support dynamic-too",         showBool $ not isWindows),+       -- Whether or not we support the @-j@ flag with @--make@.+       ("Support parallel --make",     "YES"),+       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in+       -- installed package info.+       ("Support reexported-modules",  "YES"),+       -- Whether or not we support extended @-package foo (Foo)@ syntax.+       ("Support thinning and renaming package flags", "YES"),+       -- Whether or not we support Backpack.+       ("Support Backpack", "YES"),+       -- If true, we require that the 'id' field in installed package info+       -- match what is passed to the @-this-unit-id@ flag for modules+       -- built in it+       ("Requires unified installed package IDs", "YES"),+       -- Whether or not we support the @-this-package-key@ flag.  Prefer+       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@+       -- flag has been removed, otherwise it breaks Cabal...+       ("Uses package keys",           "YES"),+       -- Whether or not we support the @-this-unit-id@ flag+       ("Uses unit IDs",               "YES"),+       -- Whether or not GHC was compiled using -dynamic+       ("GHC Dynamic",                 showBool hostIsDynamic),+       -- Whether or not GHC was compiled using -prof+       ("GHC Profiled",                showBool hostIsProfiled),+       ("Debug on",                    showBool debugIsOn),+       ("LibDir",                      topDir dflags),+       -- This is always an absolute path, unlike "Relative Global Package DB" which is+       -- in the settings file.+       ("Global Package DB",           globalPackageDatabasePath dflags)+      ]+  where+    showBool True  = "YES"+    showBool False = "NO"+    platform  = targetPlatform dflags+    isWindows = platformOS platform == OSMinGW32+    useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags+    expandDirectories :: FilePath -> Maybe FilePath -> String -> String+    expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd++-- Note [Special unit-ids]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Certain units are special to the compiler:+-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`.+-- - GHC plugins must be linked against a specific unit-id of `ghc`,+--   namely the same one as the compiler.+-- - When using Template Haskell, the result of executing splices refer to+--   the Template Haskell ASTs created using constructors from `ghc-internal`,+--   and must be linked against the same `ghc-internal` unit-id as the compiler.+--+-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and+-- ghc ("Project Unit Id") through `ghc --info`.+--+-- This allows build tools to act accordingly, eg, if a user wishes to build a+-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit+-- that the compiler was linked against.+-- See:+--  - https://github.com/haskell/cabal/issues/10087+--  - https://github.com/commercialhaskell/stack/issues/6749++{- -----------------------------------------------------------------------------+Note [DynFlags consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a number of number of DynFlags configurations which either+do not make sense or lead to unimplemented or buggy codepaths in the+compiler. makeDynFlagsConsistent is responsible for verifying the validity+of a set of DynFlags, fixing any issues, and reporting them back to the+caller.++GHCi and -O+---------------++When using optimization, the compiler can introduce several things+(such as unboxed tuples) into the intermediate code, which GHCi later+chokes on since the bytecode interpreter can't handle this (and while+this is arguably a bug these aren't handled, there are no plans to fix+it.)++While the driver pipeline always checks for this particular erroneous+combination when parsing flags, we also need to check when we update+the flags; this is because API clients may parse flags but update the+DynFlags afterwords, before finally running code inside a session (see+T10052 and #10052).++Host ways vs Build ways mismatch+--------------------------------+Many consistency checks aim to fix the situation where the wanted build ways+are not compatible with the ways the compiler is built in. This happens when+using the interpreter, TH, and the runtime linker, where the compiler cannot+load objects compiled for ways not matching its own.++For instance, a profiled-dynamic object can only be loaded by a+profiled-dynamic compiler (and not any other kind of compiler).++This incompatibility is traditionally solved in either of two ways:++(1) Force the "wanted" build ways to match the compiler ways exactly,+    guaranteeing they match.++(2) Force the use of the external interpreter. When interpreting is offloaded+    to the external interpreter it no longer matters what are the host compiler ways.++In the checks and fixes performed by `makeDynFlagsConsistent`, the choice+between the two does not seem uniform. TODO: Make this choice more evident and uniform.+-}++-- | Resolve any internal inconsistencies in a set of 'DynFlags'.+-- Returns the consistent 'DynFlags' as well as a list of warnings+-- to report to the user, and a list of verbose info msgs.+--+-- See Note [DynFlags consistency]+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc])+-- Whenever makeDynFlagsConsistent does anything, it starts over, to+-- ensure that a later change doesn't invalidate an earlier check.+-- Be careful not to introduce potential loops!+makeDynFlagsConsistent dflags+ -- Disable -dynamic-too on Windows (#8228, #7134, #5987)+ | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn    = "-dynamic-too is not supported on Windows"+      in loop dflags' warn+ -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise+ -- you get two dynamic object files (.o and .dyn_o). (#20436)+ | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn = "-dynamic-too is ignored when using -dynamic"+      in loop dflags' warn++ | gopt Opt_SplitSections dflags+ , platformHasSubsectionsViaSymbols (targetPlatform dflags)+    = let dflags' = gopt_unset dflags Opt_SplitSections+          warn = "-fsplit-sections is not useful on this platform " +++                 "since it uses subsections-via-symbols. Ignoring."+      in loop dflags' warn++   -- Via-C backend only supports unregisterised ABI. Switch to a backend+   -- supporting it if possible.+ | backendUnregisterisedAbiOnly (backend dflags) &&+   not (platformUnregisterised (targetPlatform dflags))+    = let b = platformDefaultBackend (targetPlatform dflags)+      in if backendSwappableWithViaC b then+           let dflags' = dflags { backend = b }+               warn = "Target platform doesn't use unregisterised ABI, so using " +++                      backendDescription b ++ " rather than " +++                      backendDescription (backend dflags)+           in loop dflags' warn+         else+           pgmError (backendDescription (backend dflags) +++                     " supports only unregisterised ABI but target platform doesn't use it.")++ | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags))+    = let dflags' = gopt_unset dflags Opt_Hpc+          warn = "Hpc can't be used with " ++ backendDescription (backend dflags) +++                 ". Ignoring -fhpc."+      in loop dflags' warn++ | backendSwappableWithViaC (backend dflags) &&+   platformUnregisterised (targetPlatform dflags)+    = loop (dflags { backend = viaCBackend })+           "Target platform uses unregisterised ABI, so compiling via C"++ | backendNeedsPlatformNcgSupport (backend dflags) &&+   not (platformNcgSupported $ targetPlatform dflags)+      = let dflags' = dflags { backend = llvmBackend }+            warn = "Native code generator doesn't support target platform, so using LLVM"+        in loop dflags' warn++ | not (osElfTarget os) && gopt Opt_PIE dflags+    = loop (gopt_unset dflags Opt_PIE)+           "Position-independent only supported on ELF platforms"+ | os == OSDarwin &&+   arch == ArchX86_64 &&+   not (gopt Opt_PIC dflags)+    = loop (gopt_set dflags Opt_PIC)+           "Enabling -fPIC as it is always on for this platform"++ | backendForcesOptimization0 (backend dflags)+ , gopt Opt_UnoptimizedCoreForInterpreter dflags+ , let (dflags', changed) = updOptLevelChanged 0 dflags+ , changed+    = loop dflags' $+      "Ignoring optimization flags since they are experimental for the " +++      backendDescription (backend dflags) +++      ". Pass -fno-unoptimized-core-for-interpreter to enable this feature."++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , backendWritesFiles (backend dflags)+ , ways dflags `hasNotWay` WayProf+    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"++ | gopt Opt_ByteCode dflags || gopt Opt_ByteCodeAndObjectCode dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , ways dflags `hasNotWay` WayProf+    = loop (gopt_set dflags Opt_ExternalInterpreter)+         "Enabling external interpreter, because GHC is profiled and bytecode is being used for TH"++ | LinkMergedObj <- ghcLink dflags+ , Nothing <- outputFile dflags+    = pgmError "--output must be specified when using --merge-objs"++ | platformTablesNextToCode platform+   && os == OSMinGW32+   && arch == ArchAArch64+    = case backendCodeOutput (backend dflags) of+        LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        _ -> (dflags, mempty, mempty)++  -- When we do ghci, force using dyn ways if the target RTS linker+  -- only supports dynamic code+ | LinkInMemory <- ghcLink dflags+ , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags+ , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags)+    = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $+        -- See checkOptions, -fexternal-interpreter is+        -- required when using --interactive with a non-standard+        -- way (-prof, -static, or -dynamic).+        setGeneralFlag' Opt_ExternalInterpreter $+        addWay' WayDyn dflags++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , targetWays_ dflags /= hostFullWays+    = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $+        let dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++ | otherwise = (dflags, mempty, mempty)+    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")+          loop updated_dflags warning+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is)+          loopNoWarn updated_dflags doc+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws, is) -> (dflags', ws, L loc (text doc):is)+          platform = targetPlatform dflags+          arch = platformArch platform+          os   = platformOS   platform+++setUnsafeGlobalDynFlags :: DynFlags -> IO ()+setUnsafeGlobalDynFlags dflags = do+   writeIORef v_unsafeHasPprDebug (hasPprDebug dflags)+   writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags)+   writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)+++-- -----------------------------------------------------------------------------++-- | Indicate if cost-centre profiling is enabled+sccProfilingEnabled :: DynFlags -> Bool+sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)++-- | Indicate whether we need to generate source notes+needSourceNotes :: DynFlags -> Bool+needSourceNotes dflags = debugLevel dflags > 0+                       || gopt Opt_InfoTableMap dflags++                       -- Source ticks are used to approximate the location of+                       -- overloaded call cost centers+                       || gopt Opt_ProfLateoverloadedCallsCCs dflags++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- | Should we use `-XLinker -rpath` when linking or not?+-- See Note [-fno-use-rpaths]+useXLinkerRPath :: DynFlags -> OS -> Bool+-- wasm shared libs don't have RPATH at all and wasm-ld doesn't accept+-- any RPATH-related flags+useXLinkerRPath dflags _ | ArchWasm32 <- platformArch $ targetPlatform dflags = False+useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]+useXLinkerRPath dflags _ = gopt Opt_RPath dflags++{-+Note [-fno-use-rpaths]+~~~~~~~~~~~~~~~~~~~~~~++First read, Note [Dynamic linking on macOS] to understand why on darwin we never+use `-XLinker -rpath`.++The specification of `Opt_RPath` is as follows:++The default case `-fuse-rpaths`:+* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath+  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin+  as things stand but it wasn't documented in the user guide before this patch how+  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.+* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,+  this is the normal way you should set the rpath.++The case of `-fno-use-rpaths`+* Never inject anything into the rpath.++When this was first implemented, `Opt_RPath` was disabled on darwin, but+the rpath was still always augmented by `runInjectRPaths`, and there was no way to+stop this. This was problematic because you couldn't build an executable in CI+with a clean rpath.++-}++-- -----------------------------------------------------------------------------+-- RTS hooks++-- Convert sizes like "3.5M" into integers+decodeSize :: String -> Integer+decodeSize str+  | c == ""      = truncate n+  | c == "K" || c == "k" = truncate (n * 1000)+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)+  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))+  where (m, c) = span pred str+        n      = readRational m+        pred c = isDigit c || c == '.'++foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()++outputFile :: DynFlags -> Maybe String+outputFile dflags+   | dynamicNow dflags = dynOutputFile_ dflags+   | otherwise         = outputFile_    dflags++objectSuf :: DynFlags -> String+objectSuf dflags+   | dynamicNow dflags = dynObjectSuf_ dflags+   | otherwise         = objectSuf_    dflags++-- | Pretty-print the difference between 2 DynFlags.+--+-- For now only their general flags but it could be extended.+-- Useful mostly for debugging.+pprDynFlagsDiff :: DynFlags -> DynFlags -> SDoc+pprDynFlagsDiff d1 d2 =+   let gf_removed  = EnumSet.difference (generalFlags d1) (generalFlags d2)+       gf_added    = EnumSet.difference (generalFlags d2) (generalFlags d1)+       ext_removed = EnumSet.difference (extensionFlags d1) (extensionFlags d2)+       ext_added   = EnumSet.difference (extensionFlags d2) (extensionFlags d1)+   in vcat+      [ text "Added general flags:"+      , text $ show $ EnumSet.toList $ gf_added+      , text "Removed general flags:"+      , text $ show $ EnumSet.toList $ gf_removed+      , text "Added extension flags:"+      , text $ show $ EnumSet.toList $ ext_added+      , text "Removed extension flags:"+      , text $ show $ EnumSet.toList $ ext_removed+      ]++updatePlatformConstants :: DynFlags -> Maybe PlatformConstants -> IO DynFlags+updatePlatformConstants dflags mconstants = do+  let platform1 = (targetPlatform dflags) { platform_constants = mconstants }+  let dflags1   = dflags { targetPlatform = platform1 }+  return dflags1
+ GHC/Driver/Session/Inspect.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE LambdaCase #-}++-- | GHC API utilities for inspecting the GHC session+module GHC.Driver.Session.Inspect where++import GHC.Prelude+import GHC.Data.Maybe+import Control.Monad++import GHC.ByteCode.Types+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv+import GHC.Driver.Env+import GHC.Driver.Main+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Rename.Names+import GHC.Runtime.Context+import GHC.Runtime.Interpreter+import GHC.Types.Avail+import GHC.Types.Name+import GHC.Types.Name.Ppr+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.PkgQual+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.TypeEnv+import GHC.Unit.External+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Utils.Misc+import GHC.Utils.Outputable+import qualified GHC.Unit.Home.Graph as HUG++-- %************************************************************************+-- %*                                                                      *+--             Inspecting the session+-- %*                                                                      *+-- %************************************************************************++-- | Get the module dependency graph.+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary+getModuleGraph = liftM hsc_mod_graph getSession++{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}+-- | Return @True@ \<==> module is loaded.+isLoaded :: GhcMonad m => ModuleName -> m Bool+isLoaded m = withSession $ \hsc_env -> liftIO $ do+  hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m+  return $! not (null hmis)++-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'+-- for the given 'UnitId'.+isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m+  return $! isJust hmi++-- | Check whether 'Module' is part of the 'HomeUnitGraph'.+--+-- Similar to 'isLoadedModule', but for 'Module's.+isLoadedHomeModule :: GhcMonad m => Module -> m Bool+isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)+  return $! isJust hmi++-- | 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_instances :: [ClsInst],+        minf_iface     :: Maybe ModIface,+        minf_safe      :: SafeHaskellMode,+        minf_modBreaks :: Maybe InternalModBreaks+  }+        -- 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 HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG 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_instances = error "getModuleInfo: instances for package module unimplemented",+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = Nothing+                }))++availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv+availsToGlobalRdrEnv hsc_env mod avails+  = forceGlobalRdrEnv rdr_env+    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+  where+    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)+      -- 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, is_as = moduleName mod,+                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,+                         is_dloc = srcLocSpan interactiveSrcLoc,+                         is_level = NormalLevel }++getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getHomeModuleInfo hsc_env mdl =+  HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case+    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,+                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.+                        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)++modInfoExports :: ModuleInfo -> [Name]+modInfoExports minf = concatMap availNames $! minf_exports minf++modInfoExportsWithSelectors :: ModuleInfo -> [Name]+modInfoExportsWithSelectors minf = concatMap availNames $! 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 =>+  Module     ->+  ModuleInfo ->+  m NamePprCtx+mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do+  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))+      ptc = initPromotionTickContext (hsc_dflags hsc_env)+  return name_ppr_ctx++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++-- | Retrieve module safe haskell mode+modInfoSafe :: ModuleInfo -> SafeHaskellMode+modInfoSafe = minf_safe++modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks+modInfoModBreaks = minf_modBreaks+
+ GHC/Driver/Session/Units.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+module GHC.Driver.Session.Units (initMake, initMulti) where++-- The official GHC API+import qualified GHC+import GHC              (parseTargetFiles, Ghc, GhcMonad(..))++import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Pipeline  ( oneShot, compileFile )+import GHC.Driver.Config.Diagnostic++import GHC.Unit.Env+import GHC.Unit (UnitId)+import GHC.Unit.Home.PackageTable+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.State  ( emptyUnitState )+import qualified GHC.Unit.State as State++import GHC.Types.SrcLoc+import GHC.Types.SourceError++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Monad       ( liftIO, mapMaybeM )+import GHC.Data.Maybe++import System.IO+import System.Exit+import System.FilePath+import Control.Monad+import Data.List ( partition, (\\) )+import qualified Data.Set as Set+import Prelude+import GHC.ResponseFile (expandResponse)+import Data.Bifunctor+import GHC.Data.Graph.Directed+import qualified Data.List.NonEmpty as NE++-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.+removeRTS :: [String] -> [String]+removeRTS ("+RTS" : xs)  =+  case dropWhile (/= "-RTS") xs of+    [] -> []+    (_ : ys) -> removeRTS ys+removeRTS (y:ys)         = y : removeRTS ys+removeRTS []             = []++initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]+initMake 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 NoStop srcs) >> return []+       else do++    o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)+                 non_hs_srcs+    dflags <- GHC.getSessionDynFlags+    let dflags' = dflags { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags }+    _ <- GHC.setSessionDynFlags dflags'+    return hs_srcs++initMulti :: NE.NonEmpty String+          -> (DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ())+          -- ^ Function to lint initMulti DynFlags and sources.+          -- In GHC, this is instanced to @checkOptions@.+          -> Ghc ([(String, Maybe UnitId, Maybe Phase)])+initMulti unitArgsFiles lintDynFlagsAndSrcs = do+  hsc_env <- GHC.getSession+  let logger = hsc_logger hsc_env+  initial_dflags <- GHC.getSessionDynFlags++  dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do+    when (verbosity initial_dflags > 2) (liftIO $ print f)+    args <- liftIO $ expandResponse [f]+    (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args))+    handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+         liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)++    let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)+        dflags4 = offsetDynFlags dflags3++    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++    -- This is dubious as the whole unit environment won't be set-up correctly, but+    -- that doesn't matter for what we use it for (linking and oneShot)+    let dubious_hsc_env = hscSetFlags dflags4 hsc_env+    -- 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 dubious_hsc_env NoStop srcs) >> return (dflags4, [])+       else do++    o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)+                 non_hs_srcs+    let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags4 }++    liftIO $ lintDynFlagsAndSrcs dflags5 srcs objs []++    pure (dflags5, hs_srcs)++  let+    unitDflags = NE.map fst dynFlagsAndSrcs+    srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs+    (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))++  checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))++  (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags+  let home_units = HUG.allUnits initial_home_graph++  home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+    let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+        hue_flags = homeUnitEnv_dflags homeUnitEnv+        dflags = homeUnitEnv_dflags homeUnitEnv+    (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units++    updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+    emptyHpt <- liftIO $ emptyHomePackageTable+    pure $ HomeUnitEnv+      { homeUnitEnv_units = unit_state+      , homeUnitEnv_unit_dbs = Just dbs+      , homeUnitEnv_dflags = updated_dflags+      , homeUnitEnv_hpt = emptyHpt+      , homeUnitEnv_home_unit = Just home_unit+      }++  checkUnitCycles initial_dflags home_unit_graph++  let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph+  unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))+  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }++  GHC.setSession final_hsc_env++  -- 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 do+        liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."+        liftIO $ exitWith (ExitFailure 1)+      else do++{-+  o_files <- liftIO $ mapMaybeM+                (\(src, uid, mphase) ->+                  compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)+                )+                (concat non_hs_srcs)+                -}++  -- MP: This should probably modify dflags for each unit?+  --let dflags' = dflags { ldInputs = map (FileOption "") o_files+  --                                  ++ ldInputs dflags }+  return $ concat hs_srcs++checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc ()+checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)+  where++    processSCCs [] = return ()+    processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs+    processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)+++    cycle_err uids =+      hang (text "Units form a dependency cycle:")+           2+           (one_err uids)++    one_err uids = vcat $+                    (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)+                    ++ [text "-" <+> ppr final]+      where+        start = init uids+        final = last uids++-- | Check that we don't have multiple units with the same UnitId.+checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()+checkDuplicateUnits dflags flags =+  unless (null duplicate_ids)+         (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)++  where+    uids = map (second homeUnitId_) flags+    deduplicated_uids = ordNubOn snd uids+    duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)++    duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids++    one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp++    multi_err =+      hang (text "Multiple units with the same unit-id:")+           2+           (vcat (map one_err duplicate_flags))+++offsetDynFlags :: DynFlags -> DynFlags+offsetDynFlags dflags =+  dflags { hiDir = c hiDir+         , objectDir  = c objectDir+         , stubDir = c stubDir+         , hieDir  = c hieDir+         , dumpDir = c dumpDir  }++  where+    c f = augment_maybe (f dflags)++    augment_maybe Nothing = Nothing+    augment_maybe (Just f) = Just (augment f)+    augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f+              | otherwise = f+++createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)+createUnitEnvFromFlags unitDflags = do+  unitEnvList <- forM unitDflags $ \dflags -> do+    emptyHpt <- emptyHomePackageTable+    let newInternalUnitEnv =+          HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing+    return (homeUnitId_ dflags, newInternalUnitEnv)+  let activeUnit = fst $ NE.head unitEnvList+  return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)++
GHC/Hs.hs view
@@ -9,129 +9,118 @@ therefore, is almost nothing but re-exporting. -} +{-# OPTIONS_GHC -Wno-orphans    #-} -- Outputable {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data+{-# LANGUAGE DataKinds #-}  module GHC.Hs (+        module Language.Haskell.Syntax,         module GHC.Hs.Binds,         module GHC.Hs.Decls,         module GHC.Hs.Expr,         module GHC.Hs.ImpExp,         module GHC.Hs.Lit,         module GHC.Hs.Pat,-        module GHC.Hs.Types,+        module GHC.Hs.Type,         module GHC.Hs.Utils,         module GHC.Hs.Doc,-        module GHC.Hs.PlaceHolder,         module GHC.Hs.Extension,+        module GHC.Parser.Annotation,         Fixity, -        HsModule(..),+        HsModule(..), AnnsModule(..),+        HsParsedModule(..), XModulePs(..) ) where  -- friends:-import GhcPrelude+import GHC.Prelude  import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr import GHC.Hs.ImpExp import GHC.Hs.Lit-import GHC.Hs.PlaceHolder+import Language.Haskell.Syntax import GHC.Hs.Extension+import GHC.Parser.Annotation import GHC.Hs.Pat-import GHC.Hs.Types-import BasicTypes       ( Fixity, WarningTxt )+import GHC.Hs.Type import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances  -- others:-import Outputable-import SrcLoc-import Module           ( ModuleName )+import GHC.Utils.Outputable+import GHC.Types.Fixity         ( Fixity )+import GHC.Types.SrcLoc+import GHC.Unit.Module.Warnings  -- libraries: import Data.Data hiding ( Fixity ) --- | Haskell Module------ All we actually declare here is the top-level structure for a module.-data HsModule pass-  = HsModule {-      hsmodName :: Maybe (Located ModuleName),-        -- ^ @Nothing@: \"module X where\" is omitted (in which case the next-        --     field is Nothing too)-      hsmodExports :: Maybe (Located [LIE pass]),-        -- ^ Export list-        ---        --  - @Nothing@: export list omitted, so export everything-        ---        --  - @Just []@: export /nothing/-        ---        --  - @Just [...]@: as you would expect...-        ---        ---        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'-        --                                   ,'ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation-      hsmodImports :: [LImportDecl pass],-        -- ^ We snaffle interesting stuff out of the imported interfaces early-        -- on, adding that info to TyDecls/etc; so this list is often empty,-        -- downstream.-      hsmodDecls :: [LHsDecl pass],-        -- ^ Type, class, value, and interface signature decls-      hsmodDeprecMessage :: Maybe (Located WarningTxt),+-- | Haskell Module extension point: GHC specific+data XModulePs+  = XModulePs {+      hsmodAnn :: EpAnn AnnsModule,+      hsmodLayout :: EpLayout,+        -- ^ Layout info for the module.+        -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout.+      hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs),         -- ^ reason\/explanation for warning/deprecation of this module-        ---        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'-        --                                   ,'ApiAnnotation.AnnClose'-        ----        -- For details on above see note [Api annotations] in ApiAnnotation-      hsmodHaddockModHeader :: Maybe LHsDocString+      hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)         -- ^ Haddock module info and description, unparsed-        ---        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen'-        --                                   ,'ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation    }-     -- ^ 'ApiAnnotation.AnnKeywordId's-     ---     --  - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere'-     ---     --  - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi',-     --    'ApiAnnotation.AnnClose' for explicit braces and semi around-     --    hsmodImports,hsmodDecls if this style is used.+   deriving Data -     -- For details on above see note [Api annotations] in ApiAnnotation--- deriving instance (DataIdLR name name) => Data (HsModule name)+type instance XCModule GhcPs = XModulePs+type instance XCModule GhcRn = DataConCantHappen+type instance XCModule GhcTc = DataConCantHappen+type instance XXModule p = DataConCantHappen+ deriving instance Data (HsModule GhcPs)-deriving instance Data (HsModule GhcRn)-deriving instance Data (HsModule GhcTc) -instance (OutputableBndrId p) => Outputable (HsModule (GhcPass p)) where+data AnnsModule+  = AnnsModule {+    am_sig :: EpToken "signature",+    am_mod :: EpToken "module",+    am_where :: EpToken "where",+    am_decls :: [TrailingAnn],                 -- ^ Semis before the start of top decls+    am_cs :: [LEpaComment],                    -- ^ Comments before start of top decl,+                                               --   used in exact printing only+    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token+    } deriving (Data, Eq) -    ppr (HsModule Nothing _ imports decls _ mbDoc)-      = pp_mb mbDoc $$ pp_nonnull imports-                    $$ pp_nonnull decls+instance NoAnn AnnsModule where+  noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing -    ppr (HsModule (Just name) exports imports decls deprec mbDoc)-      = vcat [-            pp_mb mbDoc,-            case exports of+instance Outputable (HsModule GhcPs) where+    ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc }+                  , hsmodName = Nothing+                  , hsmodImports = imports+                  , hsmodDecls = decls })+      = pprMaybeWithDoc mbDoc $ pp_nonnull imports+                             $$ pp_nonnull decls++    ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec+                                         , hsmodHaddockModHeader = mbDoc }+                  , hsmodName = (Just name)+                  , hsmodExports = exports+                  , hsmodImports = imports+                  , hsmodDecls = decls })+      = pprMaybeWithDoc mbDoc $+        vcat+          [ case exports of               Nothing -> pp_header (text "where")               Just es -> vcat [                            pp_header lparen,-                           nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),+                           nest 8 (pprWithCommas ppr (unLoc es)),                            nest 4 (text ") where")                           ],             pp_nonnull imports,@@ -144,10 +133,16 @@          pp_modname = text "module" <+> ppr name -pp_mb :: Outputable t => Maybe t -> SDoc-pp_mb (Just x) = ppr x-pp_mb Nothing  = empty- pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs)++data HsParsedModule = HsParsedModule {+    hpm_module    :: Located (HsModule GhcPs),+    hpm_src_files :: [FilePath]+       -- ^ extra source files (e.g. from #includes).  The lexer collects+       -- these from '# <file> <line>' pragmas, which the C preprocessor+       -- leaves behind.  These files and their timestamps are stored in+       -- the .hi file, so that we can force recompilation if any of+       -- them change (#3589)+  }
+ GHC/Hs/Basic.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Fixity+module GHC.Hs.Basic+   ( module Language.Haskell.Syntax.Basic+   ) where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data ()++import Language.Haskell.Syntax.Basic++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++instance Outputable Fixity where+    ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]+++instance Binary Fixity where+    put_ bh (Fixity aa ab) = do+            put_ bh aa+            put_ bh ab+    get bh = do+          aa <- get bh+          ab <- get bh+          return (Fixity aa ab)++------------------------++instance Binary FixityDirection where+    put_ bh InfixL =+            putByte bh 0+    put_ bh InfixR =+            putByte bh 1+    put_ bh InfixN =+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> return InfixL+              1 -> return InfixR+              _ -> return InfixN
GHC/Hs/Binds.hs view
@@ -1,1310 +1,1061 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[HsBinds]{Abstract syntax: top-level bindings and signatures}--Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Hs.Binds where--import GhcPrelude--import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr,-                                    MatchGroup, pprFunBind,-                                    GRHSs, pprPatBind )-import {-# SOURCE #-} GHC.Hs.Pat  ( LPat )--import GHC.Hs.Extension-import GHC.Hs.Types-import CoreSyn-import TcEvidence-import Type-import NameSet-import BasicTypes-import Outputable-import SrcLoc-import Var-import Bag-import FastString-import BooleanFormula (LBooleanFormula)-import DynFlags--import Data.Data hiding ( Fixity )-import Data.List hiding ( foldr )-import Data.Ord--{--************************************************************************-*                                                                      *-\subsection{Bindings: @BindGroup@}-*                                                                      *-************************************************************************--Global bindings (where clauses)--}---- During renaming, we need bindings where the left-hand sides--- have been renamed but the right-hand sides have not.--- the ...LR datatypes are parametrized by two id types,--- one for the left and one for the right.--- Other than during renaming, these will be the same.---- | Haskell Local Bindings-type HsLocalBinds id = HsLocalBindsLR id id---- | Located Haskell local bindings-type LHsLocalBinds id = Located (HsLocalBinds id)---- | Haskell Local Bindings with separate Left and Right identifier types------ Bindings in a 'let' expression--- or a 'where' clause-data HsLocalBindsLR idL idR-  = HsValBinds-        (XHsValBinds idL idR)-        (HsValBindsLR idL idR)-      -- ^ Haskell Value Bindings--         -- There should be no pattern synonyms in the HsValBindsLR-         -- These are *local* (not top level) bindings-         -- The parser accepts them, however, leaving the-         -- renamer to report them--  | HsIPBinds-        (XHsIPBinds idL idR)-        (HsIPBinds idR)-      -- ^ Haskell Implicit Parameter Bindings--  | EmptyLocalBinds (XEmptyLocalBinds idL idR)-      -- ^ Empty Local Bindings--  | XHsLocalBindsLR-        (XXHsLocalBindsLR idL idR)--type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = NoExtField-type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = NoExtField-type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon--type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)----- | Haskell Value Bindings-type HsValBinds id = HsValBindsLR id id---- | Haskell Value bindings with separate Left and Right identifier types--- (not implicit parameters)--- Used for both top level and nested bindings--- May contain pattern synonym bindings-data HsValBindsLR idL idR-  = -- | Value Bindings In-    ---    -- Before renaming RHS; idR is always RdrName-    -- Not dependency analysed-    -- Recursive by default-    ValBinds-        (XValBinds idL idR)-        (LHsBindsLR idL idR) [LSig idR]--    -- | Value Bindings Out-    ---    -- After renaming RHS; idR can be Name or Id Dependency analysed,-    -- later bindings in the list may depend on earlier ones.-  | XValBindsLR-      (XXValBindsLR idL idR)---- ------------------------------------------------------------------------ Deal with ValBindsOut---- TODO: make this the only type for ValBinds-data NHsValBindsLR idL-  = NValBinds-      [(RecFlag, LHsBinds idL)]-      [LSig GhcRn]--type instance XValBinds    (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXValBindsLR (GhcPass pL) (GhcPass pR)-            = NHsValBindsLR (GhcPass pL)---- ------------------------------------------------------------------------- | Located Haskell Binding-type LHsBind  id = LHsBindLR  id id---- | Located Haskell Bindings-type LHsBinds id = LHsBindsLR id id---- | Haskell Binding-type HsBind   id = HsBindLR   id id---- | Located Haskell Bindings with separate Left and Right identifier types-type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)---- | Located Haskell Binding with separate Left and Right identifier types-type LHsBindLR  idL idR = Located (HsBindLR idL idR)--{- Note [FunBind vs PatBind]-   ~~~~~~~~~~~~~~~~~~~~~~~~~-The distinction between FunBind and PatBind is a bit subtle. FunBind covers-patterns which resemble function bindings and simple variable bindings.--    f x = e-    f !x = e-    f = e-    !x = e          -- FunRhs has SrcStrict-    x `f` y = e     -- FunRhs has Infix--The actual patterns and RHSs of a FunBind are encoding in fun_matches.-The m_ctxt field of each Match in fun_matches will be FunRhs and carries-two bits of information about the match,--  * The mc_fixity field on each Match describes the fixity of the-    function binder in that match.  E.g. this is legal:-         f True False  = e1-         True `f` True = e2--  * The mc_strictness field is used /only/ for nullary FunBinds: ones-    with one Match, which has no pats. For these, it describes whether-    the match is decorated with a bang (e.g. `!x = e`).--By contrast, PatBind represents data constructor patterns, as well as a few-other interesting cases. Namely,--    Just x = e-    (x) = e-    x :: Ty = e--}---- | Haskell Binding with separate Left and Right id's-data HsBindLR idL idR-  = -- | Function-like Binding-    ---    -- FunBind is used for both functions     @f x = e@-    -- and variables                          @f = \x -> e@-    -- and strict variables                   @!x = x + 1@-    ---    -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.-    ---    -- Reason 2: Instance decls can only have FunBinds, which is convenient.-    --           If you change this, you'll need to change e.g. rnMethodBinds-    ---    -- But note that the form                 @f :: a->a = ...@-    -- parses as a pattern binding, just like-    --                                        @(f :: a -> a) = ... @-    ---    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their-    -- 'MatchContext'. See Note [FunBind vs PatBind] for-    -- details about the relationship between FunBind and PatBind.-    ---    --  'ApiAnnotation.AnnKeywordId's-    ---    --  - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches-    ---    --  - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',-    --    'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',--    -- For details on above see note [Api annotations] in ApiAnnotation-    FunBind {--        fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains-                                --  the locally-bound-                                -- free variables of this defn.-                                -- See Note [Bind free vars]--        fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr--        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload--        fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of-                                -- the Id.  Example:-                                ---                                -- @-                                --      f :: Int -> forall a. a -> a-                                --      f x y = y-                                -- @-                                ---                                -- Then the MatchGroup will have type (Int -> a' -> a')-                                -- (with a free type variable a').  The coercion will take-                                -- a CoreExpr of this type and convert it to a CoreExpr of-                                -- type         Int -> forall a'. a' -> a'-                                -- Notice that the coercion captures the free a'.--        fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any-    }--  -- | Pattern Binding-  ---  -- The pattern is never a simple variable;-  -- That case is done by FunBind.-  -- See Note [FunBind vs PatBind] for details about the-  -- relationship between FunBind and PatBind.--  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',-  --       'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',-  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',--  -- For details on above see note [Api annotations] in ApiAnnotation-  | PatBind {-        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]-        pat_lhs    :: LPat idL,-        pat_rhs    :: GRHSs idR (LHsExpr idR),-        pat_ticks  :: ([Tickish Id], [[Tickish Id]])-               -- ^ Ticks to put on the rhs, if any, and ticks to put on-               -- the bound variables.-    }--  -- | Variable Binding-  ---  -- Dictionary binding and suchlike.-  -- All VarBinds are introduced by the type checker-  | VarBind {-        var_ext    :: XVarBind idL idR,-        var_id     :: IdP idL,-        var_rhs    :: LHsExpr idR,   -- ^ Located only for consistency-        var_inline :: Bool           -- ^ True <=> inline this binding regardless-                                     -- (used for implication constraints only)-    }--  -- | Abstraction Bindings-  | AbsBinds {                      -- Binds abstraction; TRANSLATION-        abs_ext     :: XAbsBinds idL idR,-        abs_tvs     :: [TyVar],-        abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints--       -- | AbsBinds only gets used when idL = idR after renaming,-       -- but these need to be idL's for the collect... code in HsUtil-       -- to have the right type-        abs_exports :: [ABExport idL],--        -- | Evidence bindings-        -- Why a list? See TcInstDcls-        -- Note [Typechecking plan for instance declarations]-        abs_ev_binds :: [TcEvBinds],--        -- | Typechecked user bindings-        abs_binds    :: LHsBinds idL,--        abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]-    }--  -- | Patterns Synonym Binding-  | PatSynBind-        (XPatSynBind idL idR)-        (PatSynBind idL idR)-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',-        --          'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',-        --          'ApiAnnotation.AnnWhere'-        --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@--        -- For details on above see note [Api annotations] in ApiAnnotation--  | XHsBindsLR (XXHsBindsLR idL idR)--data NPatBindTc = NPatBindTc {-     pat_fvs :: NameSet, -- ^ Free variables-     pat_rhs_ty :: Type  -- ^ Type of the GRHSs-     } deriving Data--type instance XFunBind    (GhcPass pL) GhcPs = NoExtField-type instance XFunBind    (GhcPass pL) GhcRn = NameSet -- Free variables-type instance XFunBind    (GhcPass pL) GhcTc = NameSet -- Free variables--type instance XPatBind    GhcPs (GhcPass pR) = NoExtField-type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- Free variables-type instance XPatBind    GhcTc (GhcPass pR) = NPatBindTc--type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExtField-type instance XAbsBinds   (GhcPass pL) (GhcPass pR) = NoExtField-type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon---        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]-        ---        -- Creates bindings for (polymorphic, overloaded) poly_f-        -- in terms of monomorphic, non-overloaded mono_f-        ---        -- Invariants:-        --      1. 'binds' binds mono_f-        --      2. ftvs is a subset of tvs-        --      3. ftvs includes all tyvars free in ds-        ---        -- See Note [AbsBinds]---- | Abtraction Bindings Export-data ABExport p-  = ABE { abe_ext       :: XABE p-        , abe_poly      :: IdP p -- ^ Any INLINE pragma is attached to this Id-        , abe_mono      :: IdP p-        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]-             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly-        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas-        }-   | XABExport (XXABExport p)--type instance XABE       (GhcPass p) = NoExtField-type instance XXABExport (GhcPass p) = NoExtCon----- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',---             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'---             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,---             'ApiAnnotation.AnnClose' @'}'@,---- For details on above see note [Api annotations] in ApiAnnotation---- | Pattern Synonym binding-data PatSynBind idL idR-  = PSB { psb_ext  :: XPSB idL idR,            -- ^ Post renaming, FVs.-                                               -- See Note [Bind free vars]-          psb_id   :: Located (IdP idL),       -- ^ Name of the pattern synonym-          psb_args :: HsPatSynDetails (Located (IdP idR)),-                                               -- ^ Formal parameter names-          psb_def  :: LPat idR,                -- ^ Right-hand side-          psb_dir  :: HsPatSynDir idR          -- ^ Directionality-     }-   | XPatSynBind (XXPatSynBind idL idR)--type instance XPSB         (GhcPass idL) GhcPs = NoExtField-type instance XPSB         (GhcPass idL) GhcRn = NameSet-type instance XPSB         (GhcPass idL) GhcTc = NameSet--type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon--{--Note [AbsBinds]-~~~~~~~~~~~~~~~-The AbsBinds constructor is used in the output of the type checker, to-record *typechecked* and *generalised* bindings.  Specifically--         AbsBinds { abs_tvs      = tvs-                  , abs_ev_vars  = [d1,d2]-                  , abs_exports  = [ABE { abe_poly = fp, abe_mono = fm-                                        , abe_wrap = fwrap }-                                    ABE { slly for g } ]-                  , abs_ev_binds = DBINDS-                  , abs_binds    = BIND[fm,gm] }--where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means--        fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS        ]-                   [                       ; BIND[fm,gm] } ]-                   [                 in fm                 ]--        gp = ...same again, with gm instead of fm--The 'fwrap' is an impedence-matcher that typically does nothing; see-Note [ABExport wrapper].--This is a pretty bad translation, because it duplicates all the bindings.-So the desugarer tries to do a better job:--        fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of-                                        (fm,gm) -> fm-        ..ditto for gp..--        tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }-                                      in (fm,gm)--In general:--  * abs_tvs are the type variables over which the binding group is-    generalised-  * abs_ev_var are the evidence variables (usually dictionaries)-    over which the binding group is generalised-  * abs_binds are the monomorphic bindings-  * abs_ex_binds are the evidence bindings that wrap the abs_binds-  * abs_exports connects the monomorphic Ids bound by abs_binds-    with the polymorphic Ids bound by the AbsBinds itself.--For example, consider a module M, with this top-level binding, where-there is no type signature for M.reverse,-    M.reverse []     = []-    M.reverse (x:xs) = M.reverse xs ++ [x]--In Hindley-Milner, a recursive binding is typechecked with the-*recursive* uses being *monomorphic*.  So after typechecking *and*-desugaring we will get something like this--    M.reverse :: forall a. [a] -> [a]-      = /\a. letrec-                reverse :: [a] -> [a] = \xs -> case xs of-                                                []     -> []-                                                (x:xs) -> reverse xs ++ [x]-             in reverse--Notice that 'M.reverse' is polymorphic as expected, but there is a local-definition for plain 'reverse' which is *monomorphic*.  The type variable-'a' scopes over the entire letrec.--That's after desugaring.  What about after type checking but before-desugaring?  That's where AbsBinds comes in.  It looks like this:--   AbsBinds { abs_tvs     = [a]-            , abs_ev_vars = []-            , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],-                                 , abe_mono = reverse :: [a] -> [a]}]-            , abs_ev_binds = {}-            , abs_binds = { reverse :: [a] -> [a]-                               = \xs -> case xs of-                                            []     -> []-                                            (x:xs) -> reverse xs ++ [x] } }--Here,--  * abs_tvs says what type variables are abstracted over the binding-    group, just 'a' in this case.-  * abs_binds is the *monomorphic* bindings of the group-  * abs_exports describes how to get the polymorphic Id 'M.reverse'-    from the monomorphic one 'reverse'--Notice that the *original* function (the polymorphic one you thought-you were defining) appears in the abe_poly field of the-abs_exports. The bindings in abs_binds are for fresh, local, Ids with-a *monomorphic* Id.--If there is a group of mutually recursive (see Note [Polymorphic-recursion]) functions without type signatures, we get one AbsBinds-with the monomorphic versions of the bindings in abs_binds, and one-element of abe_exports for each variable bound in the mutually-recursive group.  This is true even for pattern bindings.  Example:-        (f,g) = (\x -> x, f)-After type checking we get-   AbsBinds { abs_tvs     = [a]-            , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a-                                  , abe_mono = f :: a -> a }-                            , ABE { abe_poly = M.g :: forall a. a -> a-                                  , abe_mono = g :: a -> a }]-            , abs_binds = { (f,g) = (\x -> x, f) }--Note [Polymorphic recursion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   Rec { f x = ...(g ef)...--       ; g :: forall a. [a] -> [a]-       ; g y = ...(f eg)...  }--These bindings /are/ mutually recursive (f calls g, and g calls f).-But we can use the type signature for g to break the recursion,-like this:--  1. Add g :: forall a. [a] -> [a] to the type environment--  2. Typecheck the definition of f, all by itself,-     including generalising it to find its most general-     type, say f :: forall b. b -> b -> [b]--  3. Extend the type environment with that type for f--  4. Typecheck the definition of g, all by itself,-     checking that it has the type claimed by its signature--Steps 2 and 4 each generate a separate AbsBinds, so we end-up with-   Rec { AbsBinds { ...for f ... }-       ; AbsBinds { ...for g ... } }--This approach allows both f and to call each other-polymorphically, even though only g has a signature.--We get an AbsBinds that encompasses multiple source-program-bindings only when- * Each binding in the group has at least one binder that-   lacks a user type signature- * The group forms a strongly connected component---Note [The abs_sig field of AbsBinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The abs_sig field supports a couple of special cases for bindings.-Consider--  x :: Num a => (# a, a #)-  x = (# 3, 4 #)--The general desugaring for AbsBinds would give--  x = /\a. \ ($dNum :: Num a) ->-      letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in-      xm--But that has an illegal let-binding for an unboxed tuple.  In this-case we'd prefer to generate the (more direct)--  x = /\ a. \ ($dNum :: Num a) ->-     (# fromInteger $dNum 3, fromInteger $dNum 4 #)--A similar thing happens with representation-polymorphic defns-(#11405):--  undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a-  undef = error "undef"--Again, the vanilla desugaring gives a local let-binding for a-representation-polymorphic (undefm :: a), which is illegal.  But-again we can desugar without a let:--  undef = /\ a. \ (d:HasCallStack) -> error a d "undef"--The abs_sig field supports this direct desugaring, with no local-let-bining.  When abs_sig = True-- * the abs_binds is single FunBind-- * the abs_exports is a singleton-- * we have a complete type sig for binder-   and hence the abs_binds is non-recursive-   (it binds the mono_id but refers to the poly_id--These properties are exploited in DsBinds.dsAbsBinds to-generate code without a let-binding.--Note [ABExport wrapper]-~~~~~~~~~~~~~~~~~~~~~~~-Consider-   (f,g) = (\x.x, \y.y)-This ultimately desugars to something like this:-   tup :: forall a b. (a->a, b->b)-   tup = /\a b. (\x:a.x, \y:b.y)-   f :: forall a. a -> a-   f = /\a. case tup a Any of-               (fm::a->a,gm:Any->Any) -> fm-   ...similarly for g...--The abe_wrap field deals with impedance-matching between-    (/\a b. case tup a b of { (f,g) -> f })-and the thing we really want, which may have fewer type-variables.  The action happens in TcBinds.mkExport.--Note [Bind free vars]-~~~~~~~~~~~~~~~~~~~~~-The bind_fvs field of FunBind and PatBind records the free variables-of the definition.  It is used for the following purposes--a) Dependency analysis prior to type checking-    (see TcBinds.tc_group)--b) Deciding whether we can do generalisation of the binding-    (see TcBinds.decideGeneralisationPlan)--c) Deciding whether the binding can be used in static forms-    (see TcExpr.checkClosedInStaticForm for the HsStatic case and-     TcBinds.isClosedBndrGroup).--Specifically,--  * bind_fvs includes all free vars that are defined in this module-    (including top-level things and lexically scoped type variables)--  * bind_fvs excludes imported vars; this is just to keep the set smaller--  * Before renaming, and after typechecking, the field is unused;-    it's just an error thunk--}--instance (OutputableBndrId pl, OutputableBndrId pr)-        => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where-  ppr (HsValBinds _ bs)   = ppr bs-  ppr (HsIPBinds _ bs)    = ppr bs-  ppr (EmptyLocalBinds _) = empty-  ppr (XHsLocalBindsLR x) = ppr x--instance (OutputableBndrId pl, OutputableBndrId pr)-        => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where-  ppr (ValBinds _ binds sigs)-   = pprDeclList (pprLHsBindsForUser binds sigs)--  ppr (XValBindsLR (NValBinds sccs sigs))-    = getPprStyle $ \ sty ->-      if debugStyle sty then    -- Print with sccs showing-        vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)-     else-        pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)-   where-     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds-     pp_rec Recursive    = text "rec"-     pp_rec NonRecursive = text "nonrec"--pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)-            => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc-pprLHsBinds binds-  | isEmptyLHsBinds binds = empty-  | otherwise = pprDeclList (map ppr (bagToList binds))--pprLHsBindsForUser :: (OutputableBndrId idL,-                       OutputableBndrId idR,-                       OutputableBndrId id2)-     => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]---  pprLHsBindsForUser is different to pprLHsBinds because---  a) No braces: 'let' and 'where' include a list of HsBindGroups---     and we don't want several groups of bindings each---     with braces around---  b) Sort by location before printing---  c) Include signatures-pprLHsBindsForUser binds sigs-  = map snd (sort_by_loc decls)-  where--    decls :: [(SrcSpan, SDoc)]-    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++-            [(loc, ppr bind) | L loc bind <- bagToList binds]--    sort_by_loc decls = sortBy (comparing fst) decls--pprDeclList :: [SDoc] -> SDoc   -- Braces with a space--- Print a bunch of declarations--- One could choose  { d1; d2; ... }, using 'sep'--- or      d1---         d2---         ..---    using vcat--- At the moment we chose the latter--- Also we do the 'pprDeeperList' thing.-pprDeclList ds = pprDeeperList vcat ds---------------emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)-emptyLocalBinds = EmptyLocalBinds noExtField---- AZ:These functions do not seem to be used at all?-isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool-isEmptyLocalBindsTc (HsValBinds _ ds)   = isEmptyValBinds ds-isEmptyLocalBindsTc (HsIPBinds _ ds)    = isEmptyIPBindsTc ds-isEmptyLocalBindsTc (EmptyLocalBinds _) = True-isEmptyLocalBindsTc (XHsLocalBindsLR _) = True--isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool-isEmptyLocalBindsPR (HsValBinds _ ds)   = isEmptyValBinds ds-isEmptyLocalBindsPR (HsIPBinds _ ds)    = isEmptyIPBindsPR ds-isEmptyLocalBindsPR (EmptyLocalBinds _) = True-isEmptyLocalBindsPR (XHsLocalBindsLR _) = True--eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool-eqEmptyLocalBinds (EmptyLocalBinds _) = True-eqEmptyLocalBinds _                   = False--isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool-isEmptyValBinds (ValBinds _ ds sigs)  = isEmptyLHsBinds ds && null sigs-isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs--emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)-emptyValBindsIn  = ValBinds noExtField emptyBag []-emptyValBindsOut = XValBindsLR (NValBinds [] [])--emptyLHsBinds :: LHsBindsLR idL idR-emptyLHsBinds = emptyBag--isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool-isEmptyLHsBinds = isEmptyBag---------------plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)-               -> HsValBinds(GhcPass a)-plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)-  = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2)-plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))-               (XValBindsLR (NValBinds ds2 sigs2))-  = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))-plusHsValBinds _ _-  = panic "HsBinds.plusHsValBinds"--instance (OutputableBndrId pl, OutputableBndrId pr)-         => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where-    ppr mbind = ppr_monobind mbind--ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)-             => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc--ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })-  = pprPatBind pat grhss-ppr_monobind (VarBind { var_id = var, var_rhs = rhs })-  = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]-ppr_monobind (FunBind { fun_id = fun,-                        fun_co_fn = wrap,-                        fun_matches = matches,-                        fun_tick = ticks })-  = pprTicks empty (if null ticks then empty-                    else text "-- ticks = " <> ppr ticks)-    $$  whenPprDebug (pprBndr LetBind (unLoc fun))-    $$  pprFunBind  matches-    $$  whenPprDebug (ppr wrap)-ppr_monobind (PatSynBind _ psb) = ppr psb-ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars-                       , abs_exports = exports, abs_binds = val_binds-                       , abs_ev_binds = ev_binds })-  = sdocWithDynFlags $ \ dflags ->-    if gopt Opt_PrintTypecheckerElaboration dflags then-      -- Show extra information (bug number: #10662)-      hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)-                                    <+> brackets (interpp'SP dictvars))-         2 $ braces $ vcat-      [ text "Exports:" <+>-          brackets (sep (punctuate comma (map ppr exports)))-      , text "Exported types:" <+>-          vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]-      , text "Binds:" <+> pprLHsBinds val_binds-      , text "Evidence:" <+> ppr ev_binds ]-    else-      pprLHsBinds val_binds-ppr_monobind (XHsBindsLR x) = ppr x--instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where-  ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })-    = vcat [ ppr gbl <+> text "<=" <+> ppr lcl-           , nest 2 (pprTcSpecPrags prags)-           , nest 2 (text "wrap:" <+> ppr wrap)]-  ppr (XABExport x) = ppr x--instance (OutputableBndrId l, OutputableBndrId r,-         Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))-          => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where-  ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,-            psb_dir = dir })-      = ppr_lhs <+> ppr_rhs-    where-      ppr_lhs = text "pattern" <+> ppr_details-      ppr_simple syntax = syntax <+> ppr pat--      ppr_details = case details of-          InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]-          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr vs)-          RecCon vs      -> pprPrefixOcc psyn-                            <> braces (sep (punctuate comma (map ppr vs)))--      ppr_rhs = case dir of-          Unidirectional           -> ppr_simple (text "<-")-          ImplicitBidirectional    -> ppr_simple equals-          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$-                                      (nest 2 $ pprFunBind mg)-  ppr (XPatSynBind x) = ppr x--pprTicks :: SDoc -> SDoc -> SDoc--- Print stuff about ticks only when -dppr-debug is on, to avoid--- them appearing in error messages (from the desugarer); see # 3263--- Also print ticks in dumpStyle, so that -ddump-hpc actually does--- something useful.-pprTicks pp_no_debug pp_when_debug-  = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty-                             then pp_when_debug-                             else pp_no_debug)--{--************************************************************************-*                                                                      *-                Implicit parameter bindings-*                                                                      *-************************************************************************--}---- | Haskell Implicit Parameter Bindings-data HsIPBinds id-  = IPBinds-        (XIPBinds id)-        [LIPBind id]-        -- TcEvBinds       -- Only in typechecker output; binds-        --                 -- uses of the implicit parameters-  | XHsIPBinds (XXHsIPBinds id)--type instance XIPBinds       GhcPs = NoExtField-type instance XIPBinds       GhcRn = NoExtField-type instance XIPBinds       GhcTc = TcEvBinds -- binds uses of the-                                               -- implicit parameters---type instance XXHsIPBinds    (GhcPass p) = NoExtCon--isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool-isEmptyIPBindsPR (IPBinds _ is) = null is-isEmptyIPBindsPR (XHsIPBinds _) = True--isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool-isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds-isEmptyIPBindsTc (XHsIPBinds _) = True---- | Located Implicit Parameter Binding-type LIPBind id = Located (IPBind id)--- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a---   list---- For details on above see note [Api annotations] in ApiAnnotation---- | Implicit parameter bindings.------ These bindings start off as (Left "x") in the parser and stay--- that way until after type-checking when they are replaced with--- (Right d), where "d" is the name of the dictionary holding the--- evidence for the implicit parameter.------ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'---- For details on above see note [Api annotations] in ApiAnnotation-data IPBind id-  = IPBind-        (XCIPBind id)-        (Either (Located HsIPName) (IdP id))-        (LHsExpr id)-  | XIPBind (XXIPBind id)--type instance XCIPBind    (GhcPass p) = NoExtField-type instance XXIPBind    (GhcPass p) = NoExtCon--instance OutputableBndrId p-       => Outputable (HsIPBinds (GhcPass p)) where-  ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)-                        $$ whenPprDebug (ppr ds)-  ppr (XHsIPBinds x) = ppr x--instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where-  ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)-    where name = case lr of-                   Left (L _ ip) -> pprBndr LetBind ip-                   Right     id  -> pprBndr LetBind id-  ppr (XIPBind x) = ppr x--{--************************************************************************-*                                                                      *-\subsection{@Sig@: type signatures and value-modifying user pragmas}-*                                                                      *-************************************************************************--It is convenient to lump ``value-modifying'' user-pragmas (e.g.,-``specialise this function to these four types...'') in with type-signatures.  Then all the machinery to move them into place, etc.,-serves for both.--}---- | Located Signature-type LSig pass = Located (Sig pass)---- | Signatures and pragmas-data Sig pass-  =   -- | An ordinary type signature-      ---      -- > f :: Num a => a -> a-      ---      -- After renaming, this list of Names contains the named-      -- wildcards brought into scope by this signature. For a signature-      -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@-      -- untouched, and the named wildcard @_a@ is then replaced with-      -- fresh meta vars in the type. Their names are stored in the type-      -- signature that brought them into scope, in this third field to be-      -- more specific.-      ---      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',-      --          'ApiAnnotation.AnnComma'--      -- For details on above see note [Api annotations] in ApiAnnotation-    TypeSig-       (XTypeSig pass)-       [Located (IdP pass)]  -- LHS of the signature; e.g.  f,g,h :: blah-       (LHsSigWcType pass)   -- RHS of the signature; can have wildcards--      -- | A pattern synonym type signature-      ---      -- > pattern Single :: () => (Show a) => a -> [a]-      ---      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',-      --           'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'-      --           'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'--      -- For details on above see note [Api annotations] in ApiAnnotation-  | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)-      -- P :: forall a b. Req => Prov => ty--      -- | A signature for a class method-      --   False: ordinary class-method signature-      --   True:  generic-default class method signature-      -- e.g.   class C a where-      --          op :: a -> a                   -- Ordinary-      --          default op :: Eq a => a -> a   -- Generic default-      -- No wildcards allowed here-      ---      --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',-      --           'ApiAnnotation.AnnDcolon'-  | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)--        -- | A type signature in generated code, notably the code-        -- generated for record selectors.  We simply record-        -- the desired Id itself, replete with its name, type-        -- and IdDetails.  Otherwise it's just like a type-        -- signature: there should be an accompanying binding-  | IdSig (XIdSig pass) Id--        -- | An ordinary fixity declaration-        ---        -- >     infixl 8 ***-        ---        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',-        --           'ApiAnnotation.AnnVal'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | FixSig (XFixSig pass) (FixitySig pass)--        -- | An inline pragma-        ---        -- > {#- INLINE f #-}-        ---        --  - 'ApiAnnotation.AnnKeywordId' :-        --       'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,-        --       'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',-        --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',-        --       'ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | InlineSig   (XInlineSig pass)-                (Located (IdP pass)) -- Function name-                InlinePragma         -- Never defaultInlinePragma--        -- | A specialisation pragma-        ---        -- > {-# SPECIALISE f :: Int -> Int #-}-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-        --      'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,-        --      'ApiAnnotation.AnnTilde',-        --      'ApiAnnotation.AnnVal',-        --      'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,-        --      'ApiAnnotation.AnnDcolon'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | SpecSig     (XSpecSig pass)-                (Located (IdP pass)) -- Specialise a function or datatype  ...-                [LHsSigType pass]  -- ... to these types-                InlinePragma       -- The pragma on SPECIALISE_INLINE form.-                                   -- If it's just defaultInlinePragma, then we said-                                   --    SPECIALISE, not SPECIALISE_INLINE--        -- | A specialisation pragma for instance declarations only-        ---        -- > {-# SPECIALISE instance Eq [Int] #-}-        ---        -- (Class tys); should be a specialisation of the-        -- current instance declaration-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-        --      'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)-                  -- Note [Pragma source text] in BasicTypes--        -- | A minimal complete definition pragma-        ---        -- > {-# MINIMAL a | (b, c | (d | e)) #-}-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-        --      'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',-        --      'ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | MinimalSig (XMinimalSig pass)-               SourceText (LBooleanFormula (Located (IdP pass)))-               -- Note [Pragma source text] in BasicTypes--        -- | A "set cost centre" pragma for declarations-        ---        -- > {-# SCC funName #-}-        ---        -- or-        ---        -- > {-# SCC funName "cost_centre_name" #-}--  | SCCFunSig  (XSCCFunSig pass)-               SourceText      -- Note [Pragma source text] in BasicTypes-               (Located (IdP pass))  -- Function name-               (Maybe (Located StringLiteral))-       -- | A complete match pragma-       ---       -- > {-# COMPLETE C, D [:: T] #-}-       ---       -- Used to inform the pattern match checker about additional-       -- complete matchings which, for example, arise from pattern-       -- synonym definitions.-  | CompleteMatchSig (XCompleteMatchSig pass)-                     SourceText-                     (Located [Located (IdP pass)])-                     (Maybe (Located (IdP pass)))-  | XSig (XXSig pass)--type instance XTypeSig          (GhcPass p) = NoExtField-type instance XPatSynSig        (GhcPass p) = NoExtField-type instance XClassOpSig       (GhcPass p) = NoExtField-type instance XIdSig            (GhcPass p) = NoExtField-type instance XFixSig           (GhcPass p) = NoExtField-type instance XInlineSig        (GhcPass p) = NoExtField-type instance XSpecSig          (GhcPass p) = NoExtField-type instance XSpecInstSig      (GhcPass p) = NoExtField-type instance XMinimalSig       (GhcPass p) = NoExtField-type instance XSCCFunSig        (GhcPass p) = NoExtField-type instance XCompleteMatchSig (GhcPass p) = NoExtField-type instance XXSig             (GhcPass p) = NoExtCon---- | Located Fixity Signature-type LFixitySig pass = Located (FixitySig pass)---- | Fixity Signature-data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity-                    | XFixitySig (XXFixitySig pass)--type instance XFixitySig  (GhcPass p) = NoExtField-type instance XXFixitySig (GhcPass p) = NoExtCon---- | Type checker Specialisation Pragmas------ 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer-data TcSpecPrags-  = IsDefaultMethod     -- ^ Super-specialised: a default method should-                        -- be macro-expanded at every call site-  | SpecPrags [LTcSpecPrag]-  deriving Data---- | Located Type checker Specification Pragmas-type LTcSpecPrag = Located TcSpecPrag---- | Type checker Specification Pragma-data TcSpecPrag-  = SpecPrag-        Id-        HsWrapper-        InlinePragma-  -- ^ The Id to be specialised, a wrapper that specialises the-  -- polymorphic function, and inlining spec for the specialised function-  deriving Data--noSpecPrags :: TcSpecPrags-noSpecPrags = SpecPrags []--hasSpecPrags :: TcSpecPrags -> Bool-hasSpecPrags (SpecPrags ps) = not (null ps)-hasSpecPrags IsDefaultMethod = False--isDefaultMethod :: TcSpecPrags -> Bool-isDefaultMethod IsDefaultMethod = True-isDefaultMethod (SpecPrags {})  = False---isFixityLSig :: LSig name -> Bool-isFixityLSig (L _ (FixSig {})) = True-isFixityLSig _                 = False--isTypeLSig :: LSig name -> Bool  -- Type signatures-isTypeLSig (L _(TypeSig {}))    = True-isTypeLSig (L _(ClassOpSig {})) = True-isTypeLSig (L _(IdSig {}))      = True-isTypeLSig _                    = False--isSpecLSig :: LSig name -> Bool-isSpecLSig (L _(SpecSig {})) = True-isSpecLSig _                 = False--isSpecInstLSig :: LSig name -> Bool-isSpecInstLSig (L _ (SpecInstSig {})) = True-isSpecInstLSig _                      = False--isPragLSig :: LSig name -> Bool--- Identifies pragmas-isPragLSig (L _ (SpecSig {}))   = True-isPragLSig (L _ (InlineSig {})) = True-isPragLSig (L _ (SCCFunSig {})) = True-isPragLSig (L _ (CompleteMatchSig {})) = True-isPragLSig _                    = False--isInlineLSig :: LSig name -> Bool--- Identifies inline pragmas-isInlineLSig (L _ (InlineSig {})) = True-isInlineLSig _                    = False--isMinimalLSig :: LSig name -> Bool-isMinimalLSig (L _ (MinimalSig {})) = True-isMinimalLSig _                     = False--isSCCFunSig :: LSig name -> Bool-isSCCFunSig (L _ (SCCFunSig {})) = True-isSCCFunSig _                    = False--isCompleteMatchSig :: LSig name -> Bool-isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True-isCompleteMatchSig _                            = False--hsSigDoc :: Sig name -> SDoc-hsSigDoc (TypeSig {})           = text "type signature"-hsSigDoc (PatSynSig {})         = text "pattern synonym signature"-hsSigDoc (ClassOpSig _ is_deflt _ _)- | is_deflt                     = text "default type signature"- | otherwise                    = text "class method signature"-hsSigDoc (IdSig {})             = text "id signature"-hsSigDoc (SpecSig _ _ _ inl)-                                = ppr inl <+> text "pragma"-hsSigDoc (InlineSig _ _ prag)   = ppr (inlinePragmaSpec prag) <+> text "pragma"-hsSigDoc (SpecInstSig _ src _)-                                = pprWithSourceText src empty <+> text "instance pragma"-hsSigDoc (FixSig {})            = text "fixity declaration"-hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"-hsSigDoc (SCCFunSig {})         = text "SCC pragma"-hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"-hsSigDoc (XSig {})              = text "XSIG TTG extension"--{--Check if signatures overlap; this is used when checking for duplicate-signatures. Since some of the signatures contain a list of names, testing for-equality is not enough -- we have to check if they overlap.--}--instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where-    ppr sig = ppr_sig sig--ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc-ppr_sig (TypeSig _ vars ty)  = pprVarSig (map unLoc vars) (ppr ty)-ppr_sig (ClassOpSig _ is_deflt vars ty)-  | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)-  | otherwise                = pprVarSig (map unLoc vars) (ppr ty)-ppr_sig (IdSig _ id)         = pprVarSig [id] (ppr (varType id))-ppr_sig (FixSig _ fix_sig)   = ppr fix_sig-ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))-  = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)-                                             (interpp'SP ty) inl)-    where-      pragmaSrc = case spec of-        NoUserInline -> "{-# SPECIALISE"-        _            -> "{-# SPECIALISE_INLINE"-ppr_sig (InlineSig _ var inl)-  = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl-                                   <+> pprPrefixOcc (unLoc var))-ppr_sig (SpecInstSig _ src ty)-  = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)-ppr_sig (MinimalSig _ src bf)-  = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)-ppr_sig (PatSynSig _ names sig_ty)-  = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)-ppr_sig (SCCFunSig _ src fn mlabel)-  = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )-ppr_sig (CompleteMatchSig _ src cs mty)-  = pragSrcBrackets src "{-# COMPLETE"-      ((hsep (punctuate comma (map ppr (unLoc cs))))-        <+> opt_sig)-  where-    opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty-ppr_sig (XSig x) = ppr x--instance OutputableBndrId p-       => Outputable (FixitySig (GhcPass p)) where-  ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]-    where-      pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)-  ppr (XFixitySig x) = ppr x--pragBrackets :: SDoc -> SDoc-pragBrackets doc = text "{-#" <+> doc <+> text "#-}"---- | Using SourceText in case the pragma was spelled differently or used mixed--- case-pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc-pragSrcBrackets (SourceText src) _   doc = text src <+> doc <+> text "#-}"-pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"--pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc-pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]-  where-    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)--pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc-pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty-  where-    pp_inl | isDefaultInlinePragma inl = empty-           | otherwise = pprInline inl--pprTcSpecPrags :: TcSpecPrags -> SDoc-pprTcSpecPrags IsDefaultMethod = text "<default method>"-pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)--instance Outputable TcSpecPrag where-  ppr (SpecPrag var _ inl)-    = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl--pprMinimalSig :: (OutputableBndr name)-              => LBooleanFormula (Located name) -> SDoc-pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)--{--************************************************************************-*                                                                      *-\subsection[PatSynBind]{A pattern synonym definition}-*                                                                      *-************************************************************************--}---- | Haskell Pattern Synonym Details-type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]---- See Note [Record PatSyn Fields]--- | Record Pattern Synonym Field-data RecordPatSynField a-  = RecordPatSynField {-      recordPatSynSelectorId :: a  -- Selector name visible in rest of the file-      , recordPatSynPatVar :: a-      -- Filled in by renamer, the name used internally-      -- by the pattern-      } deriving (Data, Functor)----{--Note [Record PatSyn Fields]--Consider the following two pattern synonyms.--pattern P x y = ([x,True], [y,'v'])-pattern Q{ x, y } =([x,True], [y,'v'])--In P, we just have two local binders, x and y.--In Q, we have local binders but also top-level record selectors-x :: ([Bool], [Char]) -> Bool and similarly for y.--It would make sense to support record-like syntax--pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])--when we have a different name for the local and top-level binder-the distinction between the two names clear---}-instance Outputable a => Outputable (RecordPatSynField a) where-    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v--instance Foldable RecordPatSynField  where-    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible-                                 , recordPatSynPatVar = hidden })-      = f visible `mappend` f hidden--instance Traversable RecordPatSynField where-    traverse f (RecordPatSynField { recordPatSynSelectorId =visible-                                  , recordPatSynPatVar = hidden })-      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id-                                               , recordPatSynPatVar = pat_var })-          <$> f visible <*> f hidden----- | Haskell Pattern Synonym Direction-data HsPatSynDir id-  = Unidirectional-  | ImplicitBidirectional-  | ExplicitBidirectional (MatchGroup id (LHsExpr id))+{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[HsBinds]{Abstract syntax: top-level bindings and signatures}++Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.+-}++module GHC.Hs.Binds+  ( module Language.Haskell.Syntax.Binds+  , module GHC.Hs.Binds+  , HsRuleBndrsAnn(..)+  ) where++import GHC.Prelude++import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Binds+import Language.Haskell.Syntax.Expr( LHsExpr )++import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )+import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat )++import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )+import GHC.Types.Tickish+import GHC.Hs.Extension+import GHC.Parser.Annotation+import GHC.Hs.Type+import GHC.Tc.Types.Evidence+import GHC.Core.Type+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.SourceText+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Var+import GHC.Types.Name++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc ((<||>))++import Data.Function+import Data.List (sortBy)+import Data.Data (Data)++{-+************************************************************************+*                                                                      *+\subsection{Bindings: @BindGroup@}+*                                                                      *+************************************************************************++Global bindings (where clauses)+-}++-- the ...LR datatypes are parameterized by two id types,+-- one for the left and one for the right.++type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where"))+type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn (AnnList (EpToken "where"))+type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField+type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen++-- ---------------------------------------------------------------------+-- Deal with ValBindsOut++-- TODO: make this the only type for ValBinds+data NHsValBindsLR idL+  = NValBinds+      [(RecFlag, LHsBinds idL)]+      [LSig GhcRn]++type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag+type instance XXValBindsLR (GhcPass pL) pR+            = NHsValBindsLR (GhcPass pL)++-- ---------------------------------------------------------------------++type instance XFunBind    (GhcPass pL) GhcPs = NoExtField+type instance XFunBind    (GhcPass pL) GhcRn = NameSet+-- ^ After the renamer (but before the type-checker), the FunBind+-- extension field contains the locally-bound free variables of this+-- defn. See Note [Bind free vars]++type instance XFunBind    (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish])+-- ^ After the type-checker, the FunBind extension field contains+-- the ticks to put on the rhs, if any, and a coercion from the+-- type of the MatchGroup to the type of the Id.+-- Example:+--+-- @+--      f :: Int -> forall a. a -> a+--      f x y = y+-- @+--+-- Then the MatchGroup will have type (Int -> a' -> a')+-- (with a free type variable a').  The coercion will take+-- a CoreExpr of this type and convert it to a CoreExpr of+-- type         Int -> forall a'. a' -> a'+-- Notice that the coercion captures the free a'.++type instance XPatBind    GhcPs (GhcPass pR) = NoExtField+type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars]+type instance XPatBind    GhcTc (GhcPass pR) =+    ( Type                  -- Type of the GRHSs+    , ( [CoreTickish]       -- Ticks to put on the rhs, if any+      , [[CoreTickish]] ) ) -- and ticks to put on the bound variables.++type instance XVarBind (GhcPass pL) (GhcPass pR) = XVarBindGhc pL pR+type family XVarBindGhc pL pR where+  XVarBindGhc 'Typechecked 'Typechecked = NoExtField+  XVarBindGhc _     _                   = DataConCantHappen++type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField++type instance XXHsBindsLR GhcPs pR = DataConCantHappen+type instance XXHsBindsLR GhcRn pR = DataConCantHappen+type instance XXHsBindsLR GhcTc pR = AbsBinds++type instance XPSB         (GhcPass idL) GhcPs = AnnPSB+type instance XPSB         (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars]+type instance XPSB         (GhcPass idL) GhcTc = NameSet++type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen++data AnnPSB+  = AnnPSB {+      ap_pattern :: EpToken "pattern",+      ap_openc   :: Maybe (EpToken "{"),+      ap_closec  :: Maybe (EpToken "}"),+      ap_larrow  :: Maybe (EpUniToken "<-" "←"),+      ap_equal   :: Maybe (EpToken "=")+    } deriving Data++instance NoAnn AnnPSB where+  noAnn = AnnPSB noAnn noAnn noAnn noAnn noAnn++setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc+setTcMultAnn mult (HsLinearAnn _)   = HsLinearAnn mult+setTcMultAnn mult (HsExplicitMult _ p) = HsExplicitMult mult p+setTcMultAnn mult (HsUnannotated _) = HsUnannotated mult++getTcMultAnn :: HsMultAnn GhcTc -> Mult+getTcMultAnn (HsLinearAnn mult)   = mult+getTcMultAnn (HsExplicitMult mult _) = mult+getTcMultAnn (HsUnannotated mult) = mult++-- ---------------------------------------------------------------------++-- | Typechecked, generalised bindings, used in the output to the type checker.+-- See Note [AbsBinds].+data AbsBinds = AbsBinds {+      abs_tvs     :: [TyVar],+      abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints++     -- | AbsBinds only gets used when idL = idR after renaming,+     -- but these need to be idL's for the collect... code in HsUtil+     -- to have the right type+      abs_exports :: [ABExport],++      -- | Evidence bindings+      -- Why a list? See "GHC.Tc.TyCl.Instance"+      -- Note [Typechecking plan for instance declarations]+      abs_ev_binds :: [TcEvBinds],++      -- | Typechecked user bindings+      abs_binds    :: LHsBinds GhcTc,++      abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]+  }+++        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]+        --+        -- Creates bindings for (polymorphic, overloaded) poly_f+        -- in terms of monomorphic, non-overloaded mono_f+        --+        -- Invariants:+        --      1. 'binds' binds mono_f+        --      2. ftvs is a subset of tvs+        --      3. ftvs includes all tyvars free in ds+        --+        -- See Note [AbsBinds]++-- | Abstraction Bindings Export+data ABExport+  = ABE { abe_poly      :: Id           -- ^ Any INLINE pragma is attached to this Id+        , abe_mono      :: Id+        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]+             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly+        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas+        }++{-+Note [AbsBinds]+~~~~~~~~~~~~~~~+The AbsBinds constructor is used in the output of the type checker, to+record *typechecked* and *generalised* bindings.  Specifically++         AbsBinds { abs_tvs      = tvs+                  , abs_ev_vars  = [d1,d2]+                  , abs_exports  = [ABE { abe_poly = fp, abe_mono = fm+                                        , abe_wrap = fwrap }+                                    ABE { slly for g } ]+                  , abs_ev_binds = DBINDS+                  , abs_binds    = BIND[fm,gm] }++where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means++        fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS        ]+                   [                       ; BIND[fm,gm] } ]+                   [                 in fm                 ]++        gp = ...same again, with gm instead of fm++The 'fwrap' is an impedance-matcher that typically does nothing; see+Note [ABExport wrapper].++This is a pretty bad translation, because it duplicates all the bindings.+So the desugarer tries to do a better job:++        fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of+                                        (fm,gm) -> fm+        ..ditto for gp..++        tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }+                                      in (fm,gm)++In general:++  * abs_tvs are the type variables over which the binding group is+    generalised+  * abs_ev_var are the evidence variables (usually dictionaries)+    over which the binding group is generalised+  * abs_binds are the monomorphic bindings+  * abs_ex_binds are the evidence bindings that wrap the abs_binds+  * abs_exports connects the monomorphic Ids bound by abs_binds+    with the polymorphic Ids bound by the AbsBinds itself.++For example, consider a module M, with this top-level binding, where+there is no type signature for M.reverse,+    M.reverse []     = []+    M.reverse (x:xs) = M.reverse xs ++ [x]++In Hindley-Milner, a recursive binding is typechecked with the+*recursive* uses being *monomorphic*.  So after typechecking *and*+desugaring we will get something like this++    M.reverse :: forall a. [a] -> [a]+      = /\a. letrec+                reverse :: [a] -> [a] = \xs -> case xs of+                                                []     -> []+                                                (x:xs) -> reverse xs ++ [x]+             in reverse++Notice that 'M.reverse' is polymorphic as expected, but there is a local+definition for plain 'reverse' which is *monomorphic*.  The type variable+'a' scopes over the entire letrec.++That's after desugaring.  What about after type checking but before+desugaring?  That's where AbsBinds comes in.  It looks like this:++   AbsBinds { abs_tvs     = [a]+            , abs_ev_vars = []+            , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],+                                 , abe_mono = reverse :: [a] -> [a]}]+            , abs_ev_binds = {}+            , abs_binds = { reverse :: [a] -> [a]+                               = \xs -> case xs of+                                            []     -> []+                                            (x:xs) -> reverse xs ++ [x] } }++Here,++  * abs_tvs says what type variables are abstracted over the binding+    group, just 'a' in this case.+  * abs_binds is the *monomorphic* bindings of the group+  * abs_exports describes how to get the polymorphic Id 'M.reverse'+    from the monomorphic one 'reverse'++Notice that the *original* function (the polymorphic one you thought+you were defining) appears in the abe_poly field of the+abs_exports. The bindings in abs_binds are for fresh, local, Ids with+a *monomorphic* Id.++If there is a group of mutually recursive (see Note [Polymorphic+recursion]) functions without type signatures, we get one AbsBinds+with the monomorphic versions of the bindings in abs_binds, and one+element of abe_exports for each variable bound in the mutually+recursive group.  This is true even for pattern bindings.  Example:+        (f,g) = (\x -> x, f)+After type checking we get+   AbsBinds { abs_tvs     = [a]+            , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a+                                  , abe_mono = f :: a -> a }+                            , ABE { abe_poly = M.g :: forall a. a -> a+                                  , abe_mono = g :: a -> a }]+            , abs_binds = { (f,g) = (\x -> x, f) }++Note [Polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   Rec { f x = ...(g ef)...++       ; g :: forall a. [a] -> [a]+       ; g y = ...(f eg)...  }++These bindings /are/ mutually recursive (f calls g, and g calls f).+But we can use the type signature for g to break the recursion,+like this:++  1. Add g :: forall a. [a] -> [a] to the type environment++  2. Typecheck the definition of f, all by itself,+     including generalising it to find its most general+     type, say f :: forall b. b -> b -> [b]++  3. Extend the type environment with that type for f++  4. Typecheck the definition of g, all by itself,+     checking that it has the type claimed by its signature++Steps 2 and 4 each generate a separate AbsBinds, so we end+up with+   Rec { AbsBinds { ...for f ... }+       ; AbsBinds { ...for g ... } }++This approach allows both f and to call each other+polymorphically, even though only g has a signature.++We get an AbsBinds that encompasses multiple source-program+bindings only when+ * Each binding in the group has at least one binder that+   lacks a user type signature+ * The group forms a strongly connected component+++Note [The abs_sig field of AbsBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The abs_sig field supports a couple of special cases for bindings.+Consider++  x :: Num a => (# a, a #)+  x = (# 3, 4 #)++The general desugaring for AbsBinds would give++  x = /\a. \ ($dNum :: Num a) ->+      letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in+      xm++But that has an illegal let-binding for an unboxed tuple.  In this+case we'd prefer to generate the (more direct)++  x = /\ a. \ ($dNum :: Num a) ->+     (# fromInteger $dNum 3, fromInteger $dNum 4 #)++A similar thing happens with representation-polymorphic defns+(#11405):++  undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a+  undef = error "undef"++Again, the vanilla desugaring gives a local let-binding for a+representation-polymorphic (undefm :: a), which is illegal.  But+again we can desugar without a let:++  undef = /\ a. \ (d:HasCallStack) -> error a d "undef"++The abs_sig field supports this direct desugaring, with no local+let-binding.  When abs_sig = True++ * the abs_binds is single FunBind++ * the abs_exports is a singleton++ * we have a complete type sig for binder+   and hence the abs_binds is non-recursive+   (it binds the mono_id but refers to the poly_id++These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to+generate code without a let-binding.++Note [ABExport wrapper]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   (f,g) = (\x.x, \y.y)+This ultimately desugars to something like this:+   tup :: forall a b. (a->a, b->b)+   tup = /\a b. (\x:a.x, \y:b.y)+   f :: forall a. a -> a+   f = /\a. case tup a Any of+               (fm::a->a,gm:Any->Any) -> fm+   ...similarly for g...++The abe_wrap field deals with impedance-matching between+    (/\a b. case tup a b of { (f,g) -> f })+and the thing we really want, which may have fewer type+variables.  The action happens in GHC.Tc.Gen.Bind.mkExport.++Note [Bind free vars]+~~~~~~~~~~~~~~~~~~~~~+The extension fields of FunBind, PatBind and PatSynBind at GhcRn records the free+variables of the definition.  It is used for the following purposes:++a) Dependency analysis prior to type checking+    (see GHC.Tc.Gen.Bind.tc_group)++b) Deciding whether we can do generalisation of the binding+    (see GHC.Tc.Gen.Bind.decideGeneralisationPlan)++c) Deciding whether the binding can be used in static forms+    (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and+     GHC.Tc.Gen.Bind.isClosedBndrGroup).++Specifically,++  * it includes all free vars that are defined in this module+    (including top-level things and lexically scoped type variables)++  * it excludes imported vars; this is just to keep the set smaller++  * Before renaming, and after typechecking, the field is unused;+    it's just an error thunk+-}++instance (OutputableBndrId pl, OutputableBndrId pr)+        => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where+  ppr (HsValBinds _ bs)   = ppr bs+  ppr (HsIPBinds _ bs)    = ppr bs+  ppr (EmptyLocalBinds _) = empty++instance (OutputableBndrId pl, OutputableBndrId pr)+        => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where+  ppr (ValBinds _ binds sigs)+   = pprDeclList (pprLHsBindsForUser binds sigs)++  ppr (XValBindsLR (NValBinds sccs sigs))+    = getPprDebug $ \case+        -- Print with sccs showing+        True  -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)+        False -> pprDeclList (pprLHsBindsForUser (concat (map snd sccs)) sigs)+   where+     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds+     pp_rec Recursive    = text "rec"+     pp_rec NonRecursive = text "nonrec"++pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)+            => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc+pprLHsBinds binds+  | isEmptyLHsBinds binds = empty+  | otherwise = pprDeclList (map ppr binds)++pprLHsBindsForUser :: (OutputableBndrId idL,+                       OutputableBndrId idR,+                       OutputableBndrId id2)+     => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]+--  pprLHsBindsForUser is different to pprLHsBinds because+--  a) No braces: 'let' and 'where' include a list of HsBindGroups+--     and we don't want several groups of bindings each+--     with braces around+--  b) Sort by location before printing+--  c) Include signatures+pprLHsBindsForUser binds sigs+  = map snd (sort_by_loc decls)+  where++    decls :: [(SrcSpan, SDoc)]+    decls = [(locA loc, ppr sig)  | L loc sig <- sigs] +++            [(locA loc, ppr bind) | L loc bind <- binds]++    sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls++pprDeclList :: [SDoc] -> SDoc   -- Braces with a space+-- Print a bunch of declarations+-- One could choose  { d1; d2; ... }, using 'sep'+-- or      d1+--         d2+--         ..+--    using vcat+-- At the moment we chose the latter+-- Also we do the 'pprDeeperList' thing.+pprDeclList ds = pprDeeperList vcat ds++------------+emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)+emptyLocalBinds = EmptyLocalBinds noExtField++eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool+eqEmptyLocalBinds (EmptyLocalBinds _) = True+eqEmptyLocalBinds _                   = False++isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool+isEmptyValBinds (ValBinds _ ds sigs)  = isEmptyLHsBinds ds && null sigs+isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs++emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)+emptyValBindsIn  = ValBinds NoAnnSortKey [] []+emptyValBindsOut = XValBindsLR (NValBinds [] [])++emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR+emptyLHsBinds = []++isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool+isEmptyLHsBinds = null++------------+plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)+               -> HsValBinds(GhcPass a)+plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)+  = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2)+plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))+               (XValBindsLR (NValBinds ds2 sigs2))+  = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))+plusHsValBinds _ _+  = panic "HsBinds.plusHsValBinds"++instance (OutputableBndrId pl, OutputableBndrId pr)+         => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where+    ppr mbind = ppr_monobind mbind++ppr_monobind :: forall idL idR.+                (OutputableBndrId idL, OutputableBndrId idR)+             => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc++ppr_monobind (PatBind { pat_lhs = pat, pat_mult = mult_ann, pat_rhs = grhss })+  = pprHsMultAnn @idL mult_ann+    <+> pprPatBind pat grhss+ppr_monobind (VarBind { var_id = var, var_rhs = rhs })+  = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]+ppr_monobind (FunBind { fun_id = fun,+                        fun_matches = matches,+                        fun_ext = ext })+  = pprTicks empty ticksDoc+    $$  whenPprDebug (pprBndr LetBind (unLoc fun))+    $$  pprFunBind  matches+    $$  whenPprDebug (pprIfTc @idR $ wrapDoc)+        where+            ticksDoc :: SDoc+            ticksDoc = case ghcPass @idR of+                         GhcPs -> empty+                         GhcRn -> empty+                         GhcTc | (_, ticks) <- ext ->+                             if null ticks+                                then empty+                                else text "-- ticks = " <> ppr ticks+            wrapDoc :: SDoc+            wrapDoc = case ghcPass @idR of+                        GhcPs -> empty+                        GhcRn -> empty+                        GhcTc | (wrap, _) <- ext -> ppr wrap+++ppr_monobind (PatSynBind _ psb) = ppr psb+ppr_monobind (XHsBindsLR b) = case ghcPass @idL of+  GhcTc -> ppr_absbinds b+    where+      ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars+                             , abs_exports = exports, abs_binds = val_binds+                             , abs_ev_binds = ev_binds })+        = sdocOption sdocPrintTypecheckerElaboration $ \case+          False -> pprLHsBinds val_binds+          True  -> -- Show extra information (bug number: #10662)+                   hang (text "AbsBinds"+                         <+> sep [ brackets (interpp'SP tyvars)+                                 , brackets (interpp'SP dictvars) ])+                      2 $ braces $ vcat+                   [ text "Exports:" <+>+                       brackets (sep (punctuate comma (map ppr exports)))+                   , text "Exported types:" <+>+                       vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]+                   , text "Binds:" <+> pprLHsBinds val_binds+                   , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)+                   ]++instance Outputable ABExport where+  ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })+    = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ]+           , nest 2 (pprTcSpecPrags prags)+           , ppr $ nest 2 (text "wrap:" <+> ppr wrap) ]++instance (OutputableBndrId l, OutputableBndrId r)+          => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where+  ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,+            psb_dir = dir })+      = ppr_lhs <+> ppr_rhs+    where+      ppr_lhs = text "pattern" <+> ppr_details+      ppr_simple syntax = syntax <+> pprLPat pat++      ppr_details = case details of+          InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v  v2]+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v+          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr_v vs)+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v+          RecCon vs      -> pprPrefixOcc psyn+                            <> braces (sep (punctuate comma (map ppr_v vs)))+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v++      ppr_rhs = case dir of+          Unidirectional           -> ppr_simple larrow+          ImplicitBidirectional    -> ppr_simple equals+          ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$+                                      (nest 2 $ pprFunBind mg)++pprTicks :: SDoc -> SDoc -> SDoc+-- Print stuff about ticks only when -dppr-debug is on, to avoid+-- them appearing in error messages (from the desugarer); see # 3263+-- Also print ticks in dumpStyle, so that -ddump-hpc actually does+-- something useful.+pprTicks pp_no_debug pp_when_debug+  = getPprStyle $ \sty ->+    getPprDebug $ \debug ->+      if debug || dumpStyle sty+         then pp_when_debug+         else pp_no_debug++instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v++{-+************************************************************************+*                                                                      *+                Implicit parameter bindings+*                                                                      *+************************************************************************+-}++type instance XIPBinds       GhcPs = NoExtField+type instance XIPBinds       GhcRn = NoExtField+type instance XIPBinds       GhcTc = TcEvBinds -- binds uses of the+                                               -- implicit parameters+++type instance XXHsIPBinds    (GhcPass p) = DataConCantHappen++isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool+isEmptyIPBindsPR (IPBinds _ is) = null is++isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool+isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds++-- EPA annotations in GhcPs, dictionary Id in GhcTc+type instance XCIPBind GhcPs = EpToken "="+type instance XCIPBind GhcRn = NoExtField+type instance XCIPBind GhcTc = Id+type instance XXIPBind    (GhcPass p) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (HsIPBinds (GhcPass p)) where+  ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)+                        $$ whenPprDebug (pprIfTc @p $ ppr ds)++instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where+  ppr (IPBind x (L _ ip) rhs) = name <+> equals <+> pprExpr (unLoc rhs)+    where name = case ghcPass @p of+            GhcPs -> pprBndr LetBind ip+            GhcRn -> pprBndr LetBind ip+            GhcTc -> pprBndr LetBind x++{-+************************************************************************+*                                                                      *+\subsection{@Sig@: type signatures and value-modifying user pragmas}+*                                                                      *+************************************************************************+-}++type instance XTypeSig          (GhcPass p) = AnnSig+type instance XPatSynSig        (GhcPass p) = AnnSig+type instance XClassOpSig       (GhcPass p) = AnnSig+type instance XFixSig           (GhcPass p) = ((EpaLocation, Maybe EpaLocation), SourceText)+type instance XInlineSig        (GhcPass p) = (EpaLocation, EpToken "#-}", ActivationAnn)+type instance XSpecSig          (GhcPass p) = AnnSpecSig+type instance XSpecInstSig      (GhcPass p) = ((EpaLocation, EpToken "instance", EpToken "#-}"), SourceText)+type instance XMinimalSig       (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText)+type instance XSCCFunSig        (GhcPass p) = ((EpaLocation, EpToken "#-}"), SourceText)+type instance XCompleteMatchSig (GhcPass p) = ((EpaLocation, Maybe TokDcolon, EpToken "#-}"), SourceText)++type instance XSpecSigE         GhcPs = AnnSpecSig+type instance XSpecSigE         GhcRn = Name+type instance XSpecSigE         GhcTc = NoExtField++    -- SourceText: See Note [Pragma source text] in "GHC.Types.SourceText"+type instance XXSig             GhcPs = DataConCantHappen+type instance XXSig             GhcRn = IdSig+type instance XXSig             GhcTc = IdSig++type instance XFixitySig  GhcPs = NamespaceSpecifier+type instance XFixitySig  GhcRn = NamespaceSpecifier+type instance XFixitySig  GhcTc = NoExtField+type instance XXFixitySig (GhcPass p) = DataConCantHappen++data AnnSpecSig+  = AnnSpecSig {+      ass_open   :: EpaLocation,+      ass_close  :: EpToken "#-}",+      ass_dcolon :: Maybe TokDcolon, -- Only for old SpecSig, remove when it goes+      ass_act    :: ActivationAnn+    } deriving Data++instance NoAnn AnnSpecSig where+  noAnn = AnnSpecSig noAnn noAnn noAnn noAnn++data ActivationAnn+  = ActivationAnn {+      aa_openc  :: EpToken "[",+      aa_closec :: EpToken "]",+      aa_tilde  :: Maybe (EpToken "~"),+      aa_val    :: Maybe EpaLocation+    } deriving (Data, Eq)++instance NoAnn ActivationAnn where+  noAnn = ActivationAnn noAnn noAnn noAnn noAnn+++-- | Optional namespace specifier for fixity signatures,+--  WARNINIG and DEPRECATED pragmas.+--+-- Examples:+--+--   {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-}+--                            -- ↑ DataNamespaceSpecifier+--+--   {-# DEPRECATED type D "This type was deprecated" #-}+--                -- ↑ TypeNamespaceSpecifier+--+--   infixr 6 data $+--          -- ↑ DataNamespaceSpecifier+data NamespaceSpecifier+  = NoNamespaceSpecifier+  | TypeNamespaceSpecifier (EpToken "type")+  | DataNamespaceSpecifier (EpToken "data")+  deriving (Eq, Data)++-- | Check if namespace specifiers overlap, i.e. if they are equal or+-- if at least one of them doesn't specify a namespace+overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool+overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True+overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True+overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers _ _ = False++-- | Check if namespace is covered by a namespace specifier:+--     * NoNamespaceSpecifier covers both namespaces+--     * TypeNamespaceSpecifier covers the type namespace only+--     * DataNamespaceSpecifier covers the data namespace only+coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool+coveredByNamespaceSpecifier NoNamespaceSpecifier = const True+coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace+coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace+instance Outputable NamespaceSpecifier where+  ppr NoNamespaceSpecifier = empty+  ppr TypeNamespaceSpecifier{} = text "type"+  ppr DataNamespaceSpecifier{} = text "data"++-- | A type signature in generated code, notably the code+-- generated for record selectors. We simply record the desired Id+-- itself, replete with its name, type and IdDetails. Otherwise it's+-- just like a type signature: there should be an accompanying binding+newtype IdSig = IdSig { unIdSig :: Id }+    deriving Data++data AnnSig+  = AnnSig {+      asDcolon  :: EpUniToken "::" "∷",+      asPattern :: Maybe (EpToken "pattern"),+      asDefault :: Maybe (EpToken "default")+      } deriving Data++instance NoAnn AnnSig where+  noAnn = AnnSig noAnn noAnn noAnn++-- | Type checker Specialisation Pragmas+--+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker+-- to the desugarer+data TcSpecPrags+  = IsDefaultMethod     -- ^ Super-specialised: a default method should+                        -- be macro-expanded at every call site+  | SpecPrags [LTcSpecPrag]++-- | Located Type checker Specialisation Pragmas+type LTcSpecPrag = Located TcSpecPrag++-- | Type checker Specialisation Pragma+--+-- This data type is used to communicate between the typechecker and+-- the desugarer.+data TcSpecPrag+  -- | Old-form specialise pragma+  = SpecPrag+      Id+      -- ^ 'Id' to be specialised+      HsWrapper+      -- ^ wrapper that specialises the polymorphic function+      InlinePragma+      -- ^ inlining spec for the specialised function+   -- | New-form specialise pragma+   | SpecPragE+     { spe_fn_nm :: Name+       -- ^ 'Name' of the 'Id' being specialised+     , spe_fn_id :: Id+        -- ^ 'Id' being specialised+        --+        -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@+        -- in the case of instance methods, where the 'Name' is the+        -- class-op selector but the 'spe_fn_id' is that for the local method+     , spe_inl   :: InlinePragma+        -- ^ (optional) INLINE annotation and activation phase annotation++     , spe_bndrs :: [Var]+        -- ^ TyVars, EvVars, and Ids+     , spe_call  :: LHsExpr GhcTc+        -- ^ The type-checked specialise expression+     }++noSpecPrags :: TcSpecPrags+noSpecPrags = SpecPrags []++hasSpecPrags :: TcSpecPrags -> Bool+hasSpecPrags (SpecPrags ps) = not (null ps)+hasSpecPrags IsDefaultMethod = False++isDefaultMethod :: TcSpecPrags -> Bool+isDefaultMethod IsDefaultMethod = True+isDefaultMethod (SpecPrags {})  = False++instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where+    ppr sig = ppr_sig sig++ppr_sig :: forall p. OutputableBndrId p+        => Sig (GhcPass p) -> SDoc+ppr_sig (TypeSig _ vars ty)  = pprVarSig (map unLoc vars) (ppr ty)+ppr_sig (ClassOpSig _ is_deflt vars ty)+  | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)+  | otherwise                = pprVarSig (map unLoc vars) (ppr ty)+ppr_sig (FixSig _ fix_sig)   = ppr fix_sig++ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_src = src, inl_inline = spec }))+  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $+    pprSpec (unLoc var) (interpp'SP ty) inl+    where+      pragmaSrc = case spec of+        NoUserInlinePrag -> "{-# " ++ extractSpecPragName src+        _                -> "{-# " ++ extractSpecPragName src  ++ "_INLINE"++ppr_sig (SpecSigE _ bndrs spec_e inl@(InlinePragma { inl_src = src, inl_inline = spec }))+  = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc $+    pp_inl <+> hang (ppr bndrs) 2 (pprLExpr spec_e)+  where+    -- SPECIALISE or SPECIALISE_INLINE+    pragmaSrc = case spec of+      NoUserInlinePrag -> "{-# " ++ extractSpecPragName src+      _                -> "{-# " ++ extractSpecPragName src  ++ "_INLINE"++    pp_inl | isDefaultInlinePragma inl = empty+           | otherwise = pprInline inl++ppr_sig (InlineSig _ var inl)+  = ppr_pfx <+> pprInline inl <+> pprPrefixOcc (unLoc var) <+> text "#-}"+    where+      ppr_pfx = case inlinePragmaSource inl of+        SourceText src -> ftext src+        NoSourceText   -> text "{-#" <+> inlinePragmaName (inl_inline inl)++ppr_sig (SpecInstSig (_, src) ty)+  = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)+ppr_sig (MinimalSig (_, src) bf)+  = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)+ppr_sig (PatSynSig _ names sig_ty)+  = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)+ppr_sig (SCCFunSig (_, src) fn mlabel)+  = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )+      where+        ppr_fn = case ghcPass @p of+          GhcPs -> ppr fn+          GhcRn -> ppr fn+          GhcTc -> ppr fn+ppr_sig (CompleteMatchSig (_, src) cs mty)+  = pragSrcBrackets src "{-# COMPLETE"+      ((hsep (punctuate comma (map ppr_n cs)))+        <+> opt_sig)+  where+    opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty+    ppr_n n = case ghcPass @p of+        GhcPs -> ppr n+        GhcRn -> ppr n+        GhcTc -> ppr n+ppr_sig (XSig x) = case ghcPass @p of+                      GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id))+                      GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id))++hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc+hsSigDoc (TypeSig {})           = text "type signature"+hsSigDoc (PatSynSig {})         = text "pattern synonym signature"+hsSigDoc (ClassOpSig _ is_deflt _ _)+ | is_deflt                     = text "default type signature"+ | otherwise                    = text "class method signature"+hsSigDoc (SpecSig _ _ _ inl)    = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"+hsSigDoc (SpecSigE _ _ _ inl)   = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"+hsSigDoc (InlineSig _ _ prag)   = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"+-- Using the 'inlinePragmaName' function ensures that the pragma name for any+-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted+-- from the InlineSpec field of the pragma.+hsSigDoc (SpecInstSig (_, src) _)  = text (extractSpecPragName src) <+> text "instance pragma"+hsSigDoc (FixSig {})            = text "fixity declaration"+hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"+hsSigDoc (SCCFunSig {})         = text "SCC pragma"+hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"+hsSigDoc (XSig _)               = case ghcPass @p of+                                    GhcRn -> text "id signature"+                                    GhcTc -> text "id signature"++-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src+-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE+-- instance pragma of the form: "SourceText {-# SPECIALIZE"+--+-- Extraction ensures that all variants of the pragma name (with a 'Z' or an+-- 'S') are output exactly as used in the pragma.+extractSpecPragName :: SourceText -> String+extractSpecPragName srcTxt =  case (words $ show srcTxt) of+     (_:_:pragName:_) -> filter (/= '\"') pragName+     _                -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt)++instance OutputableBndrId p+       => Outputable (FixitySig (GhcPass p)) where+  ppr (FixitySig ns_spec names fixity) = sep [ppr fixity, ppr_ns_spec, pprops]+    where+      ppr_ns_spec =+        case ghcPass @p of+          GhcPs -> ppr ns_spec+          GhcRn -> ppr ns_spec+          GhcTc -> empty+      pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)++pragBrackets :: SDoc -> SDoc+pragBrackets doc = text "{-#" <+> doc <+> text "#-}"++-- | Using SourceText in case the pragma was spelled differently or used mixed+-- case+pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc+pragSrcBrackets (SourceText src) _   doc = ftext src <+> doc <+> text "#-}"+pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"++pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc+pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]+  where+    pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)++pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc+pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty+  where+    pp_inl | isDefaultInlinePragma inl = empty+           | otherwise = pprInline inl++pprTcSpecPrags :: TcSpecPrags -> SDoc+pprTcSpecPrags IsDefaultMethod = text "<default method>"+pprTcSpecPrags (SpecPrags ps)  = vcat (map (ppr . unLoc) ps)++instance Outputable TcSpecPrag where+  ppr (SpecPrag var _ inl)+    = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl+  ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl })+    = text (extractSpecPragName $ inl_src inl)+       <+> hang (ppr bndrs) 2 (pprLExpr spec_e)++pprMinimalSig :: OutputableBndrId p  => LBooleanFormula (GhcPass p) -> SDoc+pprMinimalSig (L _ bf) = pprBooleanFormulaNormal bf+++{- *********************************************************************+*                                                                      *+                  RuleBndrs+*                                                                      *+********************************************************************* -}++data HsRuleBndrsAnn+  = HsRuleBndrsAnn+       { rb_tyanns :: Maybe (TokForall, EpToken ".")+                 -- ^ The locations of 'forall' and '.' for forall'd type vars+                 -- Using AddEpAnn to capture possible unicode variants+       , rb_tmanns :: Maybe (TokForall, EpToken ".")+                 -- ^ The locations of 'forall' and '.' for forall'd term vars+                 -- Using AddEpAnn to capture possible unicode variants+       } deriving (Data, Eq)++instance NoAnn HsRuleBndrsAnn where+  noAnn = HsRuleBndrsAnn Nothing Nothing++++type instance XXRuleBndrs   (GhcPass _) = DataConCantHappen+type instance XCRuleBndrs   GhcPs = HsRuleBndrsAnn+type instance XCRuleBndrs   GhcRn = NoExtField+type instance XCRuleBndrs   GhcTc = [Var]   -- Binders of the rule, not+                                            -- necessarily in dependency order++type instance XRuleBndrSig  (GhcPass _) = AnnTyVarBndr+type instance XCRuleBndr    (GhcPass _) = AnnTyVarBndr+type instance XXRuleBndr    (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (RuleBndrs (GhcPass p)) where+   ppr (RuleBndrs { rb_tyvs = tyvs, rb_tmvs = tmvs })+     = pp_forall_ty tyvs <+> pp_forall_tm tyvs+     where+       pp_forall_ty Nothing     = empty+       pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot+       pp_forall_tm Nothing | null tmvs = empty+       pp_forall_tm _ = forAllLit <+> fsep (map ppr tmvs) <> dot++instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where+   ppr (RuleBndr _ name) = ppr name+   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA+type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA+type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO++type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA++type instance Anno StringLiteral = EpAnnCO
GHC/Hs/Decls.hs view
@@ -1,2464 +1,1515 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,-             DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}---- | Abstract syntax of global declarations.------ Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,--- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.-module GHC.Hs.Decls (-  -- * Toplevel declarations-  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,-  HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,-  StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,--  -- ** Class or type declarations-  TyClDecl(..), LTyClDecl, DataDeclRn(..),-  TyClGroup(..),-  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,-  tyClGroupKindSigs,-  isClassDecl, isDataDecl, isSynDecl, tcdName,-  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,-  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,-  tyFamInstDeclName, tyFamInstDeclLName,-  countTyClDecls, pprTyClDeclFlavour,-  tyClDeclLName, tyClDeclTyVars,-  hsDeclHasCusk, famResultKindSignature,-  FamilyDecl(..), LFamilyDecl,--  -- ** Instance declarations-  InstDecl(..), LInstDecl, FamilyInfo(..),-  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,-  TyFamDefltDecl, LTyFamDefltDecl,-  DataFamInstDecl(..), LDataFamInstDecl,-  pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,-  FamInstEqn, LFamInstEqn, FamEqn(..),-  TyFamInstEqn, LTyFamInstEqn, HsTyPats,-  LClsInstDecl, ClsInstDecl(..),--  -- ** Standalone deriving declarations-  DerivDecl(..), LDerivDecl,-  -- ** Deriving strategies-  DerivStrategy(..), LDerivStrategy,-  derivStrategyName, foldDerivStrategy, mapDerivStrategy,-  -- ** @RULE@ declarations-  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),-  RuleBndr(..),LRuleBndr,-  collectRuleBndrSigTys,-  flattenRuleDecls, pprFullRuleName,-  -- ** @default@ declarations-  DefaultDecl(..), LDefaultDecl,-  -- ** Template haskell declaration splice-  SpliceExplicitFlag(..),-  SpliceDecl(..), LSpliceDecl,-  -- ** Foreign function interface declarations-  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),-  CImportSpec(..),-  -- ** Data-constructor declarations-  ConDecl(..), LConDecl,-  HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,-  getConNames, getConArgs,-  -- ** Document comments-  DocDecl(..), LDocDecl, docDeclDoc,-  -- ** Deprecations-  WarnDecl(..),  LWarnDecl,-  WarnDecls(..), LWarnDecls,-  -- ** Annotations-  AnnDecl(..), LAnnDecl,-  AnnProvenance(..), annProvenanceName_maybe,-  -- ** Role annotations-  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,-  -- ** Injective type families-  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,-  resultVariableName, familyDeclLName, familyDeclName,--  -- * Grouping-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls--    ) where---- friends:-import GhcPrelude--import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr,-                                   pprSpliceDecl )-        -- Because Expr imports Decls via HsBracket--import GHC.Hs.Binds-import GHC.Hs.Types-import GHC.Hs.Doc-import TyCon-import BasicTypes-import Coercion-import ForeignCall-import GHC.Hs.Extension-import NameSet---- others:-import Class-import Outputable-import Util-import SrcLoc-import Type--import Bag-import Maybes-import Data.Data        hiding (TyCon,Fixity, Infix)--{--************************************************************************-*                                                                      *-\subsection[HsDecl]{Declarations}-*                                                                      *-************************************************************************--}--type LHsDecl p = Located (HsDecl p)-        -- ^ When in a list this may have-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'-        ------ For details on above see note [Api annotations] in ApiAnnotation---- | A Haskell Declaration-data HsDecl p-  = TyClD      (XTyClD p)      (TyClDecl p)      -- ^ Type or Class Declaration-  | InstD      (XInstD p)      (InstDecl  p)     -- ^ Instance declaration-  | DerivD     (XDerivD p)     (DerivDecl p)     -- ^ Deriving declaration-  | ValD       (XValD p)       (HsBind p)        -- ^ Value declaration-  | SigD       (XSigD p)       (Sig p)           -- ^ Signature declaration-  | KindSigD   (XKindSigD p)   (StandaloneKindSig p) -- ^ Standalone kind signature-  | DefD       (XDefD p)       (DefaultDecl p)   -- ^ 'default' declaration-  | ForD       (XForD p)       (ForeignDecl p)   -- ^ Foreign declaration-  | WarningD   (XWarningD p)   (WarnDecls p)     -- ^ Warning declaration-  | AnnD       (XAnnD p)       (AnnDecl p)       -- ^ Annotation declaration-  | RuleD      (XRuleD p)      (RuleDecls p)     -- ^ Rule declaration-  | SpliceD    (XSpliceD p)    (SpliceDecl p)    -- ^ Splice declaration-                                                 -- (Includes quasi-quotes)-  | DocD       (XDocD p)       (DocDecl)  -- ^ Documentation comment declaration-  | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration-  | XHsDecl    (XXHsDecl p)--type instance XTyClD      (GhcPass _) = NoExtField-type instance XInstD      (GhcPass _) = NoExtField-type instance XDerivD     (GhcPass _) = NoExtField-type instance XValD       (GhcPass _) = NoExtField-type instance XSigD       (GhcPass _) = NoExtField-type instance XKindSigD   (GhcPass _) = NoExtField-type instance XDefD       (GhcPass _) = NoExtField-type instance XForD       (GhcPass _) = NoExtField-type instance XWarningD   (GhcPass _) = NoExtField-type instance XAnnD       (GhcPass _) = NoExtField-type instance XRuleD      (GhcPass _) = NoExtField-type instance XSpliceD    (GhcPass _) = NoExtField-type instance XDocD       (GhcPass _) = NoExtField-type instance XRoleAnnotD (GhcPass _) = NoExtField-type instance XXHsDecl    (GhcPass _) = NoExtCon---- NB: all top-level fixity decls are contained EITHER--- EITHER SigDs--- OR     in the ClassDecls in TyClDs------ The former covers---      a) data constructors---      b) class methods (but they can be also done in the---              signatures of class decls)---      c) imported functions (that have an IfacSig)---      d) top level decls------ The latter is for class methods only---- | Haskell Group------ A 'HsDecl' is categorised into a 'HsGroup' before being--- fed to the renamer.-data HsGroup p-  = HsGroup {-        hs_ext    :: XCHsGroup p,-        hs_valds  :: HsValBinds p,-        hs_splcds :: [LSpliceDecl p],--        hs_tyclds :: [TyClGroup p],-                -- A list of mutually-recursive groups;-                -- This includes `InstDecl`s as well;-                -- Parser generates a singleton list;-                -- renamer does dependency analysis--        hs_derivds :: [LDerivDecl p],--        hs_fixds  :: [LFixitySig p],-                -- Snaffled out of both top-level fixity signatures,-                -- and those in class declarations--        hs_defds  :: [LDefaultDecl p],-        hs_fords  :: [LForeignDecl p],-        hs_warnds :: [LWarnDecls p],-        hs_annds  :: [LAnnDecl p],-        hs_ruleds :: [LRuleDecls p],--        hs_docs   :: [LDocDecl]-    }-  | XHsGroup (XXHsGroup p)--type instance XCHsGroup (GhcPass _) = NoExtField-type instance XXHsGroup (GhcPass _) = NoExtCon---emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)-emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }-emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }--hsGroupInstDecls :: HsGroup id -> [LInstDecl id]-hsGroupInstDecls = (=<<) group_instds . hs_tyclds--emptyGroup = HsGroup { hs_ext = noExtField,-                       hs_tyclds = [],-                       hs_derivds = [],-                       hs_fixds = [], hs_defds = [], hs_annds = [],-                       hs_fords = [], hs_warnds = [], hs_ruleds = [],-                       hs_valds = error "emptyGroup hs_valds: Can't happen",-                       hs_splcds = [],-                       hs_docs = [] }--appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)-             -> HsGroup (GhcPass p)-appendGroups-    HsGroup {-        hs_valds  = val_groups1,-        hs_splcds = spliceds1,-        hs_tyclds = tyclds1,-        hs_derivds = derivds1,-        hs_fixds  = fixds1,-        hs_defds  = defds1,-        hs_annds  = annds1,-        hs_fords  = fords1,-        hs_warnds = warnds1,-        hs_ruleds = rulds1,-        hs_docs   = docs1 }-    HsGroup {-        hs_valds  = val_groups2,-        hs_splcds = spliceds2,-        hs_tyclds = tyclds2,-        hs_derivds = derivds2,-        hs_fixds  = fixds2,-        hs_defds  = defds2,-        hs_annds  = annds2,-        hs_fords  = fords2,-        hs_warnds = warnds2,-        hs_ruleds = rulds2,-        hs_docs   = docs2 }-  =-    HsGroup {-        hs_ext    = noExtField,-        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,-        hs_splcds = spliceds1 ++ spliceds2,-        hs_tyclds = tyclds1 ++ tyclds2,-        hs_derivds = derivds1 ++ derivds2,-        hs_fixds  = fixds1 ++ fixds2,-        hs_annds  = annds1 ++ annds2,-        hs_defds  = defds1 ++ defds2,-        hs_fords  = fords1 ++ fords2,-        hs_warnds = warnds1 ++ warnds2,-        hs_ruleds = rulds1 ++ rulds2,-        hs_docs   = docs1  ++ docs2 }-appendGroups _ _ = panic "appendGroups"--instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where-    ppr (TyClD _ dcl)             = ppr dcl-    ppr (ValD _ binds)            = ppr binds-    ppr (DefD _ def)              = ppr def-    ppr (InstD _ inst)            = ppr inst-    ppr (DerivD _ deriv)          = ppr deriv-    ppr (ForD _ fd)               = ppr fd-    ppr (SigD _ sd)               = ppr sd-    ppr (KindSigD _ ksd)          = ppr ksd-    ppr (RuleD _ rd)              = ppr rd-    ppr (WarningD _ wd)           = ppr wd-    ppr (AnnD _ ad)               = ppr ad-    ppr (SpliceD _ dd)            = ppr dd-    ppr (DocD _ doc)              = ppr doc-    ppr (RoleAnnotD _ ra)         = ppr ra-    ppr (XHsDecl x)               = ppr x--instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where-    ppr (HsGroup { hs_valds  = val_decls,-                   hs_tyclds = tycl_decls,-                   hs_derivds = deriv_decls,-                   hs_fixds  = fix_decls,-                   hs_warnds = deprec_decls,-                   hs_annds  = ann_decls,-                   hs_fords  = foreign_decls,-                   hs_defds  = default_decls,-                   hs_ruleds = rule_decls })-        = vcat_mb empty-            [ppr_ds fix_decls, ppr_ds default_decls,-             ppr_ds deprec_decls, ppr_ds ann_decls,-             ppr_ds rule_decls,-             if isEmptyValBinds val_decls-                then Nothing-                else Just (ppr val_decls),-             ppr_ds (tyClGroupRoleDecls tycl_decls),-             ppr_ds (tyClGroupKindSigs  tycl_decls),-             ppr_ds (tyClGroupTyClDecls tycl_decls),-             ppr_ds (tyClGroupInstDecls tycl_decls),-             ppr_ds deriv_decls,-             ppr_ds foreign_decls]-        where-          ppr_ds :: Outputable a => [a] -> Maybe SDoc-          ppr_ds [] = Nothing-          ppr_ds ds = Just (vcat (map ppr ds))--          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc-          -- Concatenate vertically with white-space between non-blanks-          vcat_mb _    []             = empty-          vcat_mb gap (Nothing : ds) = vcat_mb gap ds-          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds-    ppr (XHsGroup x) = ppr x---- | Located Splice Declaration-type LSpliceDecl pass = Located (SpliceDecl pass)---- | Splice Declaration-data SpliceDecl p-  = SpliceDecl                  -- Top level splice-        (XSpliceDecl p)-        (Located (HsSplice p))-        SpliceExplicitFlag-  | XSpliceDecl (XXSpliceDecl p)--type instance XSpliceDecl      (GhcPass _) = NoExtField-type instance XXSpliceDecl     (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (SpliceDecl (GhcPass p)) where-   ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f-   ppr (XSpliceDecl x) = ppr x--{--************************************************************************-*                                                                      *-            Type and class declarations-*                                                                      *-************************************************************************--Note [The Naming story]-~~~~~~~~~~~~~~~~~~~~~~~-Here is the story about the implicit names that go with type, class,-and instance decls.  It's a bit tricky, so pay attention!--"Implicit" (or "system") binders-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  Each data type decl defines-        a worker name for each constructor-        to-T and from-T convertors-  Each class decl defines-        a tycon for the class-        a data constructor for that tycon-        the worker for that constructor-        a selector for each superclass--All have occurrence names that are derived uniquely from their parent-declaration.--None of these get separate definitions in an interface file; they are-fully defined by the data or class decl.  But they may *occur* in-interface files, of course.  Any such occurrence must haul in the-relevant type or class decl.--Plan of attack:- - Ensure they "point to" the parent data/class decl-   when loading that decl from an interface file-   (See RnHiFiles.getSysBinders)-- - When typechecking the decl, we build the implicit TyCons and Ids.-   When doing so we look them up in the name cache (RnEnv.lookupSysName),-   to ensure correct module and provenance is set--These are the two places that we have to conjure up the magic derived-names.  (The actual magic is in OccName.mkWorkerOcc, etc.)--Default methods-~~~~~~~~~~~~~~~- - Occurrence name is derived uniquely from the method name-   E.g. $dmmax-- - If there is a default method name at all, it's recorded in-   the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field.-   (DefMethInfo is defined in Class.hs)--Source-code class decls and interface-code class decls are treated subtly-differently, which has given me a great deal of confusion over the years.-Here's the deal.  (We distinguish the two cases because source-code decls-have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.--In *source-code* class declarations:-- - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName-   This is done by RdrHsSyn.mkClassOpSigDM-- - The renamer renames it to a Name-- - During typechecking, we generate a binding for each $dm for-   which there's a programmer-supplied default method:-        class Foo a where-          op1 :: <type>-          op2 :: <type>-          op1 = ...-   We generate a binding for $dmop1 but not for $dmop2.-   The Class for Foo has a Nothing for op2 and-                         a Just ($dm_op1, VanillaDM) for op1.-   The Name for $dmop2 is simply discarded.--In *interface-file* class declarations:-  - When parsing, we see if there's an explicit programmer-supplied default method-    because there's an '=' sign to indicate it:-        class Foo a where-          op1 = :: <type>       -- NB the '='-          op2   :: <type>-    We use this info to generate a DefMeth with a suitable RdrName for op1,-    and a NoDefMeth for op2-  - The interface file has a separate definition for $dmop1, with unfolding etc.-  - The renamer renames it to a Name.-  - The renamer treats $dmop1 as a free variable of the declaration, so that-    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)-    This doesn't happen for source code class decls, because they *bind* the default method.--Dictionary functions-~~~~~~~~~~~~~~~~~~~~-Each instance declaration gives rise to one dictionary function binding.--The type checker makes up new source-code instance declarations-(e.g. from 'deriving' or generic default methods --- see-TcInstDcls.tcInstDecls1).  So we can't generate the names for-dictionary functions in advance (we don't know how many we need).--On the other hand for interface-file instance declarations, the decl-specifies the name of the dictionary function, and it has a binding elsewhere-in the interface file:-        instance {Eq Int} = dEqInt-        dEqInt :: {Eq Int} <pragma info>--So again we treat source code and interface file code slightly differently.--Source code:-  - Source code instance decls have a Nothing in the (Maybe name) field-    (see data InstDecl below)--  - The typechecker makes up a Local name for the dict fun for any source-code-    instance decl, whether it comes from a source-code instance decl, or whether-    the instance decl is derived from some other construct (e.g. 'deriving').--  - The occurrence name it chooses is derived from the instance decl (just for-    documentation really) --- e.g. dNumInt.  Two dict funs may share a common-    occurrence name, but will have different uniques.  E.g.-        instance Foo [Int]  where ...-        instance Foo [Bool] where ...-    These might both be dFooList--  - The CoreTidy phase externalises the name, and ensures the occurrence name is-    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.--  - We can take this relaxed approach (changing the occurrence name later)-    because dict fun Ids are not captured in a TyCon or Class (unlike default-    methods, say).  Instead, they are kept separately in the InstEnv.  This-    makes it easy to adjust them after compiling a module.  (Once we've finished-    compiling that module, they don't change any more.)---Interface file code:-  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)-    in the (Maybe name) field.--  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we-    suck in the dfun binding--}---- | Located Declaration of a Type or Class-type LTyClDecl pass = Located (TyClDecl pass)---- | A type or class declaration.-data TyClDecl pass-  = -- | @type/data family T :: *->*@-    ---    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',-    --             'ApiAnnotation.AnnData',-    --             'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon',-    --             'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP',-    --             'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP',-    --             'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow',-    --             'ApiAnnotation.AnnVbar'--    -- For details on above see note [Api annotations] in ApiAnnotation-    FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }--  | -- | @type@ declaration-    ---    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',-    --             'ApiAnnotation.AnnEqual',--    -- For details on above see note [Api annotations] in ApiAnnotation-    SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs-            , tcdLName  :: Located (IdP pass)     -- ^ Type constructor-            , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an-                                                  -- associated type these-                                                  -- include outer binders-            , tcdFixity :: LexicalFixity    -- ^ Fixity used in the declaration-            , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration--  | -- | @data@ declaration-    ---    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',-    --              'ApiAnnotation.AnnFamily',-    --              'ApiAnnotation.AnnNewType',-    --              'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon'-    --              'ApiAnnotation.AnnWhere',--    -- For details on above see note [Api annotations] in ApiAnnotation-    DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs-             , tcdLName    :: Located (IdP pass)   -- ^ Type constructor-             , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables-                              -- See Note [TyVar binders for associated declarations]-             , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration-             , tcdDataDefn :: HsDataDefn pass }--  | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs-                tcdCtxt    :: LHsContext pass,         -- ^ Context...-                tcdLName   :: Located (IdP pass),      -- ^ Name of the class-                tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables-                tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration-                tcdFDs     :: [LHsFunDep pass],         -- ^ Functional deps-                tcdSigs    :: [LSig pass],              -- ^ Methods' signatures-                tcdMeths   :: LHsBinds pass,            -- ^ Default methods-                tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;-                tcdATDefs  :: [LTyFamDefltDecl pass],   -- ^ Associated type defaults-                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs-    }-        -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass',-        --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',-        --           'ApiAnnotation.AnnClose'-        --   - The tcdFDs will have 'ApiAnnotation.AnnVbar',-        --                          'ApiAnnotation.AnnComma'-        --                          'ApiAnnotation.AnnRarrow'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | XTyClDecl (XXTyClDecl pass)--type LHsFunDep pass = Located (FunDep (Located (IdP pass)))--data DataDeclRn = DataDeclRn-             { tcdDataCusk :: Bool    -- ^ does this have a CUSK?-                 -- See Note [CUSKs: complete user-supplied kind signatures]-             , tcdFVs      :: NameSet }-  deriving Data--{- Note [TyVar binders for associated decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For an /associated/ data, newtype, or type-family decl, the LHsQTyVars-/includes/ outer binders.  For example-    class T a where-       data D a c-       type F a b :: *-       type F a b = a -> a-Here the data decl for 'D', and type-family decl for 'F', both include 'a'-in their LHsQTyVars (tcdTyVars and fdTyVars resp).--Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars.--The idea is that the associated type is really a top-level decl in its-own right.  However we are careful to use the same name 'a', so that-we can match things up.--c.f. Note [Associated type tyvar names] in Class.hs-     Note [Family instance declaration binders]--}--type instance XFamDecl      (GhcPass _) = NoExtField--type instance XSynDecl      GhcPs = NoExtField-type instance XSynDecl      GhcRn = NameSet -- FVs-type instance XSynDecl      GhcTc = NameSet -- FVs--type instance XDataDecl     GhcPs = NoExtField-type instance XDataDecl     GhcRn = DataDeclRn-type instance XDataDecl     GhcTc = DataDeclRn--type instance XClassDecl    GhcPs = NoExtField-type instance XClassDecl    GhcRn = NameSet -- FVs-type instance XClassDecl    GhcTc = NameSet -- FVs--type instance XXTyClDecl    (GhcPass _) = NoExtCon---- Simple classifiers for TyClDecl--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- | @True@ <=> argument is a @data@\/@newtype@--- declaration.-isDataDecl :: TyClDecl pass -> Bool-isDataDecl (DataDecl {}) = True-isDataDecl _other        = False---- | type or type instance declaration-isSynDecl :: TyClDecl pass -> Bool-isSynDecl (SynDecl {})   = True-isSynDecl _other        = False---- | type class-isClassDecl :: TyClDecl pass -> Bool-isClassDecl (ClassDecl {}) = True-isClassDecl _              = False---- | type/data family declaration-isFamilyDecl :: TyClDecl pass -> Bool-isFamilyDecl (FamDecl {})  = True-isFamilyDecl _other        = False---- | type family declaration-isTypeFamilyDecl :: TyClDecl pass -> Bool-isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of-  OpenTypeFamily      -> True-  ClosedTypeFamily {} -> True-  _                   -> False-isTypeFamilyDecl _ = False---- | open type family info-isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool-isOpenTypeFamilyInfo OpenTypeFamily = True-isOpenTypeFamilyInfo _              = False---- | closed type family info-isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool-isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True-isClosedTypeFamilyInfo _                     = False---- | data family declaration-isDataFamilyDecl :: TyClDecl pass -> Bool-isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True-isDataFamilyDecl _other      = False---- Dealing with names--tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)-tyFamInstDeclName = unLoc . tyFamInstDeclLName--tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))-tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =-                     (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })-  = ln-tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn nec)))-  = noExtCon nec-tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs nec))-  = noExtCon nec--tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))-tyClDeclLName (FamDecl { tcdFam = fd })     = familyDeclLName fd-tyClDeclLName (SynDecl { tcdLName = ln })   = ln-tyClDeclLName (DataDecl { tcdLName = ln })  = ln-tyClDeclLName (ClassDecl { tcdLName = ln }) = ln-tyClDeclLName (XTyClDecl nec) = noExtCon nec--tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)-tcdName = unLoc . tyClDeclLName--tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass-tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs-tyClDeclTyVars d = tcdTyVars d--countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)-        -- class, synonym decls, data, newtype, family decls-countTyClDecls decls- = (count isClassDecl    decls,-    count isSynDecl      decls,  -- excluding...-    count isDataTy       decls,  -- ...family...-    count isNewTy        decls,  -- ...instances-    count isFamilyDecl   decls)- where-   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True-   isDataTy _                                                       = False--   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True-   isNewTy _                                                      = False---- | Does this declaration have a complete, user-supplied kind signature?--- See Note [CUSKs: complete user-supplied kind signatures]-hsDeclHasCusk :: TyClDecl GhcRn -> Bool-hsDeclHasCusk (FamDecl { tcdFam =-    FamilyDecl { fdInfo      = fam_info-               , fdTyVars    = tyvars-               , fdResultSig = L _ resultSig } }) =-    case fam_info of-      ClosedTypeFamily {} -> hsTvbAllKinded tyvars-                          && isJust (famResultKindSignature resultSig)-      _ -> True -- Un-associated open type/data families have CUSKs-hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })-  = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)-hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk-hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars-hsDeclHasCusk (FamDecl { tcdFam = XFamilyDecl nec }) = noExtCon nec-hsDeclHasCusk (XTyClDecl nec) = noExtCon nec---- Pretty-printing TyClDecl--- ~~~~~~~~~~~~~~~~~~~~~~~~--instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where--    ppr (FamDecl { tcdFam = decl }) = ppr decl-    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity-                 , tcdRhs = rhs })-      = hang (text "type" <+>-              pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals)-          4 (ppr rhs)--    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity-                  , tcdDataDefn = defn })-      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn--    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,-                    tcdFixity = fixity,-                    tcdFDs  = fds,-                    tcdSigs = sigs, tcdMeths = methods,-                    tcdATs = ats, tcdATDefs = at_defs})-      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part-      = top_matter--      | otherwise       -- Laid out-      = vcat [ top_matter <+> text "where"-             , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++-                                     map (pprTyFamDefltDecl . unLoc) at_defs ++-                                     pprLHsBindsForUser methods sigs) ]-      where-        top_matter = text "class"-                    <+> pp_vanilla_decl_head lclas tyvars fixity context-                    <+> pprFundeps (map unLoc fds)--    ppr (XTyClDecl x) = ppr x--instance OutputableBndrId p-       => Outputable (TyClGroup (GhcPass p)) where-  ppr (TyClGroup { group_tyclds = tyclds-                 , group_roles = roles-                 , group_kisigs = kisigs-                 , group_instds = instds-                 }-      )-    = hang (text "TyClGroup") 2 $-      ppr kisigs $$-      ppr tyclds $$-      ppr roles $$-      ppr instds-  ppr (XTyClGroup x) = ppr x--pp_vanilla_decl_head :: (OutputableBndrId p)-   => Located (IdP (GhcPass p))-   -> LHsQTyVars (GhcPass p)-   -> LexicalFixity-   -> LHsContext (GhcPass p)-   -> SDoc-pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context- = hsep [pprLHsContext context, pp_tyvars tyvars]-  where-    pp_tyvars (varl:varsr)-      | fixity == Infix && length varsr > 1-         = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)-                , (ppr.unLoc) (head varsr), char ')'-                , hsep (map (ppr.unLoc) (tail varsr))]-      | fixity == Infix-         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)-         , hsep (map (ppr.unLoc) varsr)]-      | otherwise = hsep [ pprPrefixOcc (unLoc thing)-                  , hsep (map (ppr.unLoc) (varl:varsr))]-    pp_tyvars [] = pprPrefixOcc (unLoc thing)-pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x--pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc-pprTyClDeclFlavour (ClassDecl {})   = text "class"-pprTyClDeclFlavour (SynDecl {})     = text "type"-pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})-  = pprFlavour info <+> text "family"-pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl nec })-  = noExtCon nec-pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })-  = ppr nd-pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x })-  = ppr x-pprTyClDeclFlavour (XTyClDecl x) = ppr x---{- Note [CUSKs: complete user-supplied kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We kind-check declarations differently if they have a complete, user-supplied-kind signature (CUSK). This is because we can safely generalise a CUSKed-declaration before checking all of the others, supporting polymorphic recursion.-See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy-and #9200 for lots of discussion of how we got here.--The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.-Under -XNoCUSKs, all declarations are treated as if they have no CUSK.-See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst--PRINCIPLE:-  a type declaration has a CUSK iff we could produce a separate kind signature-  for it, just like a type signature for a function,-  looking only at the header of the declaration.--Examples:-  * data T1 (a :: *->*) (b :: *) = ....-    -- Has CUSK; equivalant to   T1 :: (*->*) -> * -> *-- * data T2 a b = ...-   -- No CUSK; we do not want to guess T2 :: * -> * -> *-   -- because the full decl might be   data T a b = MkT (a b)--  * data T3 (a :: k -> *) (b :: *) = ...-    -- CUSK; equivalent to   T3 :: (k -> *) -> * -> *-    -- We lexically generalise over k to get-    --    T3 :: forall k. (k -> *) -> * -> *-    -- The generalisation is here is purely lexical, just like-    --    f3 :: a -> a-    -- means-    --    f3 :: forall a. a -> a--  * data T4 (a :: j k) = ...-     -- CUSK; equivalent to   T4 :: j k -> *-     -- which we lexically generalise to  T4 :: forall j k. j k -> *-     -- and then, if PolyKinds is on, we further generalise to-     --   T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> *-     -- Again this is exactly like what happens as the term level-     -- when you write-     --    f4 :: forall a b. a b -> Int--NOTE THAT-  * A CUSK does /not/ mean that everything about the kind signature is-    fully specified by the user.  Look at T4 and f4: we had do do kind-    inference to figure out the kind-quantification.  But in both cases-    (T4 and f4) that inference is done looking /only/ at the header of T4-    (or signature for f4), not at the definition thereof.--  * The CUSK completely fixes the kind of the type constructor, forever.--  * The precise rules, for each declaration form, for whethher a declaration-    has a CUSK are given in the user manual section "Complete user-supplied-    kind signatures and polymorphic recursion".  BUt they simply implement-    PRINCIPLE above.--  * Open type families are interesting:-      type family T5 a b :: *-    There simply /is/ no accompanying declaration, so that info is all-    we'll ever get.  So we it has a CUSK by definition, and we default-    any un-fixed kind variables to *.--  * Associated types are a bit tricker:-      class C6 a where-         type family T6 a b :: *-         op :: a Int -> Int-    Here C6 does not have a CUSK (in fact we ultimately discover that-    a :: * -> *).  And hence neither does T6, the associated family,-    because we can't fix its kind until we have settled C6.  Another-    way to say it: unlike a top-level, we /may/ discover more about-    a's kind from C6's definition.--  * A data definition with a top-level :: must explicitly bind all-    kind variables to the right of the ::. See test-    dependent/should_compile/KindLevels, which requires this-    case. (Naturally, any kind variable mentioned before the :: should-    not be bound after it.)--    This last point is much more debatable than the others; see-    #15142 comment:22--    Because this is fiddly to check, there is a field in the DataDeclRn-    structure (included in a DataDecl after the renamer) that stores whether-    or not the declaration has a CUSK.--}---{- *********************************************************************-*                                                                      *-                         TyClGroup-        Strongly connected components of-      type, class, instance, and role declarations-*                                                                      *-********************************************************************* -}--{- Note [TyClGroups and dependency analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A TyClGroup represents a strongly connected components of type/class/instance-decls, together with the role annotations for the type/class declarations.--The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order-sequence of strongly-connected components.--Invariants- * The type and class declarations, group_tyclds, may depend on each-   other, or earlier TyClGroups, but not on later ones-- * The role annotations, group_roles, are role-annotations for some or-   all of the types and classes in group_tyclds (only).-- * The instance declarations, group_instds, may (and usually will)-   depend on group_tyclds, or on earlier TyClGroups, but not on later-   ones.--See Note [Dependency analsis of type, class, and instance decls]-in RnSource for more info.--}---- | Type or Class Group-data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]-  = TyClGroup { group_ext    :: XCTyClGroup pass-              , group_tyclds :: [LTyClDecl pass]-              , group_roles  :: [LRoleAnnotDecl pass]-              , group_kisigs :: [LStandaloneKindSig pass]-              , group_instds :: [LInstDecl pass] }-  | XTyClGroup (XXTyClGroup pass)--type instance XCTyClGroup (GhcPass _) = NoExtField-type instance XXTyClGroup (GhcPass _) = NoExtCon---tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]-tyClGroupTyClDecls = concatMap group_tyclds--tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]-tyClGroupInstDecls = concatMap group_instds--tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]-tyClGroupRoleDecls = concatMap group_roles--tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]-tyClGroupKindSigs = concatMap group_kisigs---{- *********************************************************************-*                                                                      *-               Data and type family declarations-*                                                                      *-********************************************************************* -}--{- Note [FamilyResultSig]-~~~~~~~~~~~~~~~~~~~~~~~~~--This data type represents the return signature of a type family.  Possible-values are:-- * NoSig - the user supplied no return signature:-      type family Id a where ...-- * KindSig - the user supplied the return kind:-      type family Id a :: * where ...-- * TyVarSig - user named the result with a type variable and possibly-   provided a kind signature for that variable:-      type family Id a = r where ...-      type family Id a = (r :: *) where ...--   Naming result of a type family is required if we want to provide-   injectivity annotation for a type family:-      type family Id a = r | r -> a where ...--See also: Note [Injectivity annotation]--Note [Injectivity annotation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A user can declare a type family to be injective:--   type family Id a = r | r -> a where ...-- * The part after the "|" is called "injectivity annotation".- * "r -> a" part is called "injectivity condition"; at the moment terms-   "injectivity annotation" and "injectivity condition" are synonymous-   because we only allow a single injectivity condition.- * "r" is the "LHS of injectivity condition". LHS can only contain the-   variable naming the result of a type family.-- * "a" is the "RHS of injectivity condition". RHS contains space-separated-   type and kind variables representing the arguments of a type-   family. Variables can be omitted if a type family is not injective in-   these arguments. Example:-         type family Foo a b c = d | d -> a c where ...--Note that:- (a) naming of type family result is required to provide injectivity-     annotation- (b) for associated types if the result was named then injectivity annotation-     is mandatory. Otherwise result type variable is indistinguishable from-     associated type default.--It is possible that in the future this syntax will be extended to support-more complicated injectivity annotations. For example we could declare that-if we know the result of Plus and one of its arguments we can determine the-other argument:--   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...--Here injectivity annotation would consist of two comma-separated injectivity-conditions.--See also Note [Injective type families] in TyCon--}---- | Located type Family Result Signature-type LFamilyResultSig pass = Located (FamilyResultSig pass)---- | type Family Result Signature-data FamilyResultSig pass = -- see Note [FamilyResultSig]-    NoSig (XNoSig pass)-  -- ^ - 'ApiAnnotation.AnnKeywordId' :--  -- For details on above see note [Api annotations] in ApiAnnotation--  | KindSig  (XCKindSig pass) (LHsKind pass)-  -- ^ - 'ApiAnnotation.AnnKeywordId' :-  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',-  --             'ApiAnnotation.AnnCloseP'--  -- For details on above see note [Api annotations] in ApiAnnotation--  | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass)-  -- ^ - 'ApiAnnotation.AnnKeywordId' :-  --             'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon',-  --             'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual'-  | XFamilyResultSig (XXFamilyResultSig pass)--  -- For details on above see note [Api annotations] in ApiAnnotation--type instance XNoSig            (GhcPass _) = NoExtField-type instance XCKindSig         (GhcPass _) = NoExtField--type instance XTyVarSig         (GhcPass _) = NoExtField-type instance XXFamilyResultSig (GhcPass _) = NoExtCon----- | Located type Family Declaration-type LFamilyDecl pass = Located (FamilyDecl pass)---- | type Family Declaration-data FamilyDecl pass = FamilyDecl-  { fdExt            :: XCFamilyDecl pass-  , fdInfo           :: FamilyInfo pass              -- type/data, closed/open-  , fdLName          :: Located (IdP pass)           -- type constructor-  , fdTyVars         :: LHsQTyVars pass              -- type variables-                       -- See Note [TyVar binders for associated declarations]-  , fdFixity         :: LexicalFixity                -- Fixity used in the declaration-  , fdResultSig      :: LFamilyResultSig pass        -- result signature-  , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann-  }-  | XFamilyDecl (XXFamilyDecl pass)-  -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',-  --             'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily',-  --             'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP',-  --             'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP',-  --             'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow',-  --             'ApiAnnotation.AnnVbar'--  -- For details on above see note [Api annotations] in ApiAnnotation--type instance XCFamilyDecl    (GhcPass _) = NoExtField-type instance XXFamilyDecl    (GhcPass _) = NoExtCon----- | Located Injectivity Annotation-type LInjectivityAnn pass = Located (InjectivityAnn pass)---- | If the user supplied an injectivity annotation it is represented using--- InjectivityAnn. At the moment this is a single injectivity condition - see--- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity--- condition. `[Located name]` stores the RHS of injectivity condition. Example:------   type family Foo a b c = r | r -> a c where ...------ This will be represented as "InjectivityAnn `r` [`a`, `c`]"-data InjectivityAnn pass-  = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)]-  -- ^ - 'ApiAnnotation.AnnKeywordId' :-  --             'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar'--  -- For details on above see note [Api annotations] in ApiAnnotation--data FamilyInfo pass-  = DataFamily-  | OpenTypeFamily-     -- | 'Nothing' if we're in an hs-boot file and the user-     -- said "type family Foo x where .."-  | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])---------------- Functions over FamilyDecls -------------familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))-familyDeclLName (FamilyDecl { fdLName = n }) = n-familyDeclLName (XFamilyDecl nec) = noExtCon nec--familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)-familyDeclName = unLoc . familyDeclLName--famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))-famResultKindSignature (NoSig _) = Nothing-famResultKindSignature (KindSig _ ki) = Just ki-famResultKindSignature (TyVarSig _ bndr) =-  case unLoc bndr of-    UserTyVar _ _ -> Nothing-    KindedTyVar _ _ ki -> Just ki-    XTyVarBndr nec -> noExtCon nec-famResultKindSignature (XFamilyResultSig nec) = noExtCon nec---- | Maybe return name of the result type variable-resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))-resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig-resultVariableName _                = Nothing--------------- Pretty printing FamilyDecls -------------instance OutputableBndrId p-       => Outputable (FamilyDecl (GhcPass p)) where-  ppr = pprFamilyDecl TopLevel--pprFamilyDecl :: (OutputableBndrId p)-              => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc-pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon-                                    , fdTyVars = tyvars-                                    , fdFixity = fixity-                                    , fdResultSig = L _ result-                                    , fdInjectivityAnn = mb_inj })-  = vcat [ pprFlavour info <+> pp_top_level <+>-           pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+>-           pp_kind <+> pp_inj <+> pp_where-         , nest 2 $ pp_eqns ]-  where-    pp_top_level = case top_level of-                     TopLevel    -> text "family"-                     NotTopLevel -> empty--    pp_kind = case result of-                NoSig    _         -> empty-                KindSig  _ kind    -> dcolon <+> ppr kind-                TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr-                XFamilyResultSig nec -> noExtCon nec-    pp_inj = case mb_inj of-               Just (L _ (InjectivityAnn lhs rhs)) ->-                 hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]-               Nothing -> empty-    (pp_where, pp_eqns) = case info of-      ClosedTypeFamily mb_eqns ->-        ( text "where"-        , case mb_eqns of-            Nothing   -> text ".."-            Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )-      _ -> (empty, empty)-pprFamilyDecl _ (XFamilyDecl nec) = noExtCon nec--pprFlavour :: FamilyInfo pass -> SDoc-pprFlavour DataFamily            = text "data"-pprFlavour OpenTypeFamily        = text "type"-pprFlavour (ClosedTypeFamily {}) = text "type"--instance Outputable (FamilyInfo pass) where-  ppr info = pprFlavour info <+> text "family"----{- *********************************************************************-*                                                                      *-               Data types and data constructors-*                                                                      *-********************************************************************* -}---- | Haskell Data type Definition-data HsDataDefn pass   -- The payload of a data type defn-                       -- Used *both* for vanilla data declarations,-                       --       *and* for data family instances-  = -- | Declares a data type or newtype, giving its constructors-    -- @-    --  data/newtype T a = <constrs>-    --  data/newtype instance T [a] = <constrs>-    -- @-    HsDataDefn { dd_ext    :: XCHsDataDefn pass,-                 dd_ND     :: NewOrData,-                 dd_ctxt   :: LHsContext pass,           -- ^ Context-                 dd_cType  :: Maybe (Located CType),-                 dd_kindSig:: Maybe (LHsKind pass),-                     -- ^ Optional kind signature.-                     ---                     -- @(Just k)@ for a GADT-style @data@,-                     -- or @data instance@ decl, with explicit kind sig-                     ---                     -- Always @Nothing@ for H98-syntax decls--                 dd_cons   :: [LConDecl pass],-                     -- ^ Data constructors-                     ---                     -- For @data T a = T1 | T2 a@-                     --   the 'LConDecl's all have 'ConDeclH98'.-                     -- For @data T a where { T1 :: T a }@-                     --   the 'LConDecls' all have 'ConDeclGADT'.--                 dd_derivs :: HsDeriving pass  -- ^ Optional 'deriving' claues--             -- For details on above see note [Api annotations] in ApiAnnotation-   }-  | XHsDataDefn (XXHsDataDefn pass)--type instance XCHsDataDefn    (GhcPass _) = NoExtField--type instance XXHsDataDefn    (GhcPass _) = NoExtCon---- | Haskell Deriving clause-type HsDeriving pass = Located [LHsDerivingClause pass]-  -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is-  -- plural because one can specify multiple deriving clauses using the-  -- @-XDerivingStrategies@ language extension.-  ---  -- The list of 'LHsDerivingClause's corresponds to exactly what the user-  -- requested to derive, in order. If no deriving clauses were specified,-  -- the list is empty.--type LHsDerivingClause pass = Located (HsDerivingClause pass)---- | A single @deriving@ clause of a data declaration.------  - 'ApiAnnotation.AnnKeywordId' :---       'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock',---       'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',---       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'-data HsDerivingClause pass-  -- See Note [Deriving strategies] in TcDeriv-  = HsDerivingClause-    { deriv_clause_ext :: XCHsDerivingClause pass-    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)-      -- ^ The user-specified strategy (if any) to use when deriving-      -- 'deriv_clause_tys'.-    , deriv_clause_tys :: Located [LHsSigType pass]-      -- ^ The types to derive.-      ---      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,-      -- we can mention type variables that aren't bound by the datatype, e.g.-      ---      -- > data T b = ... deriving (C [a])-      ---      -- should produce a derived instance for @C [a] (T b)@.-    }-  | XHsDerivingClause (XXHsDerivingClause pass)--type instance XCHsDerivingClause    (GhcPass _) = NoExtField-type instance XXHsDerivingClause    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (HsDerivingClause (GhcPass p)) where-  ppr (HsDerivingClause { deriv_clause_strategy = dcs-                        , deriv_clause_tys      = L _ dct })-    = hsep [ text "deriving"-           , pp_strat_before-           , pp_dct dct-           , pp_strat_after ]-      where-        -- This complexity is to distinguish between-        --    deriving Show-        --    deriving (Show)-        pp_dct [HsIB { hsib_body = ty }]-                 = ppr (parenthesizeHsType appPrec ty)-        pp_dct _ = parens (interpp'SP dct)--        -- @via@ is unique in that in comes /after/ the class being derived,-        -- so we must special-case it.-        (pp_strat_before, pp_strat_after) =-          case dcs of-            Just (L _ via@ViaStrategy{}) -> (empty, ppr via)-            _                            -> (ppDerivStrategy dcs, empty)-  ppr (XHsDerivingClause x) = ppr x---- | Located Standalone Kind Signature-type LStandaloneKindSig pass = Located (StandaloneKindSig pass)--data StandaloneKindSig pass-  = StandaloneKindSig (XStandaloneKindSig pass)-      (Located (IdP pass))  -- Why a single binder? See #16754-      (LHsSigType pass)     -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]-  | XStandaloneKindSig (XXStandaloneKindSig pass)--type instance XStandaloneKindSig (GhcPass p) = NoExtField-type instance XXStandaloneKindSig (GhcPass p) = NoExtCon--standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)-standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname-standaloneKindSigName (XStandaloneKindSig nec) = noExtCon nec--{- Note [Wildcards in standalone kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Standalone kind signatures enable polymorphic recursion, and it is unclear how-to reconcile this with partial type signatures, so we disallow wildcards in-them.--We reject wildcards in 'rnStandaloneKindSignature' by returning False for-'StandaloneKindSigCtx' in 'wildCardsAllowed'.--The alternative design is to have special treatment for partial standalone kind-signatures, much like we have special treatment for partial type signatures in-terms. However, partial standalone kind signatures are not a proper replacement-for CUSKs, so this would be a separate feature.--}--data NewOrData-  = NewType                     -- ^ @newtype Blah ...@-  | DataType                    -- ^ @data Blah ...@-  deriving( Eq, Data )                -- Needed because Demand derives Eq---- | Convert a 'NewOrData' to a 'TyConFlavour'-newOrDataToFlavour :: NewOrData -> TyConFlavour-newOrDataToFlavour NewType  = NewtypeFlavour-newOrDataToFlavour DataType = DataTypeFlavour----- | Located data Constructor Declaration-type LConDecl pass = Located (ConDecl pass)-      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when-      --   in a GADT constructor list--  -- For details on above see note [Api annotations] in ApiAnnotation---- |------ @--- data T b = forall a. Eq a => MkT a b---   MkT :: forall b a. Eq a => MkT a b------ data T b where---      MkT1 :: Int -> T Int------ data T = Int `MkT` Int---        | MkT2------ data T a where---      Int `MkT` Int :: T Int--- @------ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',---            'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose',---            'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar',---            'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow',---            'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot'---- For details on above see note [Api annotations] in ApiAnnotation---- | data Constructor Declaration-data ConDecl pass-  = ConDeclGADT-      { con_g_ext   :: XConDeclGADT pass-      , con_names   :: [Located (IdP pass)]--      -- The next four fields describe the type after the '::'-      -- See Note [GADT abstract syntax]-      -- The following field is Located to anchor API Annotations,-      -- AnnForall and AnnDot.-      , con_forall  :: Located Bool      -- ^ True <=> explicit forall-                                         --   False => hsq_explicit is empty-      , con_qvars   :: LHsQTyVars pass-                       -- Whether or not there is an /explicit/ forall, we still-                       -- need to capture the implicitly-bound type/kind variables--      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)-      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon-      , con_res_ty  :: LHsType pass            -- ^ Result type--      , con_doc     :: Maybe LHsDocString-          -- ^ A possible Haddock comment.-      }--  | ConDeclH98-      { con_ext     :: XConDeclH98 pass-      , con_name    :: Located (IdP pass)--      , con_forall  :: Located Bool-                              -- ^ True <=> explicit user-written forall-                              --     e.g. data T a = forall b. MkT b (b->a)-                              --     con_ex_tvs = {b}-                              -- False => con_ex_tvs is empty-      , con_ex_tvs :: [LHsTyVarBndr pass]      -- ^ Existentials only-      , con_mb_cxt :: Maybe (LHsContext pass)  -- ^ User-written context (if any)-      , con_args   :: HsConDeclDetails pass    -- ^ Arguments; can be InfixCon--      , con_doc       :: Maybe LHsDocString-          -- ^ A possible Haddock comment.-      }-  | XConDecl (XXConDecl pass)--type instance XConDeclGADT (GhcPass _) = NoExtField-type instance XConDeclH98  (GhcPass _) = NoExtField-type instance XXConDecl    (GhcPass _) = NoExtCon--{- Note [GADT abstract syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a wrinkle in ConDeclGADT--* For record syntax, it's all uniform.  Given:-      data T a where-        K :: forall a. Ord a => { x :: [a], ... } -> T a-    we make the a ConDeclGADT for K with-       con_qvars  = {a}-       con_mb_cxt = Just [Ord a]-       con_args   = RecCon <the record fields>-       con_res_ty = T a--  We need the RecCon before the reanmer, so we can find the record field-  binders in GHC.Hs.Utils.hsConDeclsBinders.--* However for a GADT constr declaration which is not a record, it can-  be hard parse until we know operator fixities. Consider for example-     C :: a :*: b -> a :*: b -> a :+: b-  Initially this type will parse as-      a :*: (b -> (a :*: (b -> (a :+: b))))-  so it's hard to split up the arguments until we've done the precedence-  resolution (in the renamer).--  So:  - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr-         type into the res_ty for a ConDeclGADT for now, and use-         PrefixCon []-            con_args   = PrefixCon []-            con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b))))--       - In the renamer (RnSource.rnConDecl), we unravel it afer-         operator fixities are sorted. So we generate. So we end-         up with-            con_args   = PrefixCon [ a :*: b, a :*: b ]-            con_res_ty = a :+: b--}---- | Haskell data Constructor Declaration Details-type HsConDeclDetails pass-   = HsConDetails (LBangType pass) (Located [LConDeclField pass])--getConNames :: ConDecl (GhcPass p) -> [Located (IdP (GhcPass p))]-getConNames ConDeclH98  {con_name  = name}  = [name]-getConNames ConDeclGADT {con_names = names} = names-getConNames (XConDecl nec) = noExtCon nec--getConArgs :: ConDecl pass -> HsConDeclDetails pass-getConArgs d = con_args d--hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass]-hsConDeclArgTys (PrefixCon tys)    = tys-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]-hsConDeclArgTys (RecCon flds)      = map (cd_fld_type . unLoc) (unLoc flds)--hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]-hsConDeclTheta Nothing            = []-hsConDeclTheta (Just (L _ theta)) = theta--pp_data_defn :: (OutputableBndrId p)-                  => (LHsContext (GhcPass p) -> SDoc)   -- Printing the header-                  -> HsDataDefn (GhcPass p)-                  -> SDoc-pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context-                                , dd_cType = mb_ct-                                , dd_kindSig = mb_sig-                                , dd_cons = condecls, dd_derivs = derivings })-  | null condecls-  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig-    <+> pp_derivings derivings--  | otherwise-  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)-       2 (pp_condecls condecls $$ pp_derivings derivings)-  where-    pp_ct = case mb_ct of-               Nothing   -> empty-               Just ct -> ppr ct-    pp_sig = case mb_sig of-               Nothing   -> empty-               Just kind -> dcolon <+> ppr kind-    pp_derivings (L _ ds) = vcat (map ppr ds)-pp_data_defn _ (XHsDataDefn x) = ppr x--instance OutputableBndrId p-       => Outputable (HsDataDefn (GhcPass p)) where-   ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d--instance OutputableBndrId p-       => Outputable (StandaloneKindSig (GhcPass p)) where-  ppr (StandaloneKindSig _ v ki)-    = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki-  ppr (XStandaloneKindSig nec) = noExtCon nec--instance Outputable NewOrData where-  ppr NewType  = text "newtype"-  ppr DataType = text "data"--pp_condecls :: (OutputableBndrId p) => [LConDecl (GhcPass p)] -> SDoc-pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax-  = hang (text "where") 2 (vcat (map ppr cs))-pp_condecls cs                    -- In H98 syntax-  = equals <+> sep (punctuate (text " |") (map ppr cs))--instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where-    ppr = pprConDecl--pprConDecl :: (OutputableBndrId p) => ConDecl (GhcPass p) -> SDoc-pprConDecl (ConDeclH98 { con_name = L _ con-                       , con_ex_tvs = ex_tvs-                       , con_mb_cxt = mcxt-                       , con_args = args-                       , con_doc = doc })-  = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args]-  where-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con-                                   : map (pprHsType . unLoc) tys)-    ppr_details (RecCon fields)  = pprPrefixOcc con-                                 <+> pprConDeclFields (unLoc fields)-    cxt = fromMaybe noLHsContext mcxt--pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars-                        , con_mb_cxt = mcxt, con_args = args-                        , con_res_ty = res_ty, con_doc = doc })-  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon-    <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt,-              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])-  where-    get_args (PrefixCon args) = map ppr args-    get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]-    get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)--    cxt = fromMaybe noLHsContext mcxt--    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)-    ppr_arrow_chain []     = empty--pprConDecl (XConDecl x) = ppr x--ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc-ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)--{--************************************************************************-*                                                                      *-                Instance declarations-*                                                                      *-************************************************************************--Note [Type family instance declarations in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The data type FamEqn represents one equation of a type family instance.-Aside from the pass, it is also parameterised over another field, feqn_rhs.-feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType-(for type family instances).--Type family instances also include associated type family default equations.-That is because a default for a type family looks like this:--  class C a where-    type family F a b :: Type-    type F c d = (c,d)   -- Default instance--The default declaration is really just a `type instance` declaration, but one-with particularly simple patterns: they must all be distinct type variables.-That's because we will instantiate it (in an instance declaration for `C`) if-we don't give an explicit instance for `F`. Note that the names of the-variables don't need to match those of the class: it really is like a-free-standing `type instance` declaration.--}------------------- Type synonym family instances ----------------- | Located Type Family Instance Equation-type LTyFamInstEqn pass = Located (TyFamInstEqn pass)-  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'-  --   when in a list---- For details on above see note [Api annotations] in ApiAnnotation---- | Haskell Type Patterns-type HsTyPats pass = [LHsTypeArg pass]--{- Note [Family instance declaration binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The feqn_pats field of FamEqn (family instance equation) stores the LHS type-(and kind) patterns. Any type (and kind) variables contained-in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs-in FamInstEqn depending on whether or not an explicit forall is present. In-the case of an explicit forall, the hsib_vars only includes kind variables not-bound in the forall. Otherwise, all type (and kind) variables are bound in-the hsib_vars. In the latter case, note that in particular--* The hsib_vars *includes* any anonymous wildcards.  For example-     type instance F a _ = a-  The hsib_vars will be {a, _}.  Remember that each separate wildcard-  '_' gets its own unique.  In this context wildcards behave just like-  an ordinary type variable, only anonymous.--* The hsib_vars *includes* type variables that are already in scope--   Eg   class C s t where-          type F t p :: *-        instance C w (a,b) where-          type F (a,b) x = x->a-   The hsib_vars of the F decl are {a,b,x}, even though the F decl-   is nested inside the 'instance' decl.--   However after the renamer, the uniques will match up:-        instance C w7 (a8,b9) where-          type F (a8,b9) x10 = x10->a8-   so that we can compare the type pattern in the 'instance' decl and-   in the associated 'type' decl--c.f. Note [TyVar binders for associated decls]--}---- | Type Family Instance Equation-type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)---- | Type family default declarations.--- A convenient synonym for 'TyFamInstDecl'.--- See @Note [Type family instance declarations in HsSyn]@.-type TyFamDefltDecl = TyFamInstDecl---- | Located type family default declarations.-type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass)---- | Located Type Family Instance Declaration-type LTyFamInstDecl pass = Located (TyFamInstDecl pass)---- | Type Family Instance Declaration-newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }-    -- ^-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',-    --           'ApiAnnotation.AnnInstance',--    -- For details on above see note [Api annotations] in ApiAnnotation------------------- Data family instances ----------------- | Located Data Family Instance Declaration-type LDataFamInstDecl pass = Located (DataFamInstDecl pass)---- | Data Family Instance Declaration-newtype DataFamInstDecl pass-  = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }-    -- ^-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData',-    --           'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance',-    --           'ApiAnnotation.AnnDcolon'-    --           'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen',-    --           'ApiAnnotation.AnnClose'--    -- For details on above see note [Api annotations] in ApiAnnotation------------------- Family instances (common types) ----------------- | Located Family Instance Equation-type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)---- | Family Instance Equation-type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)-            -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).-            -- See Note [Family instance declaration binders]---- | Family Equation------ One equation in a type family instance declaration, data family instance--- declaration, or type family default.--- See Note [Type family instance declarations in HsSyn]--- See Note [Family instance declaration binders]-data FamEqn pass rhs-  = FamEqn-       { feqn_ext    :: XCFamEqn pass rhs-       , feqn_tycon  :: Located (IdP pass)-       , feqn_bndrs  :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars-       , feqn_pats   :: HsTyPats pass-       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration-       , feqn_rhs    :: rhs-       }-    -- ^-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'-  | XFamEqn (XXFamEqn pass rhs)--    -- For details on above see note [Api annotations] in ApiAnnotation--type instance XCFamEqn    (GhcPass _) r = NoExtField-type instance XXFamEqn    (GhcPass _) r = NoExtCon------------------- Class instances ----------------- | Located Class Instance Declaration-type LClsInstDecl pass = Located (ClsInstDecl pass)---- | Class Instance Declaration-data ClsInstDecl pass-  = ClsInstDecl-      { cid_ext     :: XCClsInstDecl pass-      , cid_poly_ty :: LHsSigType pass    -- Context => Class Instance-type-                                          -- Using a polytype means that the renamer conveniently-                                          -- figures out the quantified type variables for us.-      , cid_binds         :: LHsBinds pass       -- Class methods-      , cid_sigs          :: [LSig pass]         -- User-supplied pragmatic info-      , cid_tyfam_insts   :: [LTyFamInstDecl pass]   -- Type family instances-      , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances-      , cid_overlap_mode  :: Maybe (Located OverlapMode)-         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-         --                                    'ApiAnnotation.AnnClose',--        -- For details on above see note [Api annotations] in ApiAnnotation-      }-    -- ^-    --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance',-    --           'ApiAnnotation.AnnWhere',-    --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',--    -- For details on above see note [Api annotations] in ApiAnnotation-  | XClsInstDecl (XXClsInstDecl pass)--type instance XCClsInstDecl    (GhcPass _) = NoExtField-type instance XXClsInstDecl    (GhcPass _) = NoExtCon------------------- Instances of all kinds ----------------- | Located Instance Declaration-type LInstDecl pass = Located (InstDecl pass)---- | Instance Declaration-data InstDecl pass  -- Both class and family instances-  = ClsInstD-      { cid_d_ext :: XClsInstD pass-      , cid_inst  :: ClsInstDecl pass }-  | DataFamInstD              -- data family instance-      { dfid_ext  :: XDataFamInstD pass-      , dfid_inst :: DataFamInstDecl pass }-  | TyFamInstD              -- type family instance-      { tfid_ext  :: XTyFamInstD pass-      , tfid_inst :: TyFamInstDecl pass }-  | XInstDecl (XXInstDecl pass)--type instance XClsInstD     (GhcPass _) = NoExtField-type instance XDataFamInstD (GhcPass _) = NoExtField-type instance XTyFamInstD   (GhcPass _) = NoExtField-type instance XXInstDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (TyFamInstDecl (GhcPass p)) where-  ppr = pprTyFamInstDecl TopLevel--pprTyFamInstDecl :: (OutputableBndrId p)-                 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })-   = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn--ppr_instance_keyword :: TopLevelFlag -> SDoc-ppr_instance_keyword TopLevel    = text "instance"-ppr_instance_keyword NotTopLevel = empty--pprTyFamDefltDecl :: (OutputableBndrId p)-                  => TyFamDefltDecl (GhcPass p) -> SDoc-pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel--ppr_fam_inst_eqn :: (OutputableBndrId p)-                 => TyFamInstEqn (GhcPass p) -> SDoc-ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = L _ tycon-                                            , feqn_bndrs  = bndrs-                                            , feqn_pats   = pats-                                            , feqn_fixity = fixity-                                            , feqn_rhs    = rhs }})-    = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs-ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x-ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x--instance OutputableBndrId p-       => Outputable (DataFamInstDecl (GhcPass p)) where-  ppr = pprDataFamInstDecl TopLevel--pprDataFamInstDecl :: (OutputableBndrId p)-                   => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                             FamEqn { feqn_tycon  = L _ tycon-                                    , feqn_bndrs  = bndrs-                                    , feqn_pats   = pats-                                    , feqn_fixity = fixity-                                    , feqn_rhs    = defn }}})-  = pp_data_defn pp_hdr defn-  where-    pp_hdr ctxt = ppr_instance_keyword top_lvl-              <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt-                  -- pp_data_defn pretty-prints the kind sig. See #14817.--pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x)))-  = ppr x-pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x))-  = ppr x--pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                        FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})-  = ppr nd-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                        FamEqn { feqn_rhs = XHsDataDefn x}}})-  = ppr x-pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x)))-  = ppr x-pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x))-  = ppr x--pprHsFamInstLHS :: (OutputableBndrId p)-   => IdP (GhcPass p)-   -> Maybe [LHsTyVarBndr (GhcPass p)]-   -> HsTyPats (GhcPass p)-   -> LexicalFixity-   -> LHsContext (GhcPass p)-   -> SDoc-pprHsFamInstLHS thing bndrs typats fixity mb_ctxt-   = hsep [ pprHsExplicitForAll ForallInvis bndrs-          , pprLHsContext mb_ctxt-          , pp_pats typats ]-   where-     pp_pats (patl:patr:pats)-       | Infix <- fixity-       = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in-         case pats of-           [] -> pp_op_app-           _  -> hsep (parens pp_op_app : map ppr pats)--     pp_pats pats = hsep [ pprPrefixOcc thing-                         , hsep (map ppr pats)]--instance OutputableBndrId p-       => Outputable (ClsInstDecl (GhcPass p)) where-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds-                     , cid_sigs = sigs, cid_tyfam_insts = ats-                     , cid_overlap_mode = mbOverlap-                     , cid_datafam_insts = adts })-      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part-      = top_matter--      | otherwise       -- Laid out-      = vcat [ top_matter <+> text "where"-             , nest 2 $ pprDeclList $-               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats ++-               map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++-               pprLHsBindsForUser binds sigs ]-      where-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap-                                             <+> ppr inst_ty-    ppr (XClsInstDecl x) = ppr x--ppDerivStrategy :: OutputableBndrId p-                => Maybe (LDerivStrategy (GhcPass p)) -> SDoc-ppDerivStrategy mb =-  case mb of-    Nothing       -> empty-    Just (L _ ds) -> ppr ds--ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc-ppOverlapPragma mb =-  case mb of-    Nothing           -> empty-    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"-    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"-    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"-    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"-    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"-  where-    maybe_stext NoSourceText     alt = text alt-    maybe_stext (SourceText src) _   = text src <+> text "#-}"---instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where-    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl-    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl-    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl-    ppr (XInstDecl x) = ppr x---- Extract the declarations of associated data types from an instance--instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]-instDeclDataFamInsts inst_decls-  = concatMap do_one inst_decls-  where-    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))-      = map unLoc fam_insts-    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]-    do_one (L _ (TyFamInstD {}))                              = []-    do_one (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec-    do_one (L _ (XInstDecl nec))                 = noExtCon nec--{--************************************************************************-*                                                                      *-\subsection[DerivDecl]{A stand-alone instance deriving declaration}-*                                                                      *-************************************************************************--}---- | Located stand-alone 'deriving instance' declaration-type LDerivDecl pass = Located (DerivDecl pass)---- | Stand-alone 'deriving instance' declaration-data DerivDecl pass = DerivDecl-        { deriv_ext          :: XCDerivDecl pass-        , deriv_type         :: LHsSigWcType pass-          -- ^ The instance type to derive.-          ---          -- It uses an 'LHsSigWcType' because the context is allowed to be a-          -- single wildcard:-          ---          -- > deriving instance _ => Eq (Foo a)-          ---          -- Which signifies that the context should be inferred.--          -- See Note [Inferring the instance context] in TcDerivInfer.--        , deriv_strategy     :: Maybe (LDerivStrategy pass)-        , deriv_overlap_mode :: Maybe (Located OverlapMode)-         -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',-         --        'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock',-         --        'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype',-         --        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'--  -- For details on above see note [Api annotations] in ApiAnnotation-        }-  | XDerivDecl (XXDerivDecl pass)--type instance XCDerivDecl    (GhcPass _) = NoExtField-type instance XXDerivDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (DerivDecl (GhcPass p)) where-    ppr (DerivDecl { deriv_type = ty-                   , deriv_strategy = ds-                   , deriv_overlap_mode = o })-        = hsep [ text "deriving"-               , ppDerivStrategy ds-               , text "instance"-               , ppOverlapPragma o-               , ppr ty ]-    ppr (XDerivDecl x) = ppr x--{--************************************************************************-*                                                                      *-                Deriving strategies-*                                                                      *-************************************************************************--}---- | A 'Located' 'DerivStrategy'.-type LDerivStrategy pass = Located (DerivStrategy pass)---- | Which technique the user explicitly requested when deriving an instance.-data DerivStrategy pass-  -- See Note [Deriving strategies] in TcDeriv-  = StockStrategy    -- ^ GHC's \"standard\" strategy, which is to implement a-                     --   custom instance for the data type. This only works-                     --   for certain types that GHC knows about (e.g., 'Eq',-                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,-                     --   etc.)-  | AnyclassStrategy -- ^ @-XDeriveAnyClass@-  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@-  | ViaStrategy (XViaStrategy pass)-                     -- ^ @-XDerivingVia@--type instance XViaStrategy GhcPs = LHsSigType GhcPs-type instance XViaStrategy GhcRn = LHsSigType GhcRn-type instance XViaStrategy GhcTc = Type--instance OutputableBndrId p-        => Outputable (DerivStrategy (GhcPass p)) where-    ppr StockStrategy    = text "stock"-    ppr AnyclassStrategy = text "anyclass"-    ppr NewtypeStrategy  = text "newtype"-    ppr (ViaStrategy ty) = text "via" <+> ppr ty---- | A short description of a @DerivStrategy'@.-derivStrategyName :: DerivStrategy a -> SDoc-derivStrategyName = text . go-  where-    go StockStrategy    = "stock"-    go AnyclassStrategy = "anyclass"-    go NewtypeStrategy  = "newtype"-    go (ViaStrategy {}) = "via"---- | Eliminate a 'DerivStrategy'.-foldDerivStrategy :: (p ~ GhcPass pass)-                  => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r-foldDerivStrategy other _   StockStrategy    = other-foldDerivStrategy other _   AnyclassStrategy = other-foldDerivStrategy other _   NewtypeStrategy  = other-foldDerivStrategy _     via (ViaStrategy t)  = via t---- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,--- return the 'DerivStrategy' unchanged.-mapDerivStrategy :: (p ~ GhcPass pass)-                 => (XViaStrategy p -> XViaStrategy p)-                 -> DerivStrategy p -> DerivStrategy p-mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds--{--************************************************************************-*                                                                      *-\subsection[DefaultDecl]{A @default@ declaration}-*                                                                      *-************************************************************************--There can only be one default declaration per module, but it is hard-for the parser to check that; we pass them all through in the abstract-syntax, and that restriction must be checked in the front end.--}---- | Located Default Declaration-type LDefaultDecl pass = Located (DefaultDecl pass)---- | Default Declaration-data DefaultDecl pass-  = DefaultDecl (XCDefaultDecl pass) [LHsType pass]-        -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault',-        --          'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | XDefaultDecl (XXDefaultDecl pass)--type instance XCDefaultDecl    (GhcPass _) = NoExtField-type instance XXDefaultDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (DefaultDecl (GhcPass p)) where-    ppr (DefaultDecl _ tys)-      = text "default" <+> parens (interpp'SP tys)-    ppr (XDefaultDecl x) = ppr x--{--************************************************************************-*                                                                      *-\subsection{Foreign function interface declaration}-*                                                                      *-************************************************************************--}---- foreign declarations are distinguished as to whether they define or use a--- Haskell name------  * the Boolean value indicates whether the pre-standard deprecated syntax---   has been used---- | Located Foreign Declaration-type LForeignDecl pass = Located (ForeignDecl pass)---- | Foreign Declaration-data ForeignDecl pass-  = ForeignImport-      { fd_i_ext  :: XForeignImport pass   -- Post typechecker, rep_ty ~ sig_ty-      , fd_name   :: Located (IdP pass)    -- defines this name-      , fd_sig_ty :: LHsSigType pass       -- sig_ty-      , fd_fi     :: ForeignImport }--  | ForeignExport-      { fd_e_ext  :: XForeignExport pass   -- Post typechecker, rep_ty ~ sig_ty-      , fd_name   :: Located (IdP pass)    -- uses this name-      , fd_sig_ty :: LHsSigType pass       -- sig_ty-      , fd_fe     :: ForeignExport }-        -- ^-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign',-        --           'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport',-        --           'ApiAnnotation.AnnDcolon'--        -- For details on above see note [Api annotations] in ApiAnnotation-  | XForeignDecl (XXForeignDecl pass)--{--    In both ForeignImport and ForeignExport:-        sig_ty is the type given in the Haskell code-        rep_ty is the representation for this type, i.e. with newtypes-               coerced away and type functions evaluated.-    Thus if the declaration is valid, then rep_ty will only use types-    such as Int and IO that we know how to make foreign calls with.--}--type instance XForeignImport   GhcPs = NoExtField-type instance XForeignImport   GhcRn = NoExtField-type instance XForeignImport   GhcTc = Coercion--type instance XForeignExport   GhcPs = NoExtField-type instance XForeignExport   GhcRn = NoExtField-type instance XForeignExport   GhcTc = Coercion--type instance XXForeignDecl    (GhcPass _) = NoExtCon---- Specification Of an imported external entity in dependence on the calling--- convention----data ForeignImport = -- import of a C entity-                     ---                     --  * the two strings specifying a header file or library-                     --   may be empty, which indicates the absence of a-                     --   header or object specification (both are not used-                     --   in the case of `CWrapper' and when `CFunction'-                     --   has a dynamic target)-                     ---                     --  * the calling convention is irrelevant for code-                     --   generation in the case of `CLabel', but is needed-                     --   for pretty printing-                     ---                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'-                     ---                     CImport  (Located CCallConv) -- ccall or stdcall-                              (Located Safety)  -- interruptible, safe or unsafe-                              (Maybe Header)       -- name of C header-                              CImportSpec          -- details of the C entity-                              (Located SourceText) -- original source text for-                                                   -- the C entity-  deriving Data---- details of an external C entity----data CImportSpec = CLabel    CLabelString     -- import address of a C label-                 | CFunction CCallTarget      -- static or dynamic function-                 | CWrapper                   -- wrapper to expose closures-                                              -- (former f.e.d.)-  deriving Data---- specification of an externally exported entity in dependence on the calling--- convention----data ForeignExport = CExport  (Located CExportSpec) -- contains the calling-                                                    -- convention-                              (Located SourceText)  -- original source text for-                                                    -- the C entity-  deriving Data---- pretty printing of foreign declarations-----instance OutputableBndrId p-       => Outputable (ForeignDecl (GhcPass p)) where-  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })-    = hang (text "foreign import" <+> ppr fimport <+> ppr n)-         2 (dcolon <+> ppr ty)-  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =-    hang (text "foreign export" <+> ppr fexport <+> ppr n)-       2 (dcolon <+> ppr ty)-  ppr (XForeignDecl x) = ppr x--instance Outputable ForeignImport where-  ppr (CImport  cconv safety mHeader spec (L _ srcText)) =-    ppr cconv <+> ppr safety-      <+> pprWithSourceText srcText (pprCEntity spec "")-    where-      pp_hdr = case mHeader of-               Nothing -> empty-               Just (Header _ header) -> ftext header--      pprCEntity (CLabel lbl) _ =-        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl-      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =-        if dqNeeded then doubleQuotes ce else empty-          where-            dqNeeded = (take 6 src == "static")-                    || isJust mHeader-                    || not isFun-                    || st /= NoSourceText-            ce =-                  -- We may need to drop leading spaces first-                  (if take 6 src == "static" then text "static" else empty)-              <+> pp_hdr-              <+> (if isFun then empty else text "value")-              <+> (pprWithSourceText st empty)-      pprCEntity (CFunction DynamicTarget) _ =-        doubleQuotes $ text "dynamic"-      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"--instance Outputable ForeignExport where-  ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =-    ppr cconv <+> char '"' <> ppr lbl <> char '"'--{--************************************************************************-*                                                                      *-\subsection{Transformation rules}-*                                                                      *-************************************************************************--}---- | Located Rule Declarations-type LRuleDecls pass = Located (RuleDecls pass)--  -- Note [Pragma source text] in BasicTypes--- | Rule Declarations-data RuleDecls pass = HsRules { rds_ext   :: XCRuleDecls pass-                              , rds_src   :: SourceText-                              , rds_rules :: [LRuleDecl pass] }-  | XRuleDecls (XXRuleDecls pass)--type instance XCRuleDecls    (GhcPass _) = NoExtField-type instance XXRuleDecls    (GhcPass _) = NoExtCon---- | Located Rule Declaration-type LRuleDecl pass = Located (RuleDecl pass)---- | Rule Declaration-data RuleDecl pass-  = HsRule -- Source rule-       { rd_ext  :: XHsRule pass-           -- ^ After renamer, free-vars from the LHS and RHS-       , rd_name :: Located (SourceText,RuleName)-           -- ^ Note [Pragma source text] in BasicTypes-       , rd_act  :: Activation-       , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)]-           -- ^ Forall'd type vars-       , rd_tmvs :: [LRuleBndr pass]-           -- ^ Forall'd term vars, before typechecking; after typechecking-           --    this includes all forall'd vars-       , rd_lhs  :: Located (HsExpr pass)-       , rd_rhs  :: Located (HsExpr pass)-       }-    -- ^-    --  - 'ApiAnnotation.AnnKeywordId' :-    --           'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde',-    --           'ApiAnnotation.AnnVal',-    --           'ApiAnnotation.AnnClose',-    --           'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot',-    --           'ApiAnnotation.AnnEqual',-  | XRuleDecl (XXRuleDecl pass)--data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS-  deriving Data--type instance XHsRule       GhcPs = NoExtField-type instance XHsRule       GhcRn = HsRuleRn-type instance XHsRule       GhcTc = HsRuleRn--type instance XXRuleDecl    (GhcPass _) = NoExtCon--flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]-flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls---- | Located Rule Binder-type LRuleBndr pass = Located (RuleBndr pass)---- | Rule Binder-data RuleBndr pass-  = RuleBndr (XCRuleBndr pass)  (Located (IdP pass))-  | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass)-  | XRuleBndr (XXRuleBndr pass)-        -- ^-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-        --     'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation--type instance XCRuleBndr    (GhcPass _) = NoExtField-type instance XRuleBndrSig  (GhcPass _) = NoExtField-type instance XXRuleBndr    (GhcPass _) = NoExtCon--collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass]-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]--pprFullRuleName :: Located (SourceText, RuleName) -> SDoc-pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)--instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where-  ppr (HsRules { rds_src = st-               , rds_rules = rules })-    = pprWithSourceText st (text "{-# RULES")-          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"-  ppr (XRuleDecls x) = ppr x--instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where-  ppr (HsRule { rd_name = name-              , rd_act  = act-              , rd_tyvs = tys-              , rd_tmvs = tms-              , rd_lhs  = lhs-              , rd_rhs  = rhs })-        = sep [pprFullRuleName name <+> ppr act,-               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys-                                        <+> pprExpr (unLoc lhs)),-               nest 6 (equals <+> pprExpr (unLoc rhs)) ]-        where-          pp_forall_ty Nothing     = empty-          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot-          pp_forall_tm Nothing | null tms = empty-          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot-  ppr (XRuleDecl x) = ppr x--instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where-   ppr (RuleBndr _ name) = ppr name-   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)-   ppr (XRuleBndr x) = ppr x--{--************************************************************************-*                                                                      *-\subsection[DocDecl]{Document comments}-*                                                                      *-************************************************************************--}---- | Located Documentation comment Declaration-type LDocDecl = Located (DocDecl)---- | Documentation comment Declaration-data DocDecl-  = DocCommentNext HsDocString-  | DocCommentPrev HsDocString-  | DocCommentNamed String HsDocString-  | DocGroup Int HsDocString-  deriving Data---- Okay, I need to reconstruct the document comments, but for now:-instance Outputable DocDecl where-  ppr _ = text "<document comment>"--docDeclDoc :: DocDecl -> HsDocString-docDeclDoc (DocCommentNext d) = d-docDeclDoc (DocCommentPrev d) = d-docDeclDoc (DocCommentNamed _ d) = d-docDeclDoc (DocGroup _ d) = d--{--************************************************************************-*                                                                      *-\subsection[DeprecDecl]{Deprecations}-*                                                                      *-************************************************************************--We use exported entities for things to deprecate.--}---- | Located Warning Declarations-type LWarnDecls pass = Located (WarnDecls pass)-- -- Note [Pragma source text] in BasicTypes--- | Warning pragma Declarations-data WarnDecls pass = Warnings { wd_ext      :: XWarnings pass-                               , wd_src      :: SourceText-                               , wd_warnings :: [LWarnDecl pass]-                               }-  | XWarnDecls (XXWarnDecls pass)--type instance XWarnings      (GhcPass _) = NoExtField-type instance XXWarnDecls    (GhcPass _) = NoExtCon---- | Located Warning pragma Declaration-type LWarnDecl pass = Located (WarnDecl pass)---- | Warning pragma Declaration-data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt-                   | XWarnDecl (XXWarnDecl pass)--type instance XWarning      (GhcPass _) = NoExtField-type instance XXWarnDecl    (GhcPass _) = NoExtCon---instance OutputableBndr (IdP (GhcPass p))-        => Outputable (WarnDecls (GhcPass p)) where-    ppr (Warnings _ (SourceText src) decls)-      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"-    ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"-    ppr (XWarnDecls x) = ppr x--instance OutputableBndr (IdP (GhcPass p))-       => Outputable (WarnDecl (GhcPass p)) where-    ppr (Warning _ thing txt)-      = hsep ( punctuate comma (map ppr thing))-              <+> ppr txt-    ppr (XWarnDecl x) = ppr x--{--************************************************************************-*                                                                      *-\subsection[AnnDecl]{Annotations}-*                                                                      *-************************************************************************--}---- | Located Annotation Declaration-type LAnnDecl pass = Located (AnnDecl pass)---- | Annotation Declaration-data AnnDecl pass = HsAnnotation-                      (XHsAnnotation pass)-                      SourceText -- Note [Pragma source text] in BasicTypes-                      (AnnProvenance (IdP pass)) (Located (HsExpr pass))-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-      --           'ApiAnnotation.AnnType'-      --           'ApiAnnotation.AnnModule'-      --           'ApiAnnotation.AnnClose'--      -- For details on above see note [Api annotations] in ApiAnnotation-  | XAnnDecl (XXAnnDecl pass)--type instance XHsAnnotation (GhcPass _) = NoExtField-type instance XXAnnDecl     (GhcPass _) = NoExtCon--instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where-    ppr (HsAnnotation _ _ provenance expr)-      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]-    ppr (XAnnDecl x) = ppr x---- | Annotation Provenance-data AnnProvenance name = ValueAnnProvenance (Located name)-                        | TypeAnnProvenance (Located name)-                        | ModuleAnnProvenance-deriving instance Functor     AnnProvenance-deriving instance Foldable    AnnProvenance-deriving instance Traversable AnnProvenance-deriving instance (Data pass) => Data (AnnProvenance pass)--annProvenanceName_maybe :: AnnProvenance name -> Maybe name-annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name-annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name-annProvenanceName_maybe ModuleAnnProvenance       = Nothing--pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc-pprAnnProvenance ModuleAnnProvenance       = text "ANN module"-pprAnnProvenance (ValueAnnProvenance (L _ name))-  = text "ANN" <+> ppr name-pprAnnProvenance (TypeAnnProvenance (L _ name))-  = text "ANN type" <+> ppr name--{--************************************************************************-*                                                                      *-\subsection[RoleAnnot]{Role annotations}-*                                                                      *-************************************************************************--}---- | Located Role Annotation Declaration-type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)---- See #8185 for more info about why role annotations are--- top-level declarations--- | Role Annotation Declaration-data RoleAnnotDecl pass-  = RoleAnnotDecl (XCRoleAnnotDecl pass)-                  (Located (IdP pass))   -- type constructor-                  [Located (Maybe Role)] -- optional annotations-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType',-      --           'ApiAnnotation.AnnRole'--      -- For details on above see note [Api annotations] in ApiAnnotation-  | XRoleAnnotDecl (XXRoleAnnotDecl pass)--type instance XCRoleAnnotDecl (GhcPass _) = NoExtField-type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon--instance OutputableBndr (IdP (GhcPass p))-       => Outputable (RoleAnnotDecl (GhcPass p)) where-  ppr (RoleAnnotDecl _ ltycon roles)-    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>-      hsep (map (pp_role . unLoc) roles)-    where-      pp_role Nothing  = underscore-      pp_role (Just r) = ppr r-  ppr (XRoleAnnotDecl x) = ppr x--roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)-roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name-roleAnnotDeclName (XRoleAnnotDecl nec) = noExtCon nec++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+{-# LANGUAGE InstanceSigs #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Abstract syntax of global declarations.+--+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,+-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.+module GHC.Hs.Decls (+  -- * Toplevel declarations+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,+  HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,+  NewOrData, newOrDataToFlavour, anyLConIsGadt,+  StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,++  -- ** Class or type declarations+  TyClDecl(..), LTyClDecl, DataDeclRn(..),+  AnnDataDefn(..),+  AnnClassDecl(..),+  AnnSynDecl(..),+  AnnFamilyDecl(..),+  AnnClsInstDecl(..),+  TyClGroup(..),+  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,+  tyClGroupKindSigs,+  isClassDecl, isDataDecl, isSynDecl, tcdName,+  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,+  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,+  tyFamInstDeclName, tyFamInstDeclLName,+  countTyClDecls, tyClDeclFlavour,+  tyClDeclLName, tyClDeclTyVars,+  hsDeclHasCusk, famResultKindSignature,+  FamilyDecl(..), LFamilyDecl,+  FunDep(..), ppDataDefnHeader,+  pp_vanilla_decl_head,++  -- ** Instance declarations+  InstDecl(..), LInstDecl, FamilyInfo(..),+  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,+  TyFamDefltDecl, LTyFamDefltDecl,+  DataFamInstDecl(..), LDataFamInstDecl,+  pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,+  LClsInstDecl, ClsInstDecl(..),++  -- ** Standalone deriving declarations+  DerivDecl(..), LDerivDecl, AnnDerivDecl,+  -- ** Deriving strategies+  DerivStrategy(..), LDerivStrategy,+  derivStrategyName, foldDerivStrategy, mapDerivStrategy,+  XViaStrategyPs(..),+  -- ** @RULE@ declarations+  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),+  HsRuleAnn(..),+  RuleBndr(..),LRuleBndr,+  collectRuleBndrSigTys,+  flattenRuleDecls, pprFullRuleName,+  -- ** @default@ declarations+  DefaultDecl(..), LDefaultDecl,+  -- ** Template haskell declaration splice+  SpliceDecoration(..),+  SpliceDecl(..), LSpliceDecl,+  -- ** Foreign function interface declarations+  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),+  CImportSpec(..),+  -- ** Data-constructor declarations+  ConDecl(..), LConDecl,+  HsConDeclH98Details, HsConDeclGADTDetails(..),+  AnnConDeclH98(..), AnnConDeclGADT(..),+  hsConDeclTheta,+  getConNames, getRecConArgs_maybe,+  -- ** Document comments+  DocDecl(..), LDocDecl, docDeclDoc,+  -- ** Deprecations+  WarnDecl(..), LWarnDecl,+  WarnDecls(..), LWarnDecls,+  -- ** Annotations+  AnnDecl(..), LAnnDecl,+  AnnProvenance(..), annProvenanceName_maybe,+  -- ** Role annotations+  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,+  -- ** Injective type families+  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,+  resultVariableName, familyDeclLName, familyDeclName,++  -- * Grouping+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,+  hsGroupTopLevelFixitySigs,++  partitionBindsAndSigs,+    ) where++-- friends:+import GHC.Prelude++import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Extension++import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )+        -- Because Expr imports Decls via HsBracket++import GHC.Hs.Binds+import GHC.Hs.Type+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Core.Coercion++import GHC.Hs.Extension+import GHC.Parser.Annotation+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Fixity++-- others:+import GHC.Utils.Misc (count)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Core.Type+import GHC.Types.ForeignCall+import GHC.Unit.Module.Warnings++import GHC.Data.Maybe+import Data.Data (Data)+import Data.List (concatMap)+import Data.Foldable (toList)++{-+************************************************************************+*                                                                      *+\subsection[HsDecl]{Declarations}+*                                                                      *+************************************************************************+-}++type instance XTyClD      (GhcPass _) = NoExtField+type instance XInstD      (GhcPass _) = NoExtField+type instance XDerivD     (GhcPass _) = NoExtField+type instance XValD       (GhcPass _) = NoExtField+type instance XSigD       (GhcPass _) = NoExtField+type instance XKindSigD   (GhcPass _) = NoExtField+type instance XDefD       (GhcPass _) = NoExtField+type instance XForD       (GhcPass _) = NoExtField+type instance XWarningD   (GhcPass _) = NoExtField+type instance XAnnD       (GhcPass _) = NoExtField+type instance XRuleD      (GhcPass _) = NoExtField+type instance XSpliceD    (GhcPass _) = NoExtField+type instance XDocD       (GhcPass _) = NoExtField+type instance XRoleAnnotD (GhcPass _) = NoExtField+type instance XXHsDecl    (GhcPass _) = DataConCantHappen++-- | Partition a list of HsDecls into function/pattern bindings, signatures,+-- type family declarations, type family instances, and documentation comments.+--+-- Panics when given a declaration that cannot be put into any of the output+-- groups.+--+-- The primary use of this function is to implement+-- 'GHC.Parser.PostProcess.cvBindsAndSigs'.+partitionBindsAndSigs+  :: [LHsDecl GhcPs]+  -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+partitionBindsAndSigs = go+  where+    go [] = ([], [], [], [], [], [])+    go ((L l decl) : ds) =+      let (bs, ss, ts, tfis, dfis, docs) = go ds in+      case decl of+        ValD _ b+          -> (L l b : bs, ss, ts, tfis, dfis, docs)+        SigD _ s+          -> (bs, L l s : ss, ts, tfis, dfis, docs)+        TyClD _ (FamDecl _ t)+          -> (bs, ss, L l t : ts, tfis, dfis, docs)+        InstD _ (TyFamInstD { tfid_inst = tfi })+          -> (bs, ss, ts, L l tfi : tfis, dfis, docs)+        InstD _ (DataFamInstD { dfid_inst = dfi })+          -> (bs, ss, ts, tfis, L l dfi : dfis, docs)+        DocD _ d+          -> (bs, ss, ts, tfis, dfis, L l d : docs)+        _ -> pprPanic "partitionBindsAndSigs" (ppr decl)++-- Okay, I need to reconstruct the document comments, but for now:+instance Outputable (DocDecl name) where+  ppr _ = text "<document comment>"++type instance XCHsGroup (GhcPass _) = NoExtField+type instance XXHsGroup (GhcPass _) = DataConCantHappen+++emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)+emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }+emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }++emptyGroup = HsGroup { hs_ext = noExtField,+                       hs_tyclds = [],+                       hs_derivds = [],+                       hs_fixds = [], hs_defds = [], hs_annds = [],+                       hs_fords = [], hs_warnds = [], hs_ruleds = [],+                       hs_valds = error "emptyGroup hs_valds: Can't happen",+                       hs_splcds = [],+                       hs_docs = [] }++-- | The fixity signatures for each top-level declaration and class method+-- in an 'HsGroup'.+-- See Note [Top-level fixity signatures in an HsGroup]+hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]+hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =+    fixds ++ cls_fixds+  where+    cls_fixds = [ L loc sig+                | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds+                , L loc (FixSig _ sig) <- sigs+                ]++hsGroupInstDecls :: HsGroup (GhcPass p) -> [LInstDecl (GhcPass p)]+hsGroupInstDecls = (=<<) group_instds . hs_tyclds++-- Helpers to flatten TyClGroups.+-- See (TCDEP1) in Note [Dependency analysis of type and class decls] in GHC.Rename.Module+tyClGroupTyClDecls :: [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)]+tyClGroupInstDecls :: [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)]+tyClGroupRoleDecls :: [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)]+tyClGroupKindSigs  :: [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)]+tyClGroupTyClDecls = Data.List.concatMap group_tyclds+tyClGroupInstDecls = Data.List.concatMap group_instds+tyClGroupRoleDecls = Data.List.concatMap group_roles+tyClGroupKindSigs  = Data.List.concatMap group_kisigs++appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)+             -> HsGroup (GhcPass p)+appendGroups+    HsGroup {+        hs_valds  = val_groups1,+        hs_splcds = spliceds1,+        hs_tyclds = tyclds1,+        hs_derivds = derivds1,+        hs_fixds  = fixds1,+        hs_defds  = defds1,+        hs_annds  = annds1,+        hs_fords  = fords1,+        hs_warnds = warnds1,+        hs_ruleds = rulds1,+        hs_docs   = docs1 }+    HsGroup {+        hs_valds  = val_groups2,+        hs_splcds = spliceds2,+        hs_tyclds = tyclds2,+        hs_derivds = derivds2,+        hs_fixds  = fixds2,+        hs_defds  = defds2,+        hs_annds  = annds2,+        hs_fords  = fords2,+        hs_warnds = warnds2,+        hs_ruleds = rulds2,+        hs_docs   = docs2 }+  =+    HsGroup {+        hs_ext    = noExtField,+        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,+        hs_splcds = spliceds1 ++ spliceds2,+        hs_tyclds = tyclds1 ++ tyclds2,+        hs_derivds = derivds1 ++ derivds2,+        hs_fixds  = fixds1 ++ fixds2,+        hs_annds  = annds1 ++ annds2,+        hs_defds  = defds1 ++ defds2,+        hs_fords  = fords1 ++ fords2,+        hs_warnds = warnds1 ++ warnds2,+        hs_ruleds = rulds1 ++ rulds2,+        hs_docs   = docs1  ++ docs2 }++instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where+    ppr (TyClD _ dcl)             = ppr dcl+    ppr (ValD _ binds)            = ppr binds+    ppr (DefD _ def)              = ppr def+    ppr (InstD _ inst)            = ppr inst+    ppr (DerivD _ deriv)          = ppr deriv+    ppr (ForD _ fd)               = ppr fd+    ppr (SigD _ sd)               = ppr sd+    ppr (KindSigD _ ksd)          = ppr ksd+    ppr (RuleD _ rd)              = ppr rd+    ppr (WarningD _ wd)           = ppr wd+    ppr (AnnD _ ad)               = ppr ad+    ppr (SpliceD _ dd)            = ppr dd+    ppr (DocD _ doc)              = ppr doc+    ppr (RoleAnnotD _ ra)         = ppr ra++instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where+    ppr (HsGroup { hs_valds  = val_decls,+                   hs_tyclds = tycl_decls,+                   hs_derivds = deriv_decls,+                   hs_fixds  = fix_decls,+                   hs_warnds = deprec_decls,+                   hs_annds  = ann_decls,+                   hs_fords  = foreign_decls,+                   hs_defds  = default_decls,+                   hs_ruleds = rule_decls })+        = vcat_mb empty+            [ppr_ds fix_decls, ppr_ds default_decls,+             ppr_ds deprec_decls, ppr_ds ann_decls,+             ppr_ds rule_decls,+             if isEmptyValBinds val_decls+                then Nothing+                else Just (ppr val_decls),+             ppr_ds (tyClGroupRoleDecls tycl_decls),+             ppr_ds (tyClGroupKindSigs  tycl_decls),+             ppr_ds (tyClGroupTyClDecls tycl_decls),+             ppr_ds (tyClGroupInstDecls tycl_decls),+             ppr_ds deriv_decls,+             ppr_ds foreign_decls]+        where+          ppr_ds :: Outputable a => [a] -> Maybe SDoc+          ppr_ds [] = Nothing+          ppr_ds ds = Just (vcat (map ppr ds))++          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc+          -- Concatenate vertically with white-space between non-blanks+          vcat_mb _    []             = empty+          vcat_mb gap (Nothing : ds) = vcat_mb gap ds+          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds++type instance XSpliceDecl      (GhcPass _) = NoExtField+type instance XXSpliceDecl     (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (SpliceDecl (GhcPass p)) where+  ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e+  ppr (SpliceDecl _ (L _ e) BareSplice)   = pprUntypedSplice False Nothing e++instance Outputable SpliceDecoration where+  ppr x = text $ show x++++{-+************************************************************************+*                                                                      *+            Type and class declarations+*                                                                      *+************************************************************************+-}++type instance XFamDecl      (GhcPass _) = NoExtField++type instance XSynDecl      GhcPs = AnnSynDecl+type instance XSynDecl      GhcRn = NameSet -- FVs+type instance XSynDecl      GhcTc = NameSet -- FVs++type instance XDataDecl     GhcPs = NoExtField+type instance XDataDecl     GhcRn = DataDeclRn+type instance XDataDecl     GhcTc = DataDeclRn++data DataDeclRn = DataDeclRn+             { tcdDataCusk :: Bool    -- ^ does this have a CUSK?+                 -- See Note [CUSKs: complete user-supplied kind signatures]+             , tcdFVs      :: NameSet }+  deriving Data++type instance XClassDecl    GhcPs =+  ( AnnClassDecl+  , EpLayout              -- See Note [Class EpLayout]+  , AnnSortKey DeclTag )  -- TODO:AZ:tidy up AnnSortKey++type instance XClassDecl    GhcRn = NameSet -- FVs+type instance XClassDecl    GhcTc = NameSet -- FVs++type instance XXTyClDecl    (GhcPass _) = DataConCantHappen++type instance XCTyFamInstDecl (GhcPass _) = (EpToken "type", EpToken "instance")+type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen++data AnnDataDefn+  = AnnDataDefn {+      andd_openp    :: [EpToken "("],+      andd_closep   :: [EpToken ")"],+      andd_type     :: EpToken "type",+      andd_newtype  :: EpToken "newtype",+      andd_data     :: EpToken "data",+      andd_instance :: EpToken "instance",+      andd_dcolon   :: TokDcolon,+      andd_where    :: EpToken "where",+      andd_openc    :: EpToken "{",+      andd_closec   :: EpToken "}",+      andd_equal    :: EpToken "="+  } deriving Data++instance NoAnn AnnDataDefn where+  noAnn = AnnDataDefn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn++data AnnClassDecl+  = AnnClassDecl {+      acd_class  :: EpToken "class",+      acd_openp  :: [EpToken "("],+      acd_closep :: [EpToken ")"],+      acd_vbar   :: EpToken "|",+      acd_where  :: EpToken "where",+      acd_openc  :: EpToken "{",+      acd_closec :: EpToken "}",+      acd_semis  :: [EpToken ";"]+  } deriving Data++instance NoAnn AnnClassDecl where+  noAnn = AnnClassDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn++data AnnSynDecl+  = AnnSynDecl {+    asd_opens  :: [EpToken "("],+    asd_closes :: [EpToken ")"],+    asd_type   :: EpToken "type",+    asd_equal  :: EpToken "="+  } deriving Data++instance NoAnn AnnSynDecl where+  noAnn = AnnSynDecl noAnn noAnn noAnn noAnn++------------- Pretty printing FamilyDecls -----------++pprFlavour :: FamilyInfo pass -> SDoc+pprFlavour DataFamily            = text "data"+pprFlavour OpenTypeFamily        = text "type"+pprFlavour (ClosedTypeFamily {}) = text "type"++instance Outputable (FamilyInfo pass) where+  ppr info = pprFlavour info <+> text "family"+++-- Dealing with names++tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                  => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)+tyFamInstDeclName = unLoc . tyFamInstDeclLName++tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                   => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }})+  = ln++tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN+              => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))+tyClDeclLName (FamDecl { tcdFam = fd })     = familyDeclLName fd+tyClDeclLName (SynDecl { tcdLName = ln })   = ln+tyClDeclLName (DataDecl { tcdLName = ln })  = ln+tyClDeclLName (ClassDecl { tcdLName = ln }) = ln++tyClDeclTyVars :: TyClDecl (GhcPass p) -> LHsQTyVars (GhcPass p)+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs+tyClDeclTyVars d = tcdTyVars d++countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)+        -- class, synonym decls, data, newtype, family decls+countTyClDecls decls+ = (count isClassDecl    decls,+    count isSynDecl      decls,  -- excluding...+    count isDataTy       decls,  -- ...family...+    count isNewTy        decls,  -- ...instances+    count isFamilyDecl   decls)+ where+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True+   isDataTy _                                                       = False++   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True+   isNewTy _                                                      = False++-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it+-- needs to be polymorphic in the pass+tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN+        => TyClDecl (GhcPass p) -> IdP (GhcPass p)+tcdName = unLoc . tyClDeclLName++-- | Does this declaration have a complete, user-supplied kind signature?+-- See Note [CUSKs: complete user-supplied kind signatures]+hsDeclHasCusk :: TyClDecl GhcRn -> Bool+hsDeclHasCusk (FamDecl { tcdFam =+    FamilyDecl { fdInfo      = fam_info+               , fdTyVars    = tyvars+               , fdResultSig = L _ resultSig } }) =+    case fam_info of+      ClosedTypeFamily {} -> hsTvbAllKinded tyvars+                          && isJust (famResultKindSignature resultSig)+      _ -> True -- Un-associated open type/data families have CUSKs+hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })+  = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)+hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk+hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars++-- Pretty-printing TyClDecl+-- ~~~~~~~~~~~~~~~~~~~~~~~~++instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where++    ppr (FamDecl { tcdFam = decl }) = ppr decl+    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                 , tcdRhs = rhs })+      = hang (text "type" <+>+              pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)+          4 (ppr rhs)++    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                  , tcdDataDefn = defn })+      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn++    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,+                    tcdFixity = fixity,+                    tcdFDs  = fds,+                    tcdSigs = sigs, tcdMeths = methods,+                    tcdATs = ats, tcdATDefs = at_defs})+      | null sigs && null methods && null ats && null at_defs -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList (map (ppr . unLoc) ats +++                                     map (pprTyFamDefltDecl . unLoc) at_defs +++                                     pprLHsBindsForUser methods sigs) ]+      where+        top_matter = text "class"+                    <+> pp_vanilla_decl_head lclas tyvars fixity context+                    <+> pprFundeps (map unLoc fds)++instance OutputableBndrId p+       => Outputable (TyClGroup (GhcPass p)) where+  ppr (TyClGroup { group_tyclds = tyclds+                 , group_roles = roles+                 , group_kisigs = kisigs+                 , group_instds = instds+                 }+      )+    = hang (text "TyClGroup") 2 $+      ppr kisigs $$+      ppr tyclds $$+      ppr roles $$+      ppr instds++pp_vanilla_decl_head :: (OutputableBndrId p)+   => XRecGhc (IdGhcP p)+   -> LHsQTyVars (GhcPass p)+   -> LexicalFixity+   -> Maybe (LHsContext (GhcPass p))+   -> SDoc+pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context+ = hsep [pprLHsContext context, pp_tyvars tyvars]+  where+    pp_tyvars (varl:varsr)+      | fixity == Infix, varr:varsr'@(_:_) <- varsr+         -- If varsr has at least 2 elements, parenthesize.+         = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)+                , (ppr.unLoc) varr, char ')'+                , hsep (map (ppr.unLoc) varsr')]+      | fixity == Infix+         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)+         , hsep (map (ppr.unLoc) varsr)]+      | otherwise = hsep [ pprPrefixOcc (unLoc thing)+                  , hsep (map (ppr.unLoc) (varl:varsr))]+    pp_tyvars [] = pprPrefixOcc (unLoc thing)++tyClDeclFlavour :: TyClDecl (GhcPass p) -> TyConFlavour tc+tyClDeclFlavour (ClassDecl {})   = ClassFlavour+tyClDeclFlavour (SynDecl {})     = TypeSynonymFlavour+tyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})+  = case info of+      DataFamily          -> OpenFamilyFlavour (IAmData DataType) Nothing+      OpenTypeFamily      -> OpenFamilyFlavour IAmType Nothing+      ClosedTypeFamily {} -> ClosedTypeFamilyFlavour+tyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } })+  = case dataDefnConsNewOrData nd of+      NewType  -> NewtypeFlavour+      DataType -> DataTypeFlavour++instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where+  ppr = pprFunDep++type instance XCFunDep    (GhcPass _) = TokRarrow+type instance XXFunDep    (GhcPass _) = DataConCantHappen++pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc+pprFundeps []  = empty+pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))++pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc+pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs]++{- *********************************************************************+*                                                                      *+                         TyClGroup+        Strongly connected components of+      type, class, instance, and role declarations+*                                                                      *+********************************************************************* -}++type instance XCTyClGroup GhcPs = NoExtField++type instance XCTyClGroup GhcRn = NameSet     -- Lexical dependencies of an SCC+  -- What names exactly are in this NameSet? See Note [Prepare TyClGroup FVs] in GHC.Rename.Module+  -- How is this NameSet used? See Note [Retrying TyClGroups] in GHC.Tc.TyCl++type instance XCTyClGroup GhcTc = DataConCantHappen++type instance XXTyClGroup (GhcPass _) = DataConCantHappen+++{- *********************************************************************+*                                                                      *+               Data and type family declarations+*                                                                      *+********************************************************************* -}++type instance XNoSig            (GhcPass _) = NoExtField+type instance XCKindSig         (GhcPass _) = NoExtField++type instance XTyVarSig         (GhcPass _) = NoExtField+type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen++type instance XCFamilyDecl    (GhcPass _) = AnnFamilyDecl+type instance XXFamilyDecl    (GhcPass _) = DataConCantHappen++data AnnFamilyDecl+  = AnnFamilyDecl {+      afd_openp  :: [EpToken "("],+      afd_closep :: [EpToken ")"],+      afd_type   :: EpToken "type",+      afd_data   :: EpToken "data",+      afd_family :: EpToken "family",+      afd_dcolon :: TokDcolon,+      afd_equal  :: EpToken "=",+      afd_vbar   :: EpToken "|",+      afd_where  :: EpToken "where",+      afd_openc  :: EpToken "{",+      afd_dotdot :: EpToken "..",+      afd_closec :: EpToken "}"+  } deriving Data++instance NoAnn AnnFamilyDecl where+  noAnn = AnnFamilyDecl noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn noAnn++------------- Functions over FamilyDecls -----------++familyDeclLName :: FamilyDecl (GhcPass p) -> XRecGhc (IdGhcP p)+familyDeclLName (FamilyDecl { fdLName = n }) = n++familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)+familyDeclName = unLoc . familyDeclLName++famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))+famResultKindSignature (NoSig _) = Nothing+famResultKindSignature (KindSig _ ki) = Just ki+famResultKindSignature (TyVarSig _ bndr) =+  case hsBndrKind (unLoc bndr) of+    HsBndrNoKind _  -> Nothing+    HsBndrKind _ ki -> Just ki++-- | Maybe return name of the result type variable+resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))+resultVariableName (TyVarSig _ sig) = hsLTyVarName sig+resultVariableName _                = Nothing++------------- Pretty printing FamilyDecls -----------++type instance XCInjectivityAnn  (GhcPass _) = TokRarrow+type instance XXInjectivityAnn  (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (FamilyDecl (GhcPass p)) where+  ppr (FamilyDecl { fdInfo = info, fdLName = ltycon+                  , fdTopLevel = top_level+                  , fdTyVars = tyvars+                  , fdFixity = fixity+                  , fdResultSig = L _ result+                  , fdInjectivityAnn = mb_inj })+    = vcat [ pprFlavour info <+> pp_top_level <+>+             pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>+             pp_kind <+> pp_inj <+> pp_where+           , nest 2 $ pp_eqns ]+    where+      pp_top_level = case top_level of+                       TopLevel    -> text "family"+                       NotTopLevel -> empty++      pp_kind = case result of+                  NoSig    _         -> empty+                  KindSig  _ kind    -> dcolon <+> ppr kind+                  TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr+      pp_inj = case mb_inj of+                 Just (L _ (InjectivityAnn _ lhs rhs)) ->+                   hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ]+                 Nothing -> empty+      (pp_where, pp_eqns) = case info of+        ClosedTypeFamily mb_eqns ->+          ( text "where"+          , case mb_eqns of+              Nothing   -> text ".."+              Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )+        _ -> (empty, empty)++++{- *********************************************************************+*                                                                      *+               Data types and data constructors+*                                                                      *+********************************************************************* -}++type instance XCHsDataDefn    (GhcPass _) = AnnDataDefn+type instance XXHsDataDefn    (GhcPass _) = DataConCantHappen++type instance XCHsDerivingClause    (GhcPass _) = EpToken "deriving"+type instance XXHsDerivingClause    (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (HsDerivingClause (GhcPass p)) where+  ppr (HsDerivingClause { deriv_clause_strategy = dcs+                        , deriv_clause_tys      = L _ dct })+    = hsep [ text "deriving"+           , pp_strat_before+           , ppr dct+           , pp_strat_after ]+      where+        -- @via@ is unique in that in comes /after/ the class being derived,+        -- so we must special-case it.+        (pp_strat_before, pp_strat_after) =+          case dcs of+            Just (L _ via@ViaStrategy{}) -> (empty, ppr via)+            _                            -> (ppDerivStrategy dcs, empty)++-- | A short description of a @DerivStrategy'@.+derivStrategyName :: DerivStrategy a -> SDoc+derivStrategyName = text . go+  where+    go StockStrategy    {} = "stock"+    go AnyclassStrategy {} = "anyclass"+    go NewtypeStrategy  {} = "newtype"+    go ViaStrategy      {} = "via"++type instance XDctSingle (GhcPass _) = NoExtField+type instance XDctMulti  (GhcPass _) = NoExtField+type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen++instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where+  ppr (DctSingle _ ty) = ppr ty+  ppr (DctMulti _ tys) = parens (interpp'SP tys)++type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon)+type instance XStandaloneKindSig GhcRn = NoExtField+type instance XStandaloneKindSig GhcTc = NoExtField++type instance XXStandaloneKindSig (GhcPass p) = DataConCantHappen++standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)+standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname++type instance XConDeclGADT GhcPs = AnnConDeclGADT+type instance XConDeclGADT GhcRn = NoExtField+type instance XConDeclGADT GhcTc = NoExtField++type instance XConDeclH98  GhcPs = AnnConDeclH98+type instance XConDeclH98  GhcRn = NoExtField+type instance XConDeclH98  GhcTc = NoExtField++type instance XXConDecl (GhcPass _) = DataConCantHappen++type instance XPrefixConGADT       (GhcPass _) = NoExtField++type instance XRecConGADT          GhcPs = TokRarrow+type instance XRecConGADT          GhcRn = NoExtField+type instance XRecConGADT          GhcTc = NoExtField++type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen++data AnnConDeclH98+  = AnnConDeclH98 {+    acdh_forall  :: TokForall,+    acdh_dot :: EpToken ".",+    acdh_darrow :: TokDarrow+  } deriving Data++instance NoAnn AnnConDeclH98 where+  noAnn = AnnConDeclH98 noAnn noAnn noAnn++data AnnConDeclGADT+  = AnnConDeclGADT {+    acdg_openp  :: [EpToken "("],+    acdg_closep :: [EpToken ")"],+    acdg_dcolon :: TokDcolon+  } deriving Data++instance NoAnn AnnConDeclGADT where+  noAnn = AnnConDeclGADT noAnn noAnn noAnn++-- Codomain could be 'NonEmpty', but at the moment all users need a list.+getConNames :: ConDecl GhcRn -> [LocatedN Name]+getConNames ConDeclH98  {con_name  = name}  = [name]+getConNames ConDeclGADT {con_names = names} = toList names++-- | Return @'Just' fields@ if a data constructor declaration uses record+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.+-- Otherwise, return 'Nothing'.+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LHsConDeclRecField GhcRn])+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of+  PrefixCon{} -> Nothing+  RecCon flds -> Just flds+  InfixCon{}  -> Nothing+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of+  PrefixConGADT{} -> Nothing+  RecConGADT _ flds -> Just flds++hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]+hsConDeclTheta Nothing            = []+hsConDeclTheta (Just (L _ theta)) = theta++ppDataDefnHeader+ :: (OutputableBndrId p)+ => (Maybe (LHsContext (GhcPass p)) -> SDoc)   -- Printing the header+ -> HsDataDefn (GhcPass p)+ -> SDoc+ppDataDefnHeader pp_hdr HsDataDefn+  { dd_ctxt = context+  , dd_cType = mb_ct+  , dd_kindSig = mb_sig+  , dd_cons = condecls }+  = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig+  where+    pp_type+      | isTypeDataDefnCons condecls = text "type"+      | otherwise = empty+    pp_ct = case mb_ct of+               Nothing -> empty+               Just ct -> ppr ct+    pp_sig = case mb_sig of+               Nothing   -> empty+               Just kind -> dcolon <+> ppr kind++pp_data_defn :: (OutputableBndrId p)+                  => (Maybe (LHsContext (GhcPass p)) -> SDoc)   -- Printing the header+                  -> HsDataDefn (GhcPass p)+                  -> SDoc+pp_data_defn pp_hdr defn@HsDataDefn+  { dd_cons = condecls+  , dd_derivs = derivings }+  | null condecls+  = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings++  | otherwise+  = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings)+  where+    pp_derivings ds = vcat (map ppr ds)++instance OutputableBndrId p+       => Outputable (HsDataDefn (GhcPass p)) where+   ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d++instance OutputableBndrId p+       => Outputable (StandaloneKindSig (GhcPass p)) where+  ppr (StandaloneKindSig _ v ki)+    = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki++pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc+pp_condecls cs+  | anyLConIsGadt cs             -- In GADT syntax+  = hang (text "where") 2 (vcat (map ppr cs))+  | otherwise                    -- In H98 syntax+  = equals <+> sep (punctuate (text " |") (map ppr cs))++instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where+    ppr = pprConDecl++pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc+pprConDecl (ConDeclH98 { con_name = L _ con+                       , con_ex_tvs = ex_tvs+                       , con_mb_cxt = mcxt+                       , con_args = args+                       , con_doc = doc })+  = pprMaybeWithDoc doc $+    sep [ pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt+        , ppr_details args ]+  where+    -- In ppr_details: let's not print the multiplicities (they are always 1, by+    -- definition) as they do not appear in an actual declaration.+    ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1,+                                         pprInfixOcc con,+                                         pprHsConDeclFieldNoMult t2]+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con+                                    : map pprHsConDeclFieldNoMult tys)+    ppr_details (RecCon fields)  = pprPrefixOcc con+                                    <+> pprHsConDeclRecFields (unLoc fields)++pprConDecl (ConDeclGADT { con_names = cons+                        , con_outer_bndrs = L _ outer_bndrs+                        , con_inner_bndrs = inner_bndrs+                        , con_mb_cxt = mcxt, con_g_args = args+                        , con_res_ty = res_ty, con_doc = doc })+  = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon+    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs+                <+> hsep (map pprHsForAllTelescope inner_bndrs)+                <+> pprLHsContext mcxt,+              sep (ppr_args args ++ [ppr res_ty]) ])+  where+    ppr_args (PrefixConGADT _ args) = map (pprHsConDeclFieldWith (\arr tyDoc -> tyDoc <+> ppr_arr arr)) args+    ppr_args (RecConGADT _ fields) = [pprHsConDeclRecFields (unLoc fields) <+> arrow]++    -- Display linear arrows as unrestricted with -XNoLinearTypes+    -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)+    ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types ->+                                  if show_linear_types then lollipop else arrow+    ppr_arr arr = pprHsArrow arr++ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)++{-+************************************************************************+*                                                                      *+                Instance declarations+*                                                                      *+************************************************************************+-}++type instance XCFamEqn    (GhcPass _) r = ([EpToken "("], [EpToken ")"], EpToken "=")+type instance XXFamEqn    (GhcPass _) r = DataConCantHappen++----------------- Class instances -------------++type instance XCClsInstDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                             -- The warning of the deprecated instance+                                             -- See Note [Implementation of deprecated instances]+                                             -- in GHC.Tc.Solver.Dict+                                       , AnnClsInstDecl+                                       , AnnSortKey DeclTag) -- For sorting the additional annotations+                                        -- TODO:AZ:tidy up+type instance XCClsInstDecl    GhcRn = Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated instance+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+type instance XCClsInstDecl    GhcTc = NoExtField++type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen++----------------- Instances of all kinds -------------++type instance XClsInstD     (GhcPass _) = NoExtField++type instance XDataFamInstD (GhcPass _) = NoExtField++type instance XTyFamInstD   GhcPs = NoExtField+type instance XTyFamInstD   GhcRn = NoExtField+type instance XTyFamInstD   GhcTc = NoExtField++type instance XXInstDecl    (GhcPass _) = DataConCantHappen++data AnnClsInstDecl+  = AnnClsInstDecl {+    acid_instance :: EpToken "instance",+    acid_where    :: EpToken "where",+    acid_openc    :: EpToken "{",+    acid_semis    :: [EpToken ";"],+    acid_closec   :: EpToken "}"+  } deriving Data++instance NoAnn AnnClsInstDecl where+  noAnn = AnnClsInstDecl noAnn noAnn noAnn noAnn noAnn++cidDeprecation :: forall p. IsPass p+               => ClsInstDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> ClsInstDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } )+      = depr+    decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })+      = depr+    decl_deprecation _ _ = Nothing++instance OutputableBndrId p+       => Outputable (TyFamInstDecl (GhcPass p)) where+  ppr = pprTyFamInstDecl TopLevel++pprTyFamInstDecl :: (OutputableBndrId p)+                 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })+   = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn++ppr_instance_keyword :: TopLevelFlag -> SDoc+ppr_instance_keyword TopLevel    = text "instance"+ppr_instance_keyword NotTopLevel = empty++pprTyFamDefltDecl :: (OutputableBndrId p)+                  => TyFamDefltDecl (GhcPass p) -> SDoc+pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel++ppr_fam_inst_eqn :: (OutputableBndrId p)+                 => TyFamInstEqn (GhcPass p) -> SDoc+ppr_fam_inst_eqn (FamEqn { feqn_tycon  = L _ tycon+                         , feqn_bndrs  = bndrs+                         , feqn_pats   = pats+                         , feqn_fixity = fixity+                         , feqn_rhs    = rhs })+    = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs++instance OutputableBndrId p+       => Outputable (DataFamInstDecl (GhcPass p)) where+  ppr = pprDataFamInstDecl TopLevel++pprDataFamInstDecl :: (OutputableBndrId p)+                   => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =+                            (FamEqn { feqn_tycon  = L _ tycon+                                    , feqn_bndrs  = bndrs+                                    , feqn_pats   = pats+                                    , feqn_fixity = fixity+                                    , feqn_rhs    = defn })})+  = pp_data_defn pp_hdr defn+  where+    pp_hdr mctxt = ppr_instance_keyword top_lvl+              <+> pprHsFamInstLHS tycon bndrs pats fixity mctxt+                  -- pp_data_defn pretty-prints the kind sig. See #14817.++pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc+pprDataFamInstFlavour DataFamInstDecl+  { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}}+  = ppr (dataDefnConsNewOrData cons)++pprHsFamInstLHS :: (OutputableBndrId p)+   => IdP (GhcPass p)+   -> HsOuterFamEqnTyVarBndrs (GhcPass p)+   -> HsFamEqnPats (GhcPass p)+   -> LexicalFixity+   -> Maybe (LHsContext (GhcPass p))+   -> SDoc+pprHsFamInstLHS thing bndrs typats fixity mb_ctxt+   = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs+          , pprLHsContext mb_ctxt+          , pprHsArgsApp thing fixity typats ]++instance OutputableBndrId p+       => Outputable (ClsInstDecl (GhcPass p)) where+    ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds+                         , cid_sigs = sigs, cid_tyfam_insts = ats+                         , cid_overlap_mode = mbOverlap+                         , cid_datafam_insts = adts })+      | null sigs, null ats, null adts, null binds  -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList $+               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats +++               map (pprDataFamInstDecl NotTopLevel . unLoc) adts +++               pprLHsBindsForUser binds sigs ]+      where+        top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)+                                     <+> ppOverlapPragma mbOverlap+                                     <+> ppr inst_ty++ppDerivStrategy :: OutputableBndrId p+                => Maybe (LDerivStrategy (GhcPass p)) -> SDoc+ppDerivStrategy mb =+  case mb of+    Nothing       -> empty+    Just (L _ ds) -> ppr ds++ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc+ppOverlapPragma mb =+  case mb of+    Nothing           -> empty+    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"+    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"+    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"+    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"+    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"+    Just (L _ (NonCanonical s)) -> maybe_stext s "{-# INCOHERENT #-}" -- No surface syntax for NONCANONICAL yet+  where+    maybe_stext NoSourceText     alt = text alt+    maybe_stext (SourceText src) _   = ftext src <+> text "#-}"+++instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where+    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl+    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl+    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl++-- Extract the declarations of associated data types from an instance++instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]+instDeclDataFamInsts inst_decls+  = concatMap do_one inst_decls+  where+    do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]+    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))+      = map unLoc fam_insts+    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]+    do_one (L _ (TyFamInstD {}))                              = []++-- | Convert a 'NewOrData' to a 'TyConFlavour'+newOrDataToFlavour :: NewOrData -> TyConFlavour tc+newOrDataToFlavour NewType  = NewtypeFlavour+newOrDataToFlavour DataType = DataTypeFlavour++-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@.+anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool+anyLConIsGadt xs = case toList xs of+    L _ ConDeclGADT {} : _ -> True+    _ -> False+{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-}+{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-}++{-+************************************************************************+*                                                                      *+\subsection[DerivDecl]{A stand-alone instance deriving declaration}+*                                                                      *+************************************************************************+-}++type instance XCDerivDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , AnnDerivDecl )+type instance XCDerivDecl    GhcRn = ( Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , AnnDerivDecl )+type instance XCDerivDecl    GhcTc = AnnDerivDecl+type instance XXDerivDecl    (GhcPass _) = DataConCantHappen++type AnnDerivDecl = (EpToken "deriving", EpToken "instance")++derivDeprecation :: forall p. IsPass p+               => DerivDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> DerivDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation _ _ = Nothing++instance OutputableBndrId p+       => Outputable (DerivDecl (GhcPass p)) where+    ppr (deriv@DerivDecl { deriv_type = ty+                   , deriv_strategy = ds+                   , deriv_overlap_mode = o })+        = hsep [ text "deriving"+               , ppDerivStrategy ds+               , text "instance"+               , maybe empty ppr (derivDeprecation deriv)+               , ppOverlapPragma o+               , ppr ty ]++{-+************************************************************************+*                                                                      *+                Deriving strategies+*                                                                      *+************************************************************************+-}++type instance XStockStrategy    GhcPs = EpToken "stock"+type instance XStockStrategy    GhcRn = NoExtField+type instance XStockStrategy    GhcTc = NoExtField++type instance XAnyClassStrategy GhcPs = EpToken "anyclass"+type instance XAnyClassStrategy GhcRn = NoExtField+type instance XAnyClassStrategy GhcTc = NoExtField++type instance XNewtypeStrategy  GhcPs = EpToken "newtype"+type instance XNewtypeStrategy  GhcRn = NoExtField+type instance XNewtypeStrategy  GhcTc = NoExtField++type instance XViaStrategy GhcPs = XViaStrategyPs+type instance XViaStrategy GhcRn = LHsSigType GhcRn+type instance XViaStrategy GhcTc = Type++data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs)++instance OutputableBndrId p+        => Outputable (DerivStrategy (GhcPass p)) where+    ppr (StockStrategy    _) = text "stock"+    ppr (AnyclassStrategy _) = text "anyclass"+    ppr (NewtypeStrategy  _) = text "newtype"+    ppr (ViaStrategy ty)     = text "via" <+> case ghcPass @p of+                                                GhcPs -> ppr ty+                                                GhcRn -> ppr ty+                                                GhcTc -> ppr ty++instance Outputable XViaStrategyPs where+    ppr (XViaStrategyPs _ t) = ppr t+++-- | Eliminate a 'DerivStrategy'.+foldDerivStrategy :: (p ~ GhcPass pass)+                  => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r+foldDerivStrategy other _   (StockStrategy    _) = other+foldDerivStrategy other _   (AnyclassStrategy _) = other+foldDerivStrategy other _   (NewtypeStrategy  _) = other+foldDerivStrategy _     via (ViaStrategy t)  = via t++-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,+-- return the 'DerivStrategy' unchanged.+mapDerivStrategy :: (p ~ GhcPass pass)+                 => (XViaStrategy p -> XViaStrategy p)+                 -> DerivStrategy p -> DerivStrategy p+mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds++{-+************************************************************************+*                                                                      *+\subsection[DefaultDecl]{A @default@ declaration}+*                                                                      *+************************************************************************+-}++type instance XCDefaultDecl    GhcPs = (EpToken "default", EpToken "(", EpToken ")")+type instance XCDefaultDecl    GhcRn = NoExtField+type instance XCDefaultDecl    GhcTc = NoExtField++type instance XXDefaultDecl    (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (DefaultDecl (GhcPass p)) where+    ppr (DefaultDecl _ cl tys)+      = text "default" <+> maybe id ((<+>) . ppr) cl (parens (interpp'SP tys))++{-+************************************************************************+*                                                                      *+\subsection{Foreign function interface declaration}+*                                                                      *+************************************************************************+-}++type instance XForeignImport   GhcPs = (EpToken "foreign", EpToken "import", TokDcolon)+type instance XForeignImport   GhcRn = NoExtField+type instance XForeignImport   GhcTc = Coercion++type instance XForeignExport   GhcPs = (EpToken "foreign", EpToken "export", TokDcolon)+type instance XForeignExport   GhcRn = NoExtField+type instance XForeignExport   GhcTc = Coercion++type instance XXForeignDecl    (GhcPass _) = DataConCantHappen++type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity+type instance XXForeignImport  (GhcPass _) = DataConCantHappen++type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity+type instance XXForeignExport  (GhcPass _) = DataConCantHappen+++-- pretty printing of foreign declarations++instance OutputableBndrId p+       => Outputable (ForeignDecl (GhcPass p)) where+  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })+    = hang (text "foreign import" <+> ppr fimport <+> ppr n)+         2 (dcolon <+> ppr ty)+  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =+    hang (text "foreign export" <+> ppr fexport <+> ppr n)+       2 (dcolon <+> ppr ty)++instance OutputableBndrId p+       => Outputable (ForeignImport (GhcPass p)) where+  ppr (CImport (L _ srcText) cconv safety mHeader spec) =+    ppr cconv <+> ppr safety+      <+> pprWithSourceText srcText (pprCEntity spec "")+    where+      pp_hdr = case mHeader of+               Nothing -> empty+               Just (Header _ header) -> ftext header++      pprCEntity (CLabel lbl) _ =+        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl+      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =+        if dqNeeded then doubleQuotes ce else empty+          where+            dqNeeded = (take 6 src == "static")+                    || isJust mHeader+                    || not isFun+                    || st /= NoSourceText+            ce =+                  -- We may need to drop leading spaces first+                  (if take 6 src == "static" then text "static" else empty)+              <+> pp_hdr+              <+> (if isFun then empty else text "value")+              <+> (pprWithSourceText st empty)+      pprCEntity (CFunction DynamicTarget) _ =+        doubleQuotes $ text "dynamic"+      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"++instance OutputableBndrId p+       => Outputable (ForeignExport (GhcPass p)) where+  ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) =+    ppr cconv <+> char '"' <> ppr lbl <> char '"'++{-+************************************************************************+*                                                                      *+\subsection{Rewrite rules}+*                                                                      *+************************************************************************+-}++type instance XCRuleDecls    GhcPs = ((EpaLocation, EpToken "#-}"), SourceText)+type instance XCRuleDecls    GhcRn = SourceText+type instance XCRuleDecls    GhcTc = SourceText++type instance XXRuleDecls    (GhcPass _) = DataConCantHappen++type instance XHsRule       GhcPs = ((ActivationAnn, EpToken "="), SourceText)+type instance XHsRule       GhcRn = (HsRuleRn, SourceText)+type instance XHsRule       GhcTc = (HsRuleRn, SourceText)++data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS+  deriving Data++data HsRuleAnn+  = HsRuleAnn+       { ra_tyanns :: Maybe (TokForall, EpToken ".")+       , ra_tmanns :: Maybe (TokForall, EpToken ".")+       , ra_equal  :: EpToken "="+       , ra_rest :: ActivationAnn+       } deriving (Data, Eq)++instance NoAnn HsRuleAnn where+  noAnn = HsRuleAnn Nothing Nothing noAnn noAnn++type instance XXRuleDecl    (GhcPass _) = DataConCantHappen++flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls++instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where+  ppr (HsRules { rds_ext = ext+               , rds_rules = rules })+    = pprWithSourceText st (text "{-# RULES")+          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"+              where st = case ghcPass @p of+                           GhcPs | (_, st) <- ext -> st+                           GhcRn -> ext+                           GhcTc -> ext++instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where+  ppr (HsRule { rd_ext  = ext+              , rd_name = name+              , rd_act  = act+              , rd_bndrs = bndrs+              , rd_lhs  = lhs+              , rd_rhs  = rhs })+        = sep [pprFullRuleName st name <+> ppr act,+               nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)),+               nest 6 (equals <+> pprExpr (unLoc rhs)) ]+        where+          st = case ghcPass @p of+                 GhcPs | (_, st) <- ext -> st+                 GhcRn | (_, st) <- ext -> st+                 GhcTc | (_, st) <- ext -> st++pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc+pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)+++{-+************************************************************************+*                                                                      *+\subsection[DeprecDecl]{Deprecations}+*                                                                      *+************************************************************************+-}++type instance XWarnings      GhcPs = ((EpaLocation, EpToken "#-}"), SourceText)+type instance XWarnings      GhcRn = SourceText+type instance XWarnings      GhcTc = SourceText++type instance XXWarnDecls    (GhcPass _) = DataConCantHappen++type instance XWarning      (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]"))+type instance XXWarnDecl    (GhcPass _) = DataConCantHappen+++instance OutputableBndrId p+        => Outputable (WarnDecls (GhcPass p)) where+    ppr (Warnings ext decls)+      = ftext src <+> vcat (punctuate semi (map ppr decls)) <+> text "#-}"+      where src = case ghcPass @p of+              GhcPs | (_, SourceText src) <- ext -> src+              GhcRn | SourceText src <- ext -> src+              GhcTc | SourceText src <- ext -> src+              _ -> panic "WarnDecls"++instance OutputableBndrId p+       => Outputable (WarnDecl (GhcPass p)) where+    ppr (Warning (ns_spec, _) thing txt)+      = ppr_category+              <+> ppr ns_spec+              <+> hsep (punctuate comma (map ppr thing))+              <+> ppr txt+      where+        ppr_category = case txt of+                         WarningTxt (Just cat) _ _ -> ppr cat+                         _ -> empty++{-+************************************************************************+*                                                                      *+\subsection[AnnDecl]{Annotations}+*                                                                      *+************************************************************************+-}++type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText)+type instance XXAnnDecl     (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where+    ppr (HsAnnotation _ provenance expr)+      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]++pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc+pprAnnProvenance ModuleAnnProvenance       = text "ANN module"+pprAnnProvenance (ValueAnnProvenance (L _ name))+  = text "ANN" <+> ppr name+pprAnnProvenance (TypeAnnProvenance (L _ name))+  = text "ANN type" <+> ppr name++{-+************************************************************************+*                                                                      *+\subsection[RoleAnnot]{Role annotations}+*                                                                      *+************************************************************************+-}++type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role")+type instance XCRoleAnnotDecl GhcRn = NoExtField+type instance XCRoleAnnotDecl GhcTc = NoExtField++type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen++instance OutputableBndr (IdP (GhcPass p))+       => Outputable (RoleAnnotDecl (GhcPass p)) where+  ppr (RoleAnnotDecl _ ltycon roles)+    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>+      hsep (map (pp_role . unLoc) roles)+    where+      pp_role Nothing  = underscore+      pp_role (Just r) = ppr r++roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)+roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA+type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA+type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO+type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO+type instance Anno CType = SrcSpanAnnP+type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO+type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC+type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA+type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno Bool = EpAnnCO+type instance Anno [LocatedA (HsConDeclRecField (GhcPass _))] = SrcSpanAnnL+type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA+type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA+type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno OverlapMode = SrcSpanAnnP+type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO+type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (SourceText, RuleName) = EpAnnCO+type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA+type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (Maybe Role) = EpAnnCO+type instance Anno CCallConv   = EpaLocation+type instance Anno Safety      = EpaLocation+type instance Anno CExportSpec = EpaLocation
GHC/Hs/Doc.hs view
@@ -1,152 +1,318 @@-{-# LANGUAGE CPP #-}+-- | Types and functions for raw and lexed docstrings. {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Hs.Doc-  ( HsDocString-  , LHsDocString-  , mkHsDocString-  , mkHsDocStringUtf8ByteString-  , unpackHDS-  , hsDocStringToByteString-  , ppr_mbDoc+  ( HsDoc+  , WithHsDocIdentifiers(..)+  , hsDocIds+  , LHsDoc+  , pprHsDocDebug+  , pprWithDoc+  , pprMaybeWithDoc -  , appendDocs-  , concatDocs+  , module GHC.Hs.DocString -  , DeclDocMap(..)-  , emptyDeclDocMap+  , ExtractedTHDocs(..) -  , ArgDocMap(..)-  , emptyArgDocMap-  ) where+  , DocStructureItem(..)+  , DocStructure -#include "HsVersions.h"+  , Docs(..)+  , emptyDocs+  ) where -import GhcPrelude+import GHC.Prelude -import Binary-import Encoding-import FastFunctions-import Name-import Outputable-import SrcLoc+import GHC.Utils.Binary+import GHC.Types.Name+import GHC.Utils.Outputable as Outputable hiding ((<>))+import GHC.Types.SrcLoc+import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.EnumSet (EnumSet)+import GHC.Types.Avail+import GHC.Types.Name.Set+import GHC.Driver.Flags -import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Internal as BS+import Control.DeepSeq import Data.Data+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe-import Foreign+import Data.List.NonEmpty (NonEmpty(..))+import GHC.LanguageExtensions.Type+import qualified GHC.Utils.Outputable as O+import GHC.Hs.Extension+import GHC.Types.Unique.Map+import Data.List (sortBy) --- | Haskell Documentation String+import GHC.Hs.DocString++import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name++-- | A docstring with the (probable) identifiers found in it.+type HsDoc = WithHsDocIdentifiers HsDocString++-- | Annotate a value with the probable identifiers found in it+-- These will be used by haddock to generate links. ----- Internally this is a UTF8-Encoded 'ByteString'.-newtype HsDocString = HsDocString ByteString-  -- There are at least two plausible Semigroup instances for this type:-  ---  -- 1. Simple string concatenation.-  -- 2. Concatenation as documentation paragraphs with newlines in between.-  ---  -- To avoid confusion, we pass on defining an instance at all.-  deriving (Eq, Show, Data)+-- The identifiers are bundled along with their location in the source file.+-- This is useful for tooling to know exactly where they originate.+--+-- This type is currently used in two places - for regular documentation comments,+-- with 'a' set to 'HsDocString', and for adding identifier information to+-- warnings, where 'a' is 'StringLiteral'+data WithHsDocIdentifiers a pass = WithHsDocIdentifiers+  { hsDocString      :: !a+  , hsDocIdentifiers :: ![Located (IdP pass)]+  } --- | Located Haskell Documentation String-type LHsDocString = Located HsDocString+deriving instance (Data pass, Data (IdP pass), Data a) => Data (WithHsDocIdentifiers a pass)+deriving instance (Eq (IdP pass), Eq a) => Eq (WithHsDocIdentifiers a pass)+instance (NFData (IdP pass), NFData a) => NFData (WithHsDocIdentifiers a pass) where+  rnf (WithHsDocIdentifiers d i) = rnf d `seq` rnf i -instance Binary HsDocString where-  put_ bh (HsDocString bs) = put_ bh bs-  get bh = HsDocString <$> get bh+-- | For compatibility with the existing @-ddump-parsed' output, we only show+-- the docstring.+--+-- Use 'pprHsDoc' to show `HsDoc`'s internals.+instance Outputable a => Outputable (WithHsDocIdentifiers a pass) where+  ppr (WithHsDocIdentifiers s _ids) = ppr s -instance Outputable HsDocString where-  ppr = doubleQuotes . text . unpackHDS+instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where+  put_ bh (WithHsDocIdentifiers s ids) = do+    put_ bh s+    put_ bh $ BinLocated <$> ids+  get bh =+    liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh) -mkHsDocString :: String -> HsDocString-mkHsDocString s =-  inlinePerformIO $ do-    let len = utf8EncodedLength s-    buf <- mallocForeignPtrBytes len-    withForeignPtr buf $ \ptr -> do-      utf8EncodeString ptr s-      pure (HsDocString (BS.fromForeignPtr buf 0 len))+-- | Extract a mapping from the lexed identifiers to the names they may+-- correspond to.+hsDocIds :: WithHsDocIdentifiers a GhcRn -> NameSet+hsDocIds (WithHsDocIdentifiers _ ids) = mkNameSet $ map unLoc ids --- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.-mkHsDocStringUtf8ByteString :: ByteString -> HsDocString-mkHsDocStringUtf8ByteString = HsDocString+-- | Pretty print a thing with its doc+-- The docstring will include the comment decorators '-- |', '{-|' etc+-- and will come either before or after depending on how it was written+-- i.e it will come after the thing if it is a '-- ^' or '{-^' and before+-- otherwise.+pprWithDoc :: LHsDoc name -> SDoc -> SDoc+pprWithDoc doc = pprWithDocString (hsDocString $ unLoc doc) -unpackHDS :: HsDocString -> String-unpackHDS = utf8DecodeByteString . hsDocStringToByteString+-- | See 'pprWithHsDoc'+pprMaybeWithDoc :: Maybe (LHsDoc name) -> SDoc -> SDoc+pprMaybeWithDoc Nothing    = id+pprMaybeWithDoc (Just doc) = pprWithDoc doc --- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'.-hsDocStringToByteString :: HsDocString -> ByteString-hsDocStringToByteString (HsDocString bs) = bs+-- | Print a doc with its identifiers, useful for debugging+pprHsDocDebug :: (Outputable (IdP name)) => HsDoc name -> SDoc+pprHsDocDebug (WithHsDocIdentifiers s ids) =+    vcat [ text "text:" $$ nest 2 (pprHsDocString s)+         , text "identifiers:" $$ nest 2 (vcat (map pprLocatedAlways ids))+         ] -ppr_mbDoc :: Maybe LHsDocString -> SDoc-ppr_mbDoc (Just doc) = ppr doc-ppr_mbDoc Nothing    = empty+type LHsDoc pass = Located (HsDoc pass) --- | Join two docstrings.------ Non-empty docstrings are joined with two newlines in between,--- resulting in separate paragraphs.-appendDocs :: HsDocString -> HsDocString -> HsDocString-appendDocs x y =-  fromMaybe-    (HsDocString BS.empty)-    (concatDocs [x, y])+-- | A simplified version of 'HsImpExp.IE'.+data DocStructureItem+  = DsiSectionHeading !Int !(HsDoc GhcRn)+  | DsiDocChunk !(HsDoc GhcRn)+  | DsiNamedChunkRef !String+  | DsiExports !DetOrdAvails+  | DsiModExport+      !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple+                            -- modules with a single export declaration. E.g.+                            -- when we have+                            --+                            -- > module M (module X) where+                            -- > import R0 as X+                            -- > import R1 as X+                            --+                            -- Invariant: This list of ModuleNames must be+                            -- sorted to guarantee interface file determinism.+      !DetOrdAvails+                            -- ^ Invariant: This list of Avails must be sorted+                            -- to guarantee interface file determinism. --- | Concat docstrings with two newlines in between.------ Empty docstrings are skipped.------ If all inputs are empty, 'Nothing' is returned.-concatDocs :: [HsDocString] -> Maybe HsDocString-concatDocs xs =-    if BS.null b-      then Nothing-      else Just (HsDocString b)-  where-    b = BS.intercalate (C8.pack "\n\n")-      . filter (not . BS.null)-      . map hsDocStringToByteString-      $ xs+instance Binary DocStructureItem where+  put_ bh = \case+    DsiSectionHeading level doc -> do+      putByte bh 0+      put_ bh level+      put_ bh doc+    DsiDocChunk doc -> do+      putByte bh 1+      put_ bh doc+    DsiNamedChunkRef name -> do+      putByte bh 2+      put_ bh name+    DsiExports avails -> do+      putByte bh 3+      put_ bh avails+    DsiModExport mod_names avails -> do+      putByte bh 4+      put_ bh mod_names+      put_ bh avails --- | Docs for declarations: functions, data types, instances, methods etc.-newtype DeclDocMap = DeclDocMap (Map Name HsDocString)+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> DsiSectionHeading <$> get bh <*> get bh+      1 -> DsiDocChunk <$> get bh+      2 -> DsiNamedChunkRef <$> get bh+      3 -> DsiExports <$> get bh+      4 -> DsiModExport <$> get bh <*> get bh+      _ -> fail "instance Binary DocStructureItem: Invalid tag" -instance Binary DeclDocMap where-  put_ bh (DeclDocMap m) = put_ bh (Map.toList m)-  -- We can't rely on a deterministic ordering of the `Name`s here.-  -- See the comments on `Name`'s `Ord` instance for context.-  get bh = DeclDocMap . Map.fromList <$> get bh+instance Outputable DocStructureItem where+  ppr = \case+    DsiSectionHeading level doc -> vcat+      [ text "section heading, level" <+> ppr level O.<> colon+      , nest 2 (pprHsDocDebug doc)+      ]+    DsiDocChunk doc -> vcat+      [ text "documentation chunk:"+      , nest 2 (pprHsDocDebug doc)+      ]+    DsiNamedChunkRef name ->+      text "reference to named chunk:" <+> text name+    DsiExports avails ->+      text "avails:" $$ nest 2 (ppr avails)+    DsiModExport mod_names avails ->+      text "re-exported module(s):" <+> ppr mod_names $$ nest 2 (ppr avails) -instance Outputable DeclDocMap where-  ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m))-    where-      pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc)+instance NFData DocStructureItem where+  rnf = \case+    DsiSectionHeading level doc -> rnf level `seq` rnf doc+    DsiDocChunk doc -> rnf doc+    DsiNamedChunkRef name -> rnf name+    DsiExports avails -> rnf avails+    DsiModExport mod_names avails -> rnf mod_names `seq` rnf avails -emptyDeclDocMap :: DeclDocMap-emptyDeclDocMap = DeclDocMap Map.empty --- | Docs for arguments. E.g. function arguments, method arguments.-newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))+type DocStructure = [DocStructureItem] -instance Binary ArgDocMap where-  put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m))-  -- We can't rely on a deterministic ordering of the `Name`s here.-  -- See the comments on `Name`'s `Ord` instance for context.-  get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh+data Docs = Docs+  { docs_mod_hdr      :: Maybe (HsDoc GhcRn)+    -- ^ Module header.+  , docs_exports      :: UniqMap Name (HsDoc GhcRn)+     -- ^ Docs attached to module exports.+  , docs_decls        :: UniqMap Name [HsDoc GhcRn]+    -- ^ Docs for declarations: functions, data types, instances, methods etc.+    -- A list because sometimes subsequent haddock comments can be combined into one+  , docs_args         :: UniqMap Name (IntMap (HsDoc GhcRn))+    -- ^ Docs for arguments. E.g. function arguments, method arguments.+  , docs_structure    :: DocStructure+  , docs_named_chunks :: Map String (HsDoc GhcRn)+    -- ^ Map from chunk name to content.+    --+    -- This map will be empty unless we have an explicit export list from which+    -- we can reference the chunks.+  , docs_haddock_opts :: Maybe String+    -- ^ Haddock options from @OPTIONS_HADDOCK@ or from @-haddock-opts@.+  , docs_language     :: Maybe Language+    -- ^ The 'Language' used in the module, for example 'Haskell2010'.+  , docs_extensions   :: EnumSet Extension+    -- ^ The full set of language extensions used in the module.+  } -instance Outputable ArgDocMap where-  ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))+instance NFData Docs where+  rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions)+    = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks+    `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions+    `seq` ()++instance Binary Docs where+  put_ bh docs = do+    put_ bh (docs_mod_hdr docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)+    put_ bh (docs_structure docs)+    put_ bh (Map.toList $ docs_named_chunks docs)+    put_ bh (docs_haddock_opts docs)+    put_ bh (docs_language docs)+    put_ bh (docs_extensions docs)+  get bh = do+    mod_hdr <- get bh+    exports <- listToUniqMap <$> get bh+    decls <- listToUniqMap <$> get bh+    args <- listToUniqMap <$> get bh+    structure <- get bh+    named_chunks <- Map.fromList <$> get bh+    haddock_opts <- get bh+    language <- get bh+    exts <- get bh+    pure Docs { docs_mod_hdr = mod_hdr+              , docs_exports = exports+              , docs_decls = decls+              , docs_args = args+              , docs_structure = structure+              , docs_named_chunks = named_chunks+              , docs_haddock_opts = haddock_opts+              , docs_language = language+              , docs_extensions = exts+              }++instance Outputable Docs where+  ppr docs =+      vcat+        [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr+        , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports+        , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls+        , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args+        , pprField (vcat . map ppr) "documentation structure" docs_structure+        , pprField (pprMap (doubleQuotes . text) pprHsDocDebug) "named chunks"+                   docs_named_chunks+        , pprField pprMbString "haddock options" docs_haddock_opts+        , pprField ppr "language" docs_language+        , pprField (vcat . map ppr . EnumSet.toList) "language extensions"+                   docs_extensions+        ]     where-      pprPair (name, int_map) =-        ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)-      pprIntMap im = vcat (map pprIPair (Map.toAscList im))-      pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)+      pprField :: (a -> SDoc) -> String -> (Docs -> a) -> SDoc+      pprField ppr' heading lbl =+        text heading O.<> colon $$ nest 2 (ppr' (lbl docs))+      pprMap pprKey pprVal m =+        vcat $ flip map (Map.toList m) $ \(k, v) ->+          pprKey k O.<> colon $$ nest 2 (pprVal v)+      pprIntMap pprKey pprVal m =+        vcat $ flip map (IntMap.toList m) $ \(k, v) ->+          pprKey k O.<> colon $$ nest 2 (pprVal v)+      pprMbString Nothing = empty+      pprMbString (Just s) = text s+      pprMaybe ppr' = \case+        Nothing -> text "Nothing"+        Just x -> text "Just" <+> ppr' x -emptyArgDocMap :: ArgDocMap-emptyArgDocMap = ArgDocMap Map.empty+emptyDocs :: Docs+emptyDocs = Docs+  { docs_mod_hdr = Nothing+  , docs_exports = emptyUniqMap+  , docs_decls = emptyUniqMap+  , docs_args = emptyUniqMap+  , docs_structure = []+  , docs_named_chunks = Map.empty+  , docs_haddock_opts = Nothing+  , docs_language = Nothing+  , docs_extensions = EnumSet.empty+  }++-- | Maps of docs that were added via Template Haskell's @putDoc@.+data ExtractedTHDocs =+  ExtractedTHDocs+    { ethd_mod_header :: Maybe (HsDoc GhcRn)+      -- ^ The added module header documentation, if it exists.+    , ethd_decl_docs  :: UniqMap Name (HsDoc GhcRn)+      -- ^ The documentation added to declarations.+    , ethd_arg_docs   :: UniqMap Name (IntMap (HsDoc GhcRn))+      -- ^ The documentation added to function arguments.+    , ethd_inst_docs  :: UniqMap Name (HsDoc GhcRn)+      -- ^ The documentation added to class and family instances.+    }
+ GHC/Hs/Doc.hs-boot view
@@ -0,0 +1,19 @@+{-# LANGUAGE RoleAnnotations #-}+module GHC.Hs.Doc where++-- See #21592 for progress on removing this boot file.++import GHC.Types.SrcLoc+import GHC.Hs.DocString+import Data.Kind++type role WithHsDocIdentifiers representational nominal+type WithHsDocIdentifiers :: Type -> Type -> Type+data WithHsDocIdentifiers a pass++type HsDoc :: Type -> Type+type HsDoc = WithHsDocIdentifiers HsDocString++type LHsDoc :: Type -> Type+type LHsDoc pass = Located (HsDoc pass)+
+ GHC/Hs/DocString.hs view
@@ -0,0 +1,212 @@+-- | An exactprintable structure for docstrings+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Hs.DocString+  ( LHsDocString+  , HsDocString(..)+  , HsDocStringDecorator(..)+  , HsDocStringChunk(..)+  , LHsDocStringChunk+  , isEmptyDocString+  , unpackHDSC+  , mkHsDocStringChunk+  , mkHsDocStringChunkUtf8ByteString+  , pprHsDocString+  , pprHsDocStrings+  , mkGeneratedHsDocString+  , docStringChunks+  , renderHsDocString+  , renderHsDocStrings+  , exactPrintHsDocString+  , pprWithDocString+  , printDecorator+  ) where++import GHC.Prelude++import GHC.Utils.Binary+import GHC.Utils.Encoding+import GHC.Utils.Outputable as Outputable hiding ((<>))+import GHC.Types.SrcLoc+import Control.DeepSeq++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Data+import Data.List.NonEmpty (NonEmpty(..))+import Data.List (intercalate)++type LHsDocString = Located HsDocString++-- | Haskell Documentation String+--+-- Rich structure to support exact printing+-- The location around each chunk doesn't include the decorators+data HsDocString+  = MultiLineDocString !HsDocStringDecorator !(NonEmpty LHsDocStringChunk)+     -- ^ The first chunk is preceded by "-- <decorator>" and each following chunk is preceded by "--"+     -- Example: -- | This is a docstring for 'foo'. It is the line with the decorator '|' and is always included+     --          -- This continues that docstring and is the second element in the NonEmpty list+     --          foo :: a -> a+  | NestedDocString !HsDocStringDecorator LHsDocStringChunk+     -- ^ The docstring is preceded by "{-<decorator>" and followed by "-}"+     -- The chunk contains balanced pairs of '{-' and '-}'+  | GeneratedDocString HsDocStringChunk+     -- ^ A docstring generated either internally or via TH+     -- Pretty printed with the '-- |' decorator+     -- This is because it may contain unbalanced pairs of '{-' and '-}' and+     -- not form a valid 'NestedDocString'+  deriving (Eq, Data, Show)++instance Outputable HsDocString where+  ppr = text . renderHsDocString++instance NFData HsDocString where+  rnf (MultiLineDocString a b) = rnf a `seq` rnf b+  rnf (NestedDocString a b) = rnf a `seq` rnf b+  rnf (GeneratedDocString a) = rnf a++-- | Annotate a pretty printed thing with its doc+-- The docstring comes after if is 'HsDocStringPrevious'+-- Otherwise it comes before.+-- Note - we convert MultiLineDocString HsDocStringPrevious to HsDocStringNext+-- because we can't control if something else will be pretty printed on the same line+pprWithDocString :: HsDocString -> SDoc -> SDoc+pprWithDocString  (MultiLineDocString HsDocStringPrevious ds) sd = pprWithDocString (MultiLineDocString HsDocStringNext ds) sd+pprWithDocString doc@(NestedDocString HsDocStringPrevious  _) sd = sd <+> pprHsDocString doc+pprWithDocString doc sd = pprHsDocString doc $+$ sd+++instance Binary HsDocString where+  put_ bh x = case x of+    MultiLineDocString dec xs -> do+      putByte bh 0+      put_ bh dec+      put_ bh $ BinLocated <$> xs+    NestedDocString dec x -> do+      putByte bh 1+      put_ bh dec+      put_ bh $ BinLocated x+    GeneratedDocString x -> do+      putByte bh 2+      put_ bh x+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> MultiLineDocString <$> get bh <*> (fmap unBinLocated <$> get bh)+      1 -> NestedDocString <$> get bh <*> (unBinLocated <$> get bh)+      2 -> GeneratedDocString <$> get bh+      t -> fail $ "HsDocString: invalid tag " ++ show t++data HsDocStringDecorator+  = HsDocStringNext -- ^ '|' is the decorator+  | HsDocStringPrevious -- ^ '^' is the decorator+  | HsDocStringNamed !String -- ^ '$<string>' is the decorator+  | HsDocStringGroup !Int -- ^ The decorator is the given number of '*'s+  deriving (Eq, Ord, Show, Data)++instance Outputable HsDocStringDecorator where+  ppr = text . printDecorator++instance NFData HsDocStringDecorator where+  rnf HsDocStringNext = ()+  rnf HsDocStringPrevious = ()+  rnf (HsDocStringNamed x) = rnf x+  rnf (HsDocStringGroup x) = rnf x++printDecorator :: HsDocStringDecorator -> String+printDecorator HsDocStringNext = "|"+printDecorator HsDocStringPrevious = "^"+printDecorator (HsDocStringNamed n) = '$':n+printDecorator (HsDocStringGroup n) = replicate n '*'++instance Binary HsDocStringDecorator where+  put_ bh x = case x of+    HsDocStringNext -> putByte bh 0+    HsDocStringPrevious -> putByte bh 1+    HsDocStringNamed n -> putByte bh 2 >> put_ bh n+    HsDocStringGroup n -> putByte bh 3 >> put_ bh n+  get bh = do+    tag <- getByte bh+    case tag of+      0 -> pure HsDocStringNext+      1 -> pure HsDocStringPrevious+      2 -> HsDocStringNamed <$> get bh+      3 -> HsDocStringGroup <$> get bh+      t -> fail $ "HsDocStringDecorator: invalid tag " ++ show t++type LHsDocStringChunk = Located HsDocStringChunk++-- | A contiguous chunk of documentation+newtype HsDocStringChunk = HsDocStringChunk ByteString+  deriving stock (Eq,Ord,Data, Show)+  deriving newtype (NFData)++instance Binary HsDocStringChunk where+  put_ bh (HsDocStringChunk bs) = put_ bh bs+  get bh = HsDocStringChunk <$> get bh++instance Outputable HsDocStringChunk where+  ppr = text . unpackHDSC++mkHsDocStringChunk :: String -> HsDocStringChunk+mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s)++-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'.+mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk+mkHsDocStringChunkUtf8ByteString = HsDocStringChunk++unpackHDSC :: HsDocStringChunk -> String+unpackHDSC (HsDocStringChunk bs) = utf8DecodeByteString bs++nullHDSC :: HsDocStringChunk -> Bool+nullHDSC (HsDocStringChunk bs) = BS.null bs++mkGeneratedHsDocString :: String -> HsDocString+mkGeneratedHsDocString = GeneratedDocString . mkHsDocStringChunk++isEmptyDocString :: HsDocString -> Bool+isEmptyDocString (MultiLineDocString _ xs) = all (nullHDSC . unLoc) xs+isEmptyDocString (NestedDocString _ s) = nullHDSC $ unLoc s+isEmptyDocString (GeneratedDocString x) = nullHDSC x++docStringChunks :: HsDocString -> [LHsDocStringChunk]+docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs+docStringChunks (NestedDocString _ x) = [x]+docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x]++-- | Pretty print with decorators, exactly as the user wrote it+pprHsDocString :: HsDocString -> SDoc+pprHsDocString = text . exactPrintHsDocString++pprHsDocStrings :: [HsDocString] -> SDoc+pprHsDocStrings = text . intercalate "\n\n" . map exactPrintHsDocString++-- | Pretty print with decorators, exactly as the user wrote it+exactPrintHsDocString :: HsDocString -> String+exactPrintHsDocString (MultiLineDocString dec (x :| xs))+  = unlines' $ ("-- " ++ printDecorator dec ++ unpackHDSC (unLoc x))+            : map (\x -> "--" ++ unpackHDSC (unLoc x)) xs+exactPrintHsDocString (NestedDocString dec (L _ s))+  = "{-" ++ printDecorator dec ++ unpackHDSC s ++ "-}"+exactPrintHsDocString (GeneratedDocString x) = case lines (unpackHDSC x) of+  [] -> ""+  (x:xs) -> unlines' $ ( "-- |" ++ x)+                    : map (\y -> "--"++y) xs++-- | Just get the docstring, without any decorators+renderHsDocString :: HsDocString -> String+renderHsDocString (MultiLineDocString _ (x :| xs)) = unlines' $ map (unpackHDSC . unLoc) (x:xs)+renderHsDocString (NestedDocString _ ds) = unpackHDSC $ unLoc ds+renderHsDocString (GeneratedDocString x) = unpackHDSC x++-- | Don't add a newline to a single string+unlines' :: [String] -> String+unlines' = intercalate "\n"++-- | Just get the docstring, without any decorators+-- Separates docstrings using "\n\n", which is how haddock likes to render them+renderHsDocStrings :: [HsDocString] -> String+renderHsDocStrings = intercalate "\n\n" . map renderHsDocString
GHC/Hs/Dump.hs view
@@ -4,7 +4,12 @@ -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-specialise #-}+   -- Don't do type-class specialisation; it goes mad in this module+   -- See #25463+ -- | Contains a debug function to dump parts of the GHC.Hs 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.@@ -12,48 +17,91 @@ module GHC.Hs.Dump (         -- * Dumping ASTs         showAstData,+        showAstDataFull,         BlankSrcSpan(..),+        BlankEpAnnotations(..),     ) where -import GhcPrelude+import GHC.Prelude -import Data.Data hiding (Fixity)-import Bag-import BasicTypes-import FastString-import NameSet-import Name-import DataCon-import SrcLoc import GHC.Hs-import OccName hiding (occName)-import Var-import Module-import Outputable +import GHC.Core.DataCon++import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Types.Name.Set+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Var+import GHC.Types.SourceText+import GHC.Utils.Outputable++import Data.Data hiding (Fixity) import qualified Data.ByteString as B+import GHC.TypeLits -data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+-- | Should source spans be removed from output.+data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan                   deriving (Eq,Show) +-- | Should EpAnnotations be removed from output.+data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations+                  deriving (Eq,Show)++-- | Show the full AST as the compiler sees it.+showAstDataFull :: Data a => a -> SDoc+showAstDataFull = showAstData NoBlankSrcSpan NoBlankEpAnnotations+ -- | 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+showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc+showAstData bs ba a0 = blankLine $$ showAstData' a0   where     showAstData' :: Data a => a -> SDoc     showAstData' =       generic               `ext1Q` list-              `extQ` string `extQ` fastString `extQ` srcSpan+              `extQ` list_epaLocation+              `extQ` list_epTokenOpenP+              `extQ` list_epTokenCloseP+              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan+              `extQ` annotationModule+              `extQ` annotationGrhsAnn+              `extQ` annotationAnnList+              `extQ` annotationAnnListWhere+              `extQ` annotationAnnListCommas+              `extQ` annotationAnnListIE+              `extQ` annotationEpAnnImportDecl+              `extQ` annotationNoEpAnns+              `extQ` annotationExprBracket+              `extQ` annotationTypedBracket+              `extQ` epTokenOC+              `extQ` epTokenCC+              `extQ` epTokenInstance+              `extQ` epTokenForall+              `extQ` annParen+              `extQ` annClassDecl+              `extQ` annSynDecl+              `extQ` annDataDefn+              `extQ` annFamilyDecl+              `extQ` annClsInstDecl               `extQ` lit `extQ` litr `extQ` litt+              `extQ` sourceText+              `extQ` deltaPos+              `extQ` epaLocation+              `extQ` maybe_epaLocation               `extQ` bytestring               `extQ` name `extQ` occName `extQ` moduleName `extQ` var               `extQ` dataCon               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity               `ext2Q` located+              `extQ` srcSpanAnnA+              `extQ` srcSpanAnnL+              `extQ` srcSpanAnnP+              `extQ` srcSpanAnnC+              `extQ` srcSpanAnnN        where generic :: Data a => a -> SDoc             generic t = parens $ text (showConstr (toConstr t))@@ -64,12 +112,30 @@              fastString :: FastString -> SDoc             fastString s = braces $-                            text "FastString: "-                         <> text (normalize_newlines . show $ s)+                            text "FastString:"+                        <+> text (normalize_newlines . show $ s)              bytestring :: B.ByteString -> SDoc             bytestring = text . normalize_newlines . show +            list_epaLocation :: [EpaLocation] -> SDoc+            list_epaLocation ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpaLocation]"+              NoBlankEpAnnotations -> list ls++            list_epTokenOpenP :: [EpToken "("] -> SDoc+            list_epTokenOpenP ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpToken \"(\"]"+              NoBlankEpAnnotations -> list ls++            list_epTokenCloseP :: [EpToken ")"] -> SDoc+            list_epTokenCloseP ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[EpToken \"(\"]"+              NoBlankEpAnnotations -> list ls+             list []    = brackets empty             list [x]   = brackets (showAstData' x)             list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)@@ -105,61 +171,256 @@                                                , generic x                                                , generic s ] +            sourceText :: SourceText -> SDoc+            sourceText NoSourceText = case bs of+              BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"+              _            -> parens $ text "NoSourceText"+            sourceText (SourceText src) = case bs of+              BlankSrcSpan     -> parens $ text "SourceText" <+> text "blanked"+              _                -> parens $ text "SourceText" <+> ftext src++            epaLocation :: EpaLocation -> SDoc+            epaLocation (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s+            epaLocation (EpaDelta s d cs) = case ba of+              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstData' cs+              BlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> text "blanked"++            maybe_epaLocation :: Maybe EpaLocation -> SDoc+            maybe_epaLocation ml = case ba of+              NoBlankEpAnnotations -> case ml of+                Nothing -> parens $ text "Nothing"+                Just l -> parens (text "Just" $$ showAstData' l)+              BlankEpAnnotations -> parens $ text "Maybe EpaLocation:" <+> text "blanked"++            deltaPos :: DeltaPos -> SDoc+            deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c+            deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c+             name :: Name -> SDoc-            name nm    = braces $ text "Name: " <> ppr nm+            name nm    = braces $ text "Name:" <+> ppr nm              occName n  =  braces $-                          text "OccName: "-                       <> text (OccName.occNameString n)+                          text "OccName:"+                      <+> ftext (occNameFS n)              moduleName :: ModuleName -> SDoc-            moduleName m = braces $ text "ModuleName: " <> ppr m+            moduleName m = braces $ text "ModuleName:" <+> ppr m              srcSpan :: SrcSpan -> SDoc-            srcSpan ss = case b of+            srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' ' +            realSrcSpan :: RealSrcSpan -> SDoc+            realSrcSpan ss = case bs of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' '++            annParen :: AnnParen -> SDoc+            annParen ap = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen"+             NoBlankEpAnnotations -> parens (case ap of+                                      (AnnParens       o c) -> text "AnnParens"       $$ vcat [showAstData' o, showAstData' c]+                                      (AnnParensHash   o c) -> text "AnnParensHash"   $$ vcat [showAstData' o, showAstData' c]+                                      (AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c]+                                      )++            annClassDecl :: AnnClassDecl -> SDoc+            annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnClassDecl"+                        $$ vcat [showAstData' c, showAstData' ops, showAstData' cps,+                                 showAstData' v, showAstData' w, showAstData' oc,+                                 showAstData' cc, showAstData' s]++            annSynDecl :: AnnSynDecl -> SDoc+            annSynDecl (AnnSynDecl ops cps t e) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnSynDecl"+                        $$ vcat [showAstData' ops, showAstData' cps,+                                 showAstData' t, showAstData' e]++            annDataDefn :: AnnDataDefn -> SDoc+            annDataDefn (AnnDataDefn a b c d e f g h i j k) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnDataDefn"+             NoBlankEpAnnotations ->+              parens $ text "AnnDataDefn"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e, showAstData' f,+                                 showAstData' g, showAstData' h, showAstData' i,+                                 showAstData' j, showAstData' k]++            annFamilyDecl :: AnnFamilyDecl -> SDoc+            annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnFamilyDecl"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e, showAstData' f,+                                 showAstData' g, showAstData' h, showAstData' i,+                                 showAstData' j, showAstData' k, showAstData' l]++            annClsInstDecl :: AnnClsInstDecl -> SDoc+            annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"+             NoBlankEpAnnotations ->+              parens $ text "AnnClsInstDecl"+                        $$ vcat [showAstData' a, showAstData' b, showAstData' c,+                                 showAstData' d, showAstData' e]+++            annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc+            annotationExprBracket = annotationBracket++            annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc+            annotationTypedBracket = annotationBracket++            annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h)+              => BracketAnn n h -> SDoc+            annotationBracket a = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "BracketAnn"+             NoBlankEpAnnotations ->+              parens $ case a of+                BracketNoE  t -> text "BracketNoE"  <+> showAstData' t+                BracketHasE t -> text "BracketHasE" <+> showAstData' t++            epTokenOC :: EpToken "{" -> SDoc+            epTokenOC  = epToken'++            epTokenCC :: EpToken "}" -> SDoc+            epTokenCC = epToken'++            epTokenInstance :: EpToken "instance" -> SDoc+            epTokenInstance = epToken'++            epTokenForall :: TokForall -> SDoc+            epTokenForall = epUniToken'++            epToken' :: KnownSymbol sym => EpToken sym -> SDoc+            epToken' (EpTok s) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpToken"+             NoBlankEpAnnotations ->+              parens $ text "EpTok" <+> epaLocation s+            epToken' NoEpTok = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpToken"+             NoBlankEpAnnotations ->+              parens $ text "NoEpTok"++            epUniToken' :: EpUniToken sym1 sym2 -> SDoc+            epUniToken' (EpUniTok s f) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpUniToken"+             NoBlankEpAnnotations ->+              parens $ text "EpUniTok" <+> epaLocation s <+> ppr f+            epUniToken' NoEpUniTok = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "EpUniToken"+             NoBlankEpAnnotations ->+              parens $ text "NoEpUniTok"++             var  :: Var -> SDoc-            var v      = braces $ text "Var: " <> ppr v+            var v      = braces $ text "Var:" <+> ppr v              dataCon :: DataCon -> SDoc-            dataCon c  = braces $ text "DataCon: " <> ppr c+            dataCon c  = braces $ text "DataCon:" <+> ppr c -            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc+            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc             bagRdrName bg =  braces $-                             text "Bag(Located (HsBind GhcPs)):"+                             text "Bag(LocatedA (HsBind GhcPs)):"                           $$ (list . bagToList $ bg) -            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc+            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc             bagName bg  =  braces $-                           text "Bag(Located (HsBind Name)):"+                           text "Bag(LocatedA (HsBind Name)):"                         $$ (list . bagToList $ bg) -            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc+            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc             bagVar bg  =  braces $-                          text "Bag(Located (HsBind Var)):"+                          text "Bag(LocatedA (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 a, Data b) => GenLocated a b -> SDoc+            located (L ss a)+              = parens (text "L"+                        $$ vcat [showAstData' ss, showAstData' a]) -            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++            -- -------------------------++            annotationModule :: EpAnn AnnsModule -> SDoc+            annotationModule = annotation' (text "EpAnn AnnsModule")++            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc+            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")++            annotationAnnList :: EpAnn (AnnList ()) -> SDoc+            annotationAnnList = annotation' (text "EpAnn (AnnList ())")++            annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc+            annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))")++            annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc+            annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])")++            annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc+            annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))")++            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")++            annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc+            annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")++            annotation' :: forall a .(Data a, Typeable a)+                       => SDoc -> EpAnn a -> SDoc+            annotation' tag anns = case ba of+             BlankEpAnnotations -> parens (text "blanked:" <+> tag)+             NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))+                                               $$ vcat (gmapQ showAstData' anns)++            -- -------------------------++            srcSpanAnnA :: EpAnn AnnListItem -> SDoc+            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")++            srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc+            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")++            srcSpanAnnP :: EpAnn AnnPragma -> SDoc+            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")++            srcSpanAnnC :: EpAnn AnnContext -> SDoc+            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")++            srcSpanAnnN :: EpAnn NameAnn -> SDoc+            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")++            locatedAnn'' :: forall a. (Typeable a, Data a)+              => SDoc -> EpAnn a -> SDoc+            locatedAnn'' tag ss = parens $+              case cast ss of+                Just (ann :: EpAnn a) ->+                  case ba of+                    BlankEpAnnotations+                      -> parens (text "blanked:" <+> tag)+                    NoBlankEpAnnotations+                      -> text (showConstr (toConstr ann))+                                          $$ vcat (gmapQ showAstData' ann)+                Nothing -> text "locatedAnn:unmatched" <+> tag+                           <+> (parens $ text (showConstr (toConstr ss)))+  normalize_newlines :: String -> String normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
GHC/Hs/Expr.hs view
@@ -1,2920 +1,2722 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}---- | Abstract Haskell syntax for expressions.-module GHC.Hs.Expr where--#include "HsVersions.h"---- friends:-import GhcPrelude--import GHC.Hs.Decls-import GHC.Hs.Pat-import GHC.Hs.Lit-import GHC.Hs.PlaceHolder ( NameOrRdrName )-import GHC.Hs.Extension-import GHC.Hs.Types-import GHC.Hs.Binds---- others:-import TcEvidence-import CoreSyn-import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )-import Name-import NameSet-import RdrName  ( GlobalRdrEnv )-import BasicTypes-import ConLike-import SrcLoc-import Util-import Outputable-import FastString-import Type-import TysWiredIn (mkTupleStr)-import TcType (TcType)-import {-# SOURCE #-} TcRnTypes (TcLclEnv)---- libraries:-import Data.Data hiding (Fixity(..))-import qualified Data.Data as Data (Fixity(..))-import Data.Maybe (isNothing)--import GHCi.RemoteTypes ( ForeignRef )-import qualified Language.Haskell.TH as TH (Q)--{--************************************************************************-*                                                                      *-\subsection{Expressions proper}-*                                                                      *-************************************************************************--}---- * Expressions proper---- | Located Haskell Expression-type LHsExpr p = Located (HsExpr p)-  -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when-  --   in a list--  -- For details on above see note [Api annotations] in ApiAnnotation------------------------------ | Post-Type checking Expression------ PostTcExpr is an evidence expression attached to the syntax tree by the--- type checker (c.f. postTcType).-type PostTcExpr  = HsExpr GhcTc---- | Post-Type checking Table------ We use a PostTcTable where there are a bunch of pieces of evidence, more--- than is convenient to keep individually.-type PostTcTable = [(Name, PostTcExpr)]------------------------------ | Syntax Expression------ SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier,--- by the renamer.  It's used for rebindable syntax.------ E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for---      @(>>=)@, and then instantiated by the type checker with its type args---      etc------ This should desugar to------ > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)--- >                         (syn_arg_wraps[1] arg1) ...------ where the actual arguments come from elsewhere in the AST.--- This could be defined using @GhcPass p@ and such, but it's--- harder to get it all to work out that way. ('noSyntaxExpr' is hard to--- write, for example.)-data SyntaxExpr p = SyntaxExpr { syn_expr      :: HsExpr p-                               , syn_arg_wraps :: [HsWrapper]-                               , syn_res_wrap  :: HsWrapper }---- | This is used for rebindable-syntax pieces that are too polymorphic--- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)-noExpr :: HsExpr (GhcPass p)-noExpr = HsLit noExtField (HsString (SourceText  "noExpr") (fsLit "noExpr"))--noSyntaxExpr :: SyntaxExpr (GhcPass p)-                              -- Before renaming, and sometimes after,-                              -- (if the syntax slot makes no sense)-noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit noExtField-                                                  (HsString NoSourceText-                                                  (fsLit "noSyntaxExpr"))-                          , syn_arg_wraps = []-                          , syn_res_wrap  = WpHole }---- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers.-mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p)-mkSyntaxExpr expr = SyntaxExpr { syn_expr      = expr-                               , syn_arg_wraps = []-                               , syn_res_wrap  = WpHole }---- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the--- renamer), missing its HsWrappers.-mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn-mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExtField $ noLoc name-  -- don't care about filling in syn_arg_wraps because we're clearly-  -- not past the typechecker--instance OutputableBndrId p-       => Outputable (SyntaxExpr (GhcPass p)) where-  ppr (SyntaxExpr { syn_expr      = expr-                  , syn_arg_wraps = arg_wraps-                  , syn_res_wrap  = res_wrap })-    = sdocWithDynFlags $ \ dflags ->-      getPprStyle $ \s ->-      if debugStyle s || gopt Opt_PrintExplicitCoercions dflags-      then ppr expr <> braces (pprWithCommas ppr arg_wraps)-                    <> braces (ppr res_wrap)-      else ppr expr---- | Command Syntax Table (for Arrow syntax)-type CmdSyntaxTable p = [(Name, HsExpr p)]--- See Note [CmdSyntaxTable]--{--Note [CmdSyntaxtable]-~~~~~~~~~~~~~~~~~~~~~-Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps-track of the methods needed for a Cmd.--* Before the renamer, this list is an empty list--* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@-  For example, for the 'arr' method-   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)-   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)-             where @arr_22@ is whatever 'arr' is in scope--* After the type checker, it takes the form [(std_name, <expression>)]-  where <expression> is the evidence for the method.  This evidence is-  instantiated with the class, but is still polymorphic in everything-  else.  For example, in the case of 'arr', the evidence has type-         forall b c. (b->c) -> a b c-  where 'a' is the ambient type of the arrow.  This polymorphism is-  important because the desugarer uses the same evidence at multiple-  different types.--This is Less Cool than what we normally do for rebindable syntax, which is to-make fully-instantiated piece of evidence at every use site.  The Cmd way-is Less Cool because-  * The renamer has to predict which methods are needed.-    See the tedious RnExpr.methodNamesCmd.--  * The desugarer has to know the polymorphic type of the instantiated-    method. This is checked by Inst.tcSyntaxName, but is less flexible-    than the rest of rebindable syntax, where the type is less-    pre-ordained.  (And this flexibility is useful; for example we can-    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)--}---- | An unbound variable; used for treating--- out-of-scope variables as expression holes------ Either "x", "y"     Plain OutOfScope--- or     "_", "_x"    A TrueExprHole------ Both forms indicate an out-of-scope variable,  but the latter--- indicates that the user /expects/ it to be out of scope, and--- just wants GHC to report its type-data UnboundVar-  = OutOfScope OccName GlobalRdrEnv  -- ^ An (unqualified) out-of-scope-                                     -- variable, together with the GlobalRdrEnv-                                     -- with respect to which it is unbound--                                     -- See Note [OutOfScope and GlobalRdrEnv]--  | TrueExprHole OccName             -- ^ A "true" expression hole (_ or _x)--  deriving Data--instance Outputable UnboundVar where-    ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ)-    ppr (TrueExprHole occ) = text "ExprHole"   <> parens (ppr occ)--unboundVarOcc :: UnboundVar -> OccName-unboundVarOcc (OutOfScope occ _) = occ-unboundVarOcc (TrueExprHole occ) = occ--{--Note [OutOfScope and GlobalRdrEnv]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To understand why we bundle a GlobalRdrEnv with an out-of-scope variable,-consider the following module:--    module A where--    foo :: ()-    foo = bar--    bat :: [Double]-    bat = [1.2, 3.4]--    $(return [])--    bar = ()-    bad = False--When A is compiled, the renamer determines that `bar` is not in scope in the-declaration of `foo` (since `bar` is declared in the following inter-splice-group).  Once it has finished typechecking the entire module, the typechecker-then generates the associated error message, which specifies both the type of-`bar` and a list of possible in-scope alternatives:--    A.hs:6:7: error:-        • Variable not in scope: bar :: ()-        • ‘bar’ (line 13) is not in scope before the splice on line 11-          Perhaps you meant ‘bat’ (line 9)--When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the-typechecker must provide a GlobalRdrEnv.  If it provided the current one, which-contains top-level declarations for the entire module, the error message would-incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives-for `bar` (see #11680).  Instead, the typechecker must use the same-GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope.--To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope-`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to-look it up in some global store?  Unfortunately, no.  The problem is that-location information is not always sufficient for this task.  This is most-apparent when dealing with the TH function addTopDecls, which adds its-declarations to the FOLLOWING inter-splice group.  Consider these declarations:--    ex9 = cat               -- cat is NOT in scope here--    $(do --------------------------------------------------------------        ds <- [d| f = cab   -- cat and cap are both in scope here-                  cat = ()-                |]-        addTopDecls ds-        [d| g = cab         -- only cap is in scope here-            cap = True-          |])--    ex10 = cat              -- cat is NOT in scope here--    $(return []) -------------------------------------------------------    ex11 = cat              -- cat is in scope--Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs-the GlobalRdrEnvs which were used when they were renamed.  These GlobalRdrEnvs-are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the-locations of the two `cab`s are the same (they are both created in the same-splice).  Thus, we must include some additional information with each `cab` to-allow the typechecker to obtain the correct GlobalRdrEnv.  Clearly, the simplest-information to use is the GlobalRdrEnv itself.--}---- | A Haskell expression.-data HsExpr p-  = HsVar     (XVar p)-              (Located (IdP p)) -- ^ Variable--                             -- See Note [Located RdrNames]--  | HsUnboundVar (XUnboundVar p)-                 UnboundVar  -- ^ Unbound variable; also used for "holes"-                             --   (_ or _x).-                             -- Turned from HsVar to HsUnboundVar by the-                             --   renamer, when it finds an out-of-scope-                             --   variable or hole.-                             -- Turned into HsVar by type checker, to support-                             --   deferred type errors.--  | HsConLikeOut (XConLikeOut p)-                 ConLike     -- ^ After typechecker only; must be different-                             -- HsVar for pretty printing--  | HsRecFld  (XRecFld p)-              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector-                                    -- Not in use after typechecking--  | HsOverLabel (XOverLabel p)-                (Maybe (IdP p)) FastString-     -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)-     --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the-     --   in-scope 'fromLabel'.-     --   NB: Not in use after typechecking--  | HsIPVar   (XIPVar p)-              HsIPName   -- ^ Implicit parameter (not in use after typechecking)-  | HsOverLit (XOverLitE p)-              (HsOverLit p)  -- ^ Overloaded literals--  | HsLit     (XLitE p)-              (HsLit p)      -- ^ Simple (non-overloaded) literals--  | HsLam     (XLam p)-              (MatchGroup p (LHsExpr p))-                       -- ^ Lambda abstraction. Currently always a single match-       ---       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',-       --       'ApiAnnotation.AnnRarrow',--       -- For details on above see note [Api annotations] in ApiAnnotation--  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case-       ---       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',-       --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',-       --           'ApiAnnotation.AnnClose'--       -- For details on above see note [Api annotations] in ApiAnnotation--  | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application--  | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p))  -- ^ Visible type application-       ---       -- Explicit type argument; e.g  f @Int x y-       -- NB: Has wildcards, but no implicit quantification-       ---       -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',--  -- | Operator applications:-  -- NB Bracketed ops such as (+) come out as Vars.--  -- NB We need an expr for the operator in an OpApp/Section since-  -- the typechecker may need to apply the operator to a few types.--  | OpApp       (XOpApp p)-                (LHsExpr p)       -- left operand-                (LHsExpr p)       -- operator-                (LHsExpr p)       -- right operand--  -- | Negation operator. Contains the negated expression and the name-  -- of 'negate'-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | NegApp      (XNegApp p)-                (LHsExpr p)-                (SyntaxExpr p)--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,-  --             'ApiAnnotation.AnnClose' @')'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsPar       (XPar p)-                (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]--  | SectionL    (XSectionL p)-                (LHsExpr p)    -- operand; see Note [Sections in HsSyn]-                (LHsExpr p)    -- operator-  | SectionR    (XSectionR p)-                (LHsExpr p)    -- operator; see Note [Sections in HsSyn]-                (LHsExpr p)    -- operand--  -- | Used for explicit tuples and sections thereof-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-  --         'ApiAnnotation.AnnClose'--  -- For details on above see note [Api annotations] in ApiAnnotation-  -- Note [ExplicitTuple]-  | ExplicitTuple-        (XExplicitTuple p)-        [LHsTupArg p]-        Boxity--  -- | Used for unboxed sum types-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,-  --          'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@,-  ---  --  There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before-  --  the expression, (arity - alternative) after it-  | ExplicitSum-          (XExplicitSum p)-          ConTag --  Alternative (one-based)-          Arity  --  Sum arity-          (LHsExpr p)--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',-  --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,-  --       'ApiAnnotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsCase      (XCase p)-                (LHsExpr p)-                (MatchGroup p (LHsExpr p))--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',-  --       'ApiAnnotation.AnnSemi',-  --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',-  --       'ApiAnnotation.AnnElse',--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsIf        (XIf p)-                (Maybe (SyntaxExpr p)) -- cond function-                                        -- Nothing => use the built-in 'if'-                                        -- See Note [Rebindable if]-                (LHsExpr p)    --  predicate-                (LHsExpr p)    --  then part-                (LHsExpr p)    --  else part--  -- | Multi-way if-  ---  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf'-  --       'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]--  -- | let(rec)-  ---  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',-  --       'ApiAnnotation.AnnOpen' @'{'@,-  --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsLet       (XLet p)-                (LHsLocalBinds p)-                (LHsExpr  p)--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',-  --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',-  --             'ApiAnnotation.AnnVbar',-  --             'ApiAnnotation.AnnClose'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsDo        (XDo p)                  -- Type of the whole expression-                (HsStmtContext Name)     -- The parameterisation is unimportant-                                         -- because in this context we never use-                                         -- the PatGuard or ParStmt variant-                (Located [ExprLStmt p]) -- "do":one or more stmts--  -- | Syntactic list: [a,b,c,...]-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,-  --              'ApiAnnotation.AnnClose' @']'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  -- See Note [Empty lists]-  | ExplicitList-                (XExplicitList p)  -- Gives type of components of list-                (Maybe (SyntaxExpr p))-                                   -- For OverloadedLists, the fromListN witness-                [LHsExpr p]--  -- | Record construction-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | RecordCon-      { rcon_ext      :: XRecordCon p-      , rcon_con_name :: Located (IdP p)    -- The constructor name;-                                            --  not used after type checking-      , rcon_flds     :: HsRecordBinds p }  -- The fields--  -- | Record update-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,-  --         'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | RecordUpd-      { rupd_ext  :: XRecordUpd p-      , rupd_expr :: LHsExpr p-      , rupd_flds :: [LHsRecUpdField p]-      }-  -- For a type family, the arg types are of the *instance* tycon,-  -- not the family tycon--  -- | Expression with an explicit type signature. @e :: type@-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | ExprWithTySig-                (XExprWithTySig p)--                (LHsExpr p)-                (LHsSigWcType (NoGhcTc p))--  -- | Arithmetic sequence-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,-  --              'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot',-  --              'ApiAnnotation.AnnClose' @']'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | ArithSeq-                (XArithSeq p)-                (Maybe (SyntaxExpr p))-                                  -- For OverloadedLists, the fromList witness-                (ArithSeqInfo p)--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsSCC       (XSCC p)-                SourceText            -- Note [Pragma source text] in BasicTypes-                StringLiteral         -- "set cost centre" SCC pragma-                (LHsExpr p)           -- expr whose cost is to be measured--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@,-  --             'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsCoreAnn   (XCoreAnn p)-                SourceText            -- Note [Pragma source text] in BasicTypes-                StringLiteral         -- hdaume: core annotation-                (LHsExpr p)--  ------------------------------------------------------------  -- MetaHaskell Extensions--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-  --         'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ',-  --         'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsBracket    (XBracket p) (HsBracket p)--    -- See Note [Pending Splices]-  | HsRnBracketOut-      (XRnBracketOut p)-      (HsBracket GhcRn)    -- Output of the renamer is the *original* renamed-                           -- expression, plus-      [PendingRnSplice]    -- _renamed_ splices to be type checked--  | HsTcBracketOut-      (XTcBracketOut p)-      (HsBracket GhcRn)    -- Output of the type checker is the *original*-                           -- renamed expression, plus-      [PendingTcSplice]    -- _typechecked_ splices to be-                           -- pasted back in by the desugarer--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-  --         'ApiAnnotation.AnnClose'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsSpliceE  (XSpliceE p) (HsSplice p)--  ------------------------------------------------------------  -- Arrow notation extension--  -- | @proc@ notation for Arrows-  ---  --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc',-  --          'ApiAnnotation.AnnRarrow'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsProc      (XProc p)-                (LPat p)               -- arrow abstraction, proc-                (LHsCmdTop p)          -- body of the abstraction-                                       -- always has an empty stack--  ----------------------------------------  -- static pointers extension-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsStatic (XStatic p) -- Free variables of the body-             (LHsExpr p)        -- Body--  ----------------------------------------  -- Haskell program coverage (Hpc) Support--  | HsTick-     (XTick p)-     (Tickish (IdP p))-     (LHsExpr p)                       -- sub-expression--  | HsBinTick-     (XBinTick p)-     Int                                -- module-local tick number for True-     Int                                -- module-local tick number for False-     (LHsExpr p)                        -- sub-expression--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-  --       'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@,-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal',-  --       'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal',-  --       'ApiAnnotation.AnnMinus',-  --       'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon',-  --       'ApiAnnotation.AnnVal',-  --       'ApiAnnotation.AnnClose' @'\#-}'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsTickPragma                      -- A pragma introduced tick-     (XTickPragma p)-     SourceText                       -- Note [Pragma source text] in BasicTypes-     (StringLiteral,(Int,Int),(Int,Int))-                                      -- external span for this tick-     ((SourceText,SourceText),(SourceText,SourceText))-        -- Source text for the four integers used in the span.-        -- See note [Pragma source text] in BasicTypes-     (LHsExpr p)--  ----------------------------------------  -- Finally, HsWrap appears only in typechecker output-  -- The contained Expr is *NOT* itself an HsWrap.-  -- See Note [Detecting forced eta expansion] in DsExpr. This invariant-  -- is maintained by GHC.Hs.Utils.mkHsWrap.--  |  HsWrap     (XWrap p)-                HsWrapper    -- TRANSLATION-                (HsExpr p)--  | XExpr       (XXExpr p) -- Note [Trees that Grow] extension constructor----- | Extra data fields for a 'RecordCon', added by the type checker-data RecordConTc = RecordConTc-      { rcon_con_like :: ConLike      -- The data constructor or pattern synonym-      , rcon_con_expr :: PostTcExpr   -- Instantiated constructor function-      }---- | Extra data fields for a 'RecordUpd', added by the type checker-data RecordUpdTc = RecordUpdTc-      { rupd_cons :: [ConLike]-                -- Filled in by the type checker to the-                -- _non-empty_ list of DataCons that have-                -- all the upd'd fields--      , rupd_in_tys  :: [Type] -- Argument types of *input* record type-      , rupd_out_tys :: [Type] --             and  *output* record type-                               -- The original type can be reconstructed-                               -- with conLikeResTy-      , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper]-      } deriving Data---- -----------------------------------------------------------------------type instance XVar           (GhcPass _) = NoExtField-type instance XUnboundVar    (GhcPass _) = NoExtField-type instance XConLikeOut    (GhcPass _) = NoExtField-type instance XRecFld        (GhcPass _) = NoExtField-type instance XOverLabel     (GhcPass _) = NoExtField-type instance XIPVar         (GhcPass _) = NoExtField-type instance XOverLitE      (GhcPass _) = NoExtField-type instance XLitE          (GhcPass _) = NoExtField-type instance XLam           (GhcPass _) = NoExtField-type instance XLamCase       (GhcPass _) = NoExtField-type instance XApp           (GhcPass _) = NoExtField--type instance XAppTypeE      (GhcPass _) = NoExtField--type instance XOpApp         GhcPs = NoExtField-type instance XOpApp         GhcRn = Fixity-type instance XOpApp         GhcTc = Fixity--type instance XNegApp        (GhcPass _) = NoExtField-type instance XPar           (GhcPass _) = NoExtField-type instance XSectionL      (GhcPass _) = NoExtField-type instance XSectionR      (GhcPass _) = NoExtField-type instance XExplicitTuple (GhcPass _) = NoExtField--type instance XExplicitSum   GhcPs = NoExtField-type instance XExplicitSum   GhcRn = NoExtField-type instance XExplicitSum   GhcTc = [Type]--type instance XCase          (GhcPass _) = NoExtField-type instance XIf            (GhcPass _) = NoExtField--type instance XMultiIf       GhcPs = NoExtField-type instance XMultiIf       GhcRn = NoExtField-type instance XMultiIf       GhcTc = Type--type instance XLet           (GhcPass _) = NoExtField--type instance XDo            GhcPs = NoExtField-type instance XDo            GhcRn = NoExtField-type instance XDo            GhcTc = Type--type instance XExplicitList  GhcPs = NoExtField-type instance XExplicitList  GhcRn = NoExtField-type instance XExplicitList  GhcTc = Type--type instance XRecordCon     GhcPs = NoExtField-type instance XRecordCon     GhcRn = NoExtField-type instance XRecordCon     GhcTc = RecordConTc--type instance XRecordUpd     GhcPs = NoExtField-type instance XRecordUpd     GhcRn = NoExtField-type instance XRecordUpd     GhcTc = RecordUpdTc--type instance XExprWithTySig (GhcPass _) = NoExtField--type instance XArithSeq      GhcPs = NoExtField-type instance XArithSeq      GhcRn = NoExtField-type instance XArithSeq      GhcTc = PostTcExpr--type instance XSCC           (GhcPass _) = NoExtField-type instance XCoreAnn       (GhcPass _) = NoExtField-type instance XBracket       (GhcPass _) = NoExtField--type instance XRnBracketOut  (GhcPass _) = NoExtField-type instance XTcBracketOut  (GhcPass _) = NoExtField--type instance XSpliceE       (GhcPass _) = NoExtField-type instance XProc          (GhcPass _) = NoExtField--type instance XStatic        GhcPs = NoExtField-type instance XStatic        GhcRn = NameSet-type instance XStatic        GhcTc = NameSet--type instance XTick          (GhcPass _) = NoExtField-type instance XBinTick       (GhcPass _) = NoExtField-type instance XTickPragma    (GhcPass _) = NoExtField-type instance XWrap          (GhcPass _) = NoExtField-type instance XXExpr         (GhcPass _) = NoExtCon---- ------------------------------------------------------------------------- | Located Haskell Tuple Argument------ 'HsTupArg' is used for tuple sections--- @(,a,)@ is represented by--- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@--- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@-type LHsTupArg id = Located (HsTupArg id)--- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'---- For details on above see note [Api annotations] in ApiAnnotation---- | Haskell Tuple Argument-data HsTupArg id-  = Present (XPresent id) (LHsExpr id)     -- ^ The argument-  | Missing (XMissing id)    -- ^ The argument is missing, but this is its type-  | XTupArg (XXTupArg id)    -- ^ Note [Trees that Grow] extension point--type instance XPresent         (GhcPass _) = NoExtField--type instance XMissing         GhcPs = NoExtField-type instance XMissing         GhcRn = NoExtField-type instance XMissing         GhcTc = Type--type instance XXTupArg         (GhcPass _) = NoExtCon--tupArgPresent :: LHsTupArg id -> Bool-tupArgPresent (L _ (Present {})) = True-tupArgPresent (L _ (Missing {})) = False-tupArgPresent (L _ (XTupArg {})) = False--{--Note [Parens in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~-HsPar (and ParPat in patterns, HsParTy in types) is used as follows--  * HsPar is required; the pretty printer does not add parens.--  * HsPars are respected when rearranging operator fixities.-    So   a * (b + c)  means what it says (where the parens are an HsPar)--  * For ParPat and HsParTy the pretty printer does add parens but this should be-    a no-op for ParsedSource, based on the pretty printer round trip feature-    introduced in-    https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c--  * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or-    not they are strictly necessary. This should be addressed when #13238 is-    completed, to be treated the same as HsPar.---Note [Sections in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~~~-Sections should always appear wrapped in an HsPar, thus-         HsPar (SectionR ...)-The parser parses sections in a wider variety of situations-(See Note [Parsing sections]), but the renamer checks for those-parens.  This invariant makes pretty-printing easier; we don't need-a special case for adding the parens round sections.--Note [Rebindable if]-~~~~~~~~~~~~~~~~~~~~-The rebindable syntax for 'if' is a bit special, because when-rebindable syntax is *off* we do not want to treat-   (if c then t else e)-as if it was an application (ifThenElse c t e).  Why not?-Because we allow an 'if' to return *unboxed* results, thus-  if blah then 3# else 4#-whereas that would not be possible using a all to a polymorphic function-(because you can't call a polymorphic function at an unboxed type).--So we use Nothing to mean "use the old built-in typing rule".--Note [Record Update HsWrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is a wrapper in RecordUpd which is used for the *required*-constraints for pattern synonyms. This wrapper is created in the-typechecking and is then directly used in the desugaring without-modification.--For example, if we have the record pattern synonym P,-  pattern P :: (Show a) => a -> Maybe a-  pattern P{x} = Just x--  foo = (Just True) { x = False }-then `foo` desugars to something like-  foo = case Just True of-          P x -> P False-hence we need to provide the correct dictionaries to P's matcher on-the RHS so that we can build the expression.--Note [Located RdrNames]-~~~~~~~~~~~~~~~~~~~~~~~-A number of syntax elements have seemingly redundant locations attached to them.-This is deliberate, to allow transformations making use of the API Annotations-to easily correlate a Located Name in the RenamedSource with a Located RdrName-in the ParsedSource.--There are unfortunately enough differences between the ParsedSource and the-RenamedSource that the API Annotations cannot be used directly with-RenamedSource, so this allows a simple mapping to be used based on the location.--Note [ExplicitTuple]-~~~~~~~~~~~~~~~~~~~~-An ExplicitTuple is never just a data constructor like (,,,).-That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least-one `Present` member (and is thus never empty).--A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an-`ExplicitTuple`, and stays that way. This is important for two reasons:--  1. We don't need -XTupleSections for (,,,)-  2. The type variables in (,,,) can be instantiated with visible type application.-     That is,--       (,,)     :: forall a b c. a -> b -> c -> (a,b,c)-       (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c)--     Note that the tuple section has *inferred* arguments, while the data-     constructor has *specified* ones.-     (See Note [Required, Specified, and Inferred for types] in TcTyClsDecls-     for background.)--Sadly, the grammar for this is actually ambiguous, and it's only thanks to the-preference of a shift in a shift/reduce conflict that the parser works as this-Note details. Search for a reference to this Note in Parser.y for further-explanation.--Note [Empty lists]-~~~~~~~~~~~~~~~~~~-An empty list could be considered either a data constructor (stored with-HsVar) or an ExplicitList. This Note describes how empty lists flow through the-various phases and why.--Parsing---------An empty list is parsed by the sysdcon nonterminal. It thus comes to life via-HsVar nilDataCon (defined in TysWiredIn). A freshly-parsed (HsExpr GhcPs) empty list-is never a ExplicitList.--Renaming----------If -XOverloadedLists is enabled, we must type-check the empty list as if it-were a call to fromListN. (This is true regardless of the setting of--XRebindableSyntax.) This is very easy if the empty list is an ExplicitList,-but an annoying special case if it's an HsVar. So the renamer changes a-HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on.-(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr.--Type-checking---------------We want to accept an expression like [] @Int. To do this, we must infer that-[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside.-However, the type-checking for explicit lists works differently: [x,y,z] is never-polymorphic. Instead, we unify the types of x, y, and z together, and use the-unified type as the argument to the cons and nil constructors. Thus, treating-[] as an empty ExplicitList in the type-checker would prevent [] @Int from working.--However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed:-it's just like fromListN 0 [] @Int. Since-  fromListN :: forall list. IsList list => Int -> [Item list] -> list-that expression really should be rejected. Thus, the renamer's behaviour is-exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as-an empty ExplicitList when -XOverloadedLists.--See also #13680, which requested [] @Int to work.--}--instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where-    ppr expr = pprExpr expr---------------------------- pprExpr, pprLExpr, pprBinds call pprDeeper;--- the underscore versions do not-pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-pprLExpr (L _ e) = pprExpr e--pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc-pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e-          | otherwise                           = pprDeeper (ppr_expr e)--isQuietHsExpr :: HsExpr id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsExpr (HsPar {})        = True--- applications don't display anything themselves-isQuietHsExpr (HsApp {})        = True-isQuietHsExpr (HsAppType {})    = True-isQuietHsExpr (OpApp {})        = True-isQuietHsExpr _ = False--pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)-         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc-pprBinds b = pprDeeper (ppr b)--------------------------ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-ppr_lexpr e = ppr_expr (unLoc e)--ppr_expr :: forall p. (OutputableBndrId p)-         => HsExpr (GhcPass p) -> SDoc-ppr_expr (HsVar _ (L _ v))  = pprPrefixOcc v-ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv)-ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c-ppr_expr (HsIPVar _ v)      = ppr v-ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l-ppr_expr (HsLit _ lit)      = ppr lit-ppr_expr (HsOverLit _ lit)  = ppr lit-ppr_expr (HsPar _ e)        = parens (ppr_lexpr e)--ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e)-  = vcat [pprWithSourceText stc (text "{-# CORE")-          <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}"-         , ppr_lexpr e]--ppr_expr e@(HsApp {})        = ppr_apps e []-ppr_expr e@(HsAppType {})    = ppr_apps e []--ppr_expr (OpApp _ e1 op e2)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly--  where-    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens-    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear--    pp_prefixly-      = hang (ppr op) 2 (sep [pp_e1, pp_e2])--    pp_infixly pp_op-      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])--ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e--ppr_expr (SectionL _ expr op)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])-                       4 (hsep [pp_expr, text "x_ )"])--    pp_infixly v = (sep [pp_expr, v])--ppr_expr (SectionR _ op expr)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])-                       4 (pp_expr <> rparen)--    pp_infixly v = sep [v, pp_expr]--ppr_expr (ExplicitTuple _ exprs boxity)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Unit x`, not `(x)`-  | [dL -> L _ (Present _ expr)] <- exprs-  , Boxed <- boxity-  = hsep [text (mkTupleStr Boxed 1), ppr expr]-  | otherwise-  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))-  where-    ppr_tup_args []               = []-    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es-    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es-    ppr_tup_args (XTupArg x   : es) = (ppr x <> punc es) : ppr_tup_args es--    punc (Present {} : _) = comma <> space-    punc (Missing {} : _) = comma-    punc (XTupArg {} : _) = comma <> space-    punc []               = empty--ppr_expr (ExplicitSum _ alt arity expr)-  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"-  where-    ppr_bars n = hsep (replicate n (char '|'))--ppr_expr (HsLam _ matches)-  = pprMatches matches--ppr_expr (HsLamCase _ matches)-  = sep [ sep [text "\\case"],-          nest 2 (pprMatches matches) ]--ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],-          nest 2 (pprMatches matches) <+> char '}']-ppr_expr (HsCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],-          nest 2 (pprMatches matches) ]--ppr_expr (HsIf _ _ e1 e2 e3)-  = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],-         nest 4 (ppr e2),-         text "else",-         nest 4 (ppr e3)]--ppr_expr (HsMultiIf _ alts)-  = hang (text "if") 3  (vcat (map ppr_alt alts))-  where ppr_alt (L _ (GRHS _ guards expr)) =-          hang vbar 2 (ppr_one one_alt)-          where-            ppr_one [] = panic "ppr_exp HsMultiIf"-            ppr_one (h:t) = hang h 2 (sep t)-            one_alt = [ interpp'SP guards-                      , text "->" <+> pprDeeper (ppr expr) ]-        ppr_alt (L _ (XGRHS x)) = ppr x---- special case: let ... in let ...-ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),-         ppr_lexpr expr]--ppr_expr (HsLet _ (L _ binds) expr)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr expr)]--ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts--ppr_expr (ExplicitList _ _ exprs)-  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))--ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })-  = hang (ppr con_id) 2 (ppr rbinds)--ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })-  = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))--ppr_expr (ExprWithTySig _ expr sig)-  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)-         4 (ppr sig)--ppr_expr (ArithSeq _ _ info) = brackets (ppr info)--ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr)-  = sep [ pprWithSourceText st (text "{-# SCC")-         -- no doublequotes if stl empty, for the case where the SCC was written-         -- without quotes.-          <+> pprWithSourceText stl (ftext lbl) <+> text "#-}",-          ppr expr ]--ppr_expr (HsWrap _ co_fn e)-  = pprHsWrapper co_fn (\parens -> if parens then pprExpr e-                                             else pprExpr e)--ppr_expr (HsSpliceE _ s)         = pprSplice s-ppr_expr (HsBracket _ b)         = pprHsBracket b-ppr_expr (HsRnBracketOut _ e []) = ppr e-ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps-ppr_expr (HsTcBracketOut _ e []) = ppr e-ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps--ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]-ppr_expr (HsProc _ pat (L _ (XCmdTop x)))-  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x]--ppr_expr (HsStatic _ e)-  = hsep [text "static", ppr e]--ppr_expr (HsTick _ tickish exp)-  = pprTicks (ppr exp) $-    ppr tickish <+> ppr_lexpr exp-ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)-  = pprTicks (ppr exp) $-    hcat [text "bintick<",-          ppr tickIdTrue,-          text ",",-          ppr tickIdFalse,-          text ">(",-          ppr exp, text ")"]-ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp)-  = pprTicks (ppr exp) $-    hcat [text "tickpragma<",-          pprExternalSrcLoc externalSrcLoc,-          text ">(",-          ppr exp,-          text ")"]--ppr_expr (HsRecFld _ f) = ppr f-ppr_expr (XExpr x) = ppr x--ppr_infix_expr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc-ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)-ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))-ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)-ppr_infix_expr (HsUnboundVar _ h@TrueExprHole{}) = Just (pprInfixOcc (unboundVarOcc h))-ppr_infix_expr (HsWrap _ _ e)       = ppr_infix_expr e-ppr_infix_expr _                    = Nothing--ppr_apps :: (OutputableBndrId p)-         => HsExpr (GhcPass p)-         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]-         -> SDoc-ppr_apps (HsApp _ (L _ fun) arg)        args-  = ppr_apps fun (Left arg : args)-ppr_apps (HsAppType _ (L _ fun) arg)    args-  = ppr_apps fun (Right arg : args)-ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))-  where-    pp (Left arg)                             = ppr arg-    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))-    --   = char '@' <> pprHsType arg-    pp (Right arg)-      = char '@' <> ppr arg--pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc-pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))-  = ppr (src,(n1,n2),(n3,n4))--{--HsSyn records exactly where the user put parens, with HsPar.-So generally speaking we print without adding any parens.-However, some code is internally generated, and in some places-parens are absolutely required; so for these places we use-pprParendLExpr (but don't print double parens of course).--For operator applications we don't add parens, because the operator-fixities should do the job, except in debug mode (-dppr-debug) so we-can see the structure of the parse tree.--}--pprDebugParendExpr :: (OutputableBndrId p)-                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprDebugParendExpr p expr-  = getPprStyle (\sty ->-    if debugStyle sty then pprParendLExpr p expr-                      else pprLExpr      expr)--pprParendLExpr :: (OutputableBndrId p)-               => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprParendLExpr p (L _ e) = pprParendExpr p e--pprParendExpr :: (OutputableBndrId p)-              => PprPrec -> HsExpr (GhcPass p) -> SDoc-pprParendExpr p expr-  | hsExprNeedsParens p expr = parens (pprExpr expr)-  | otherwise                = pprExpr expr-        -- Using pprLExpr makes sure that we go 'deeper'-        -- I think that is usually (always?) right---- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs--- parentheses under precedence @p@.-hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool-hsExprNeedsParens p = go-  where-    go (HsVar{})                      = False-    go (HsUnboundVar{})               = False-    go (HsConLikeOut{})               = False-    go (HsIPVar{})                    = False-    go (HsOverLabel{})                = False-    go (HsLit _ l)                    = hsLitNeedsParens p l-    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol-    go (HsPar{})                      = False-    go (HsCoreAnn _ _ _ (L _ e))      = go e-    go (HsApp{})                      = p >= appPrec-    go (HsAppType {})                 = p >= appPrec-    go (OpApp{})                      = p >= opPrec-    go (NegApp{})                     = p > topPrec-    go (SectionL{})                   = True-    go (SectionR{})                   = True-    go (ExplicitTuple{})              = False-    go (ExplicitSum{})                = False-    go (HsLam{})                      = p > topPrec-    go (HsLamCase{})                  = p > topPrec-    go (HsCase{})                     = p > topPrec-    go (HsIf{})                       = p > topPrec-    go (HsMultiIf{})                  = p > topPrec-    go (HsLet{})                      = p > topPrec-    go (HsDo _ sc _)-      | isComprehensionContext sc     = False-      | otherwise                     = p > topPrec-    go (ExplicitList{})               = False-    go (RecordUpd{})                  = False-    go (ExprWithTySig{})              = p >= sigPrec-    go (ArithSeq{})                   = False-    go (HsSCC{})                      = p >= appPrec-    go (HsWrap _ _ e)                 = go e-    go (HsSpliceE{})                  = False-    go (HsBracket{})                  = False-    go (HsRnBracketOut{})             = False-    go (HsTcBracketOut{})             = False-    go (HsProc{})                     = p > topPrec-    go (HsStatic{})                   = p >= appPrec-    go (HsTick _ _ (L _ e))           = go e-    go (HsBinTick _ _ _ (L _ e))      = go e-    go (HsTickPragma _ _ _ _ (L _ e)) = go e-    go (RecordCon{})                  = False-    go (HsRecFld{})                   = False-    go (XExpr{})                      = True---- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,--- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.-parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-parenthesizeHsExpr p le@(L loc e)-  | hsExprNeedsParens p e = L loc (HsPar noExtField le)-  | otherwise             = le--isAtomicHsExpr :: HsExpr id -> Bool--- True of a single token-isAtomicHsExpr (HsVar {})        = True-isAtomicHsExpr (HsConLikeOut {}) = True-isAtomicHsExpr (HsLit {})        = True-isAtomicHsExpr (HsOverLit {})    = True-isAtomicHsExpr (HsIPVar {})      = True-isAtomicHsExpr (HsOverLabel {})  = True-isAtomicHsExpr (HsUnboundVar {}) = True-isAtomicHsExpr (HsWrap _ _ e)    = isAtomicHsExpr e-isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)-isAtomicHsExpr (HsRecFld{})      = True-isAtomicHsExpr _                 = False--{--************************************************************************-*                                                                      *-\subsection{Commands (in arrow abstractions)}-*                                                                      *-************************************************************************--We re-use HsExpr to represent these.--}---- | Located Haskell Command (for arrow syntax)-type LHsCmd id = Located (HsCmd id)---- | Haskell Command (e.g. a "statement" in an Arrow proc block)-data HsCmd id-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail',-  --          'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail',-  --          'ApiAnnotation.AnnRarrowtail'--  -- For details on above see note [Api annotations] in ApiAnnotation-  = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)-        (XCmdArrApp id)  -- type of the arrow expressions f,-                         -- of the form a t t', where arg :: t-        (LHsExpr id)     -- arrow expression, f-        (LHsExpr id)     -- input expression, arg-        HsArrAppType     -- higher-order (-<<) or first-order (-<)-        Bool             -- True => right-to-left (f -< arg)-                         -- False => left-to-right (arg >- f)--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@,-  --         'ApiAnnotation.AnnCloseB' @'|)'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)-        (XCmdArrForm id)-        (LHsExpr id)     -- The operator.-                         -- After type-checking, a type abstraction to be-                         -- applied to the type of the local environment tuple-        LexicalFixity    -- Whether the operator appeared prefix or infix when-                         -- parsed.-        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that-                         -- were converted from OpApp's by the renamer-        [LHsCmdTop id]   -- argument commands--  | HsCmdApp    (XCmdApp id)-                (LHsCmd id)-                (LHsExpr id)--  | HsCmdLam    (XCmdLam id)-                (MatchGroup id (LHsCmd id))     -- kappa-       -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',-       --       'ApiAnnotation.AnnRarrow',--       -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdPar    (XCmdPar id)-                (LHsCmd id)                     -- parenthesised command-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,-    --             'ApiAnnotation.AnnClose' @')'@--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdCase   (XCmdCase id)-                (LHsExpr id)-                (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',-    --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,-    --       'ApiAnnotation.AnnClose' @'}'@--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdIf     (XCmdIf id)-                (Maybe (SyntaxExpr id))         -- cond function-                (LHsExpr id)                    -- predicate-                (LHsCmd id)                     -- then part-                (LHsCmd id)                     -- else part-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf',-    --       'ApiAnnotation.AnnSemi',-    --       'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi',-    --       'ApiAnnotation.AnnElse',--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdLet    (XCmdLet id)-                (LHsLocalBinds id)      -- let(rec)-                (LHsCmd  id)-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',-    --       'ApiAnnotation.AnnOpen' @'{'@,-    --       'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression-                (Located [CmdLStmt id])-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',-    --             'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',-    --             'ApiAnnotation.AnnVbar',-    --             'ApiAnnotation.AnnClose'--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsCmdWrap   (XCmdWrap id)-                HsWrapper-                (HsCmd id)     -- If   cmd :: arg1 --> res-                               --      wrap :: arg1 "->" arg2-                               -- Then (HsCmdWrap wrap cmd) :: arg2 --> res-  | XCmd        (XXCmd id)     -- Note [Trees that Grow] extension point--type instance XCmdArrApp  GhcPs = NoExtField-type instance XCmdArrApp  GhcRn = NoExtField-type instance XCmdArrApp  GhcTc = Type--type instance XCmdArrForm (GhcPass _) = NoExtField-type instance XCmdApp     (GhcPass _) = NoExtField-type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = NoExtField-type instance XCmdCase    (GhcPass _) = NoExtField-type instance XCmdIf      (GhcPass _) = NoExtField-type instance XCmdLet     (GhcPass _) = NoExtField--type instance XCmdDo      GhcPs = NoExtField-type instance XCmdDo      GhcRn = NoExtField-type instance XCmdDo      GhcTc = Type--type instance XCmdWrap    (GhcPass _) = NoExtField-type instance XXCmd       (GhcPass _) = NoExtCon---- | Haskell Array Application Type-data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp-  deriving Data---{- | Top-level command, introducing a new arrow.-This may occur inside a proc (where the stack is empty) or as an-argument of a command-forming operator.--}---- | Located Haskell Top-level Command-type LHsCmdTop p = Located (HsCmdTop p)---- | Haskell Top-level Command-data HsCmdTop p-  = HsCmdTop (XCmdTop p)-             (LHsCmd p)-  | XCmdTop (XXCmdTop p)        -- Note [Trees that Grow] extension point--data CmdTopTc-  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack-             Type    -- return type of the command-             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]--type instance XCmdTop  GhcPs = NoExtField-type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]-type instance XCmdTop  GhcTc = CmdTopTc--type instance XXCmdTop (GhcPass _) = NoExtCon--instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where-    ppr cmd = pprCmd cmd---------------------------- pprCmd and pprLCmd call pprDeeper;--- the underscore versions do not-pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-pprLCmd (L _ c) = pprCmd c--pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc-pprCmd c | isQuietHsCmd c =            ppr_cmd c-         | otherwise      = pprDeeper (ppr_cmd c)--isQuietHsCmd :: HsCmd id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsCmd (HsCmdPar {}) = True--- applications don't display anything themselves-isQuietHsCmd (HsCmdApp {}) = True-isQuietHsCmd _ = False--------------------------ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-ppr_lcmd c = ppr_cmd (unLoc c)--ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)--ppr_cmd (HsCmdApp _ c e)-  = let (fun, args) = collect_args c [e] in-    hang (ppr_lcmd fun) 2 (sep (map ppr args))-  where-    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)-    collect_args fun args = (fun, args)--ppr_cmd (HsCmdLam _ matches)-  = pprMatches matches--ppr_cmd (HsCmdCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],-          nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdIf _ _ e ct ce)-  = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],-         nest 4 (ppr ct),-         text "else",-         nest 4 (ppr ce)]---- special case: let ... in let ...-ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),-         ppr_lcmd cmd]--ppr_cmd (HsCmdLet _ (L _ binds) cmd)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr cmd)]--ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts--ppr_cmd (HsCmdWrap _ w cmd)-  = pprHsWrapper w (\_ -> parens (ppr_cmd cmd))-ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)-  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)-  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)-  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)-  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]--ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ op _ _ args)-  = hang (text "(|" <+> ppr_lexpr op)-         4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")-ppr_cmd (XCmd x) = ppr x--pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc-pprCmdArg (HsCmdTop _ cmd)-  = ppr_lcmd cmd-pprCmdArg (XCmdTop x) = ppr x--instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where-    ppr = pprCmdArg--{--************************************************************************-*                                                                      *-\subsection{Record binds}-*                                                                      *-************************************************************************--}---- | Haskell Record Bindings-type HsRecordBinds p = HsRecFields p (LHsExpr p)--{--************************************************************************-*                                                                      *-\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}-*                                                                      *-************************************************************************--@Match@es are sets of pattern bindings and right hand sides for-functions, patterns or case branches. For example, if a function @g@-is defined as:-\begin{verbatim}-g (x,y) = y-g ((x:ys),y) = y+1,-\end{verbatim}-then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.--It is always the case that each element of an @[Match]@ list has the-same number of @pats@s inside it.  This corresponds to saying that-a function defined by pattern matching must have the same number of-patterns in each equation.--}--data MatchGroup p body-  = MG { mg_ext     :: XMG p body -- Post-typechecker, types of args and result-       , mg_alts    :: Located [LMatch p body]  -- The alternatives-       , mg_origin  :: Origin }-     -- The type is the type of the entire group-     --      t1 -> ... -> tn -> tr-     -- where there are n patterns-  | XMatchGroup (XXMatchGroup p body)--data MatchGroupTc-  = MatchGroupTc-       { mg_arg_tys :: [Type]  -- Types of the arguments, t1..tn-       , mg_res_ty  :: Type    -- Type of the result, tr-       } deriving Data--type instance XMG         GhcPs b = NoExtField-type instance XMG         GhcRn b = NoExtField-type instance XMG         GhcTc b = MatchGroupTc--type instance XXMatchGroup (GhcPass _) b = NoExtCon---- | Located Match-type LMatch id body = Located (Match id body)--- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a---   list---- For details on above see note [Api annotations] in ApiAnnotation-data Match p body-  = Match {-        m_ext :: XCMatch p body,-        m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)),-          -- See note [m_ctxt in Match]-        m_pats :: [LPat p], -- The patterns-        m_grhss :: (GRHSs p body)-  }-  | XMatch (XXMatch p body)--type instance XCMatch (GhcPass _) b = NoExtField-type instance XXMatch (GhcPass _) b = NoExtCon--instance (OutputableBndrId pr, Outputable body)-            => Outputable (Match (GhcPass pr) body) where-  ppr = pprMatch--{--Note [m_ctxt in Match]-~~~~~~~~~~~~~~~~~~~~~~--A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and-so on.--In order to simplify tooling processing and pretty print output, the provenance-is captured in an HsMatchContext.--This is particularly important for the API Annotations for a multi-equation-FunBind.--The parser initially creates a FunBind with a single Match in it for-every function definition it sees.--These are then grouped together by getMonoBind into a single FunBind,-where all the Matches are combined.--In the process, all the original FunBind fun_id's bar one are-discarded, including the locations.--This causes a problem for source to source conversions via API-Annotations, so the original fun_ids and infix flags are preserved in-the Match, when it originates from a FunBind.--Example infix function definition requiring individual API Annotations--    (&&&  ) [] [] =  []-    xs    &&&   [] =  xs-    (  &&&  ) [] ys =  ys-----}---isInfixMatch :: Match id body -> Bool-isInfixMatch match = case m_ctxt match of-  FunRhs {mc_fixity = Infix} -> True-  _                          -> False--isEmptyMatchGroup :: MatchGroup id body -> Bool-isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms-isEmptyMatchGroup (XMatchGroup {})      = False---- | Is there only one RHS in this list of matches?-isSingletonMatchGroup :: [LMatch id body] -> Bool-isSingletonMatchGroup matches-  | [L _ match] <- matches-  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match-  = True-  | otherwise-  = False--matchGroupArity :: MatchGroup (GhcPass id) body -> Arity--- Precondition: MatchGroup is non-empty--- This is called before type checking, when mg_arg_tys is not set-matchGroupArity (MG { mg_alts = alts })-  | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)-  | otherwise        = panic "matchGroupArity"-matchGroupArity (XMatchGroup nec) = noExtCon nec--hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]-hsLMatchPats (L _ (Match { m_pats = pats })) = pats-hsLMatchPats (L _ (XMatch nec)) = noExtCon nec---- | Guarded Right-Hand Sides------ GRHSs are used both for pattern bindings and for Matches------  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',---        'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',---        'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose'---        'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi'---- For details on above see note [Api annotations] in ApiAnnotation-data GRHSs p body-  = GRHSs {-      grhssExt :: XCGRHSs p body,-      grhssGRHSs :: [LGRHS p body],      -- ^ Guarded RHSs-      grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause-    }-  | XGRHSs (XXGRHSs p body)--type instance XCGRHSs (GhcPass _) b = NoExtField-type instance XXGRHSs (GhcPass _) b = NoExtCon---- | Located Guarded Right-Hand Side-type LGRHS id body = Located (GRHS id body)---- | Guarded Right Hand Side.-data GRHS p body = GRHS (XCGRHS p body)-                        [GuardLStmt p] -- Guards-                        body           -- Right hand side-                  | XGRHS (XXGRHS p body)--type instance XCGRHS (GhcPass _) b = NoExtField-type instance XXGRHS (GhcPass _) b = NoExtCon---- We know the list must have at least one @Match@ in it.--pprMatches :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc-pprMatches MG { mg_alts = matches }-    = vcat (map pprMatch (map unLoc (unLoc matches)))-      -- Don't print the type; it's only a place-holder before typechecking-pprMatches (XMatchGroup x) = ppr x---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprFunBind :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc-pprFunBind matches = pprMatches matches---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprPatBind :: forall bndr p body. (OutputableBndrId bndr,-                                   OutputableBndrId p,-                                   Outputable body)-           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc-pprPatBind pat (grhss)- = sep [ppr pat,-       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)]--pprMatch :: (OutputableBndrId idR, Outputable body)-         => Match (GhcPass idR) body -> SDoc-pprMatch match-  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)-        , nest 2 (pprGRHSs ctxt (m_grhss match)) ]-  where-    ctxt = m_ctxt match-    (herald, other_pats)-        = case ctxt of-            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}-                | strictness == SrcStrict -> ASSERT(null $ m_pats match)-                                             (char '!'<>pprPrefixOcc fun, m_pats match)-                        -- a strict variable binding-                | fixity == Prefix -> (pprPrefixOcc fun, m_pats match)-                        -- f x y z = e-                        -- Not pprBndr; the AbsBinds will-                        -- have printed the signature--                | null pats2 -> (pp_infix, [])-                        -- x &&& y = e--                | otherwise -> (parens pp_infix, pats2)-                        -- (x &&& y) z = e-                where-                  pp_infix = pprParendLPat opPrec pat1-                         <+> pprInfixOcc fun-                         <+> pprParendLPat opPrec pat2--            LambdaExpr -> (char '\\', m_pats match)--            _  -> if null (m_pats match)-                     then (empty, [])-                     else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 )-                          (ppr pat1, [])        -- No parens around the single pat--    (pat1:pats1) = m_pats match-    (pat2:pats2) = pats1--pprGRHSs :: (OutputableBndrId idR, Outputable body)-         => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc-pprGRHSs ctxt (GRHSs _ grhss (L _ binds))-  = vcat (map (pprGRHS ctxt . unLoc) grhss)-  -- Print the "where" even if the contents of the binds is empty. Only-  -- EmptyLocalBinds means no "where" keyword- $$ ppUnless (eqEmptyLocalBinds binds)-      (text "where" $$ nest 4 (pprBinds binds))-pprGRHSs _ (XGRHSs x) = ppr x--pprGRHS :: (OutputableBndrId idR, Outputable body)-        => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc-pprGRHS ctxt (GRHS _ [] body)- =  pp_rhs ctxt body--pprGRHS ctxt (GRHS _ guards body)- = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]--pprGRHS _ (XGRHS x) = ppr x--pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc-pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)--{--************************************************************************-*                                                                      *-\subsection{Do stmts and list comprehensions}-*                                                                      *-************************************************************************--}---- | Located @do@ block Statement-type LStmt id body = Located (StmtLR id id body)---- | Located Statement with separate Left and Right id's-type LStmtLR idL idR body = Located (StmtLR idL idR body)---- | @do@ block Statement-type Stmt id body = StmtLR id id body---- | Command Located Statement-type CmdLStmt   id = LStmt id (LHsCmd  id)---- | Command Statement-type CmdStmt    id = Stmt  id (LHsCmd  id)---- | Expression Located Statement-type ExprLStmt  id = LStmt id (LHsExpr id)---- | Expression Statement-type ExprStmt   id = Stmt  id (LHsExpr id)---- | Guard Located Statement-type GuardLStmt id = LStmt id (LHsExpr id)---- | Guard Statement-type GuardStmt  id = Stmt  id (LHsExpr id)---- | Ghci Located Statement-type GhciLStmt  id = LStmt id (LHsExpr id)---- | Ghci Statement-type GhciStmt   id = Stmt  id (LHsExpr id)---- The SyntaxExprs in here are used *only* for do-notation and monad--- comprehensions, which have rebindable syntax. Otherwise they are unused.--- | API Annotations when in qualifier lists or guards---  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar',---         'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen',---         'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy',---         'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing'---- For details on above see note [Api annotations] in ApiAnnotation-data StmtLR idL idR body -- body should always be (LHs**** idR)-  = LastStmt  -- Always the last Stmt in ListComp, MonadComp,-              -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr-              -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff-          (XLastStmt idL idR body)-          body-          Bool               -- True <=> return was stripped by ApplicativeDo-          (SyntaxExpr idR)   -- The return operator-            -- The return operator is used only for MonadComp-            -- For ListComp we use the baked-in 'return'-            -- For DoExpr, MDoExpr, we don't apply a 'return' at all-            -- See Note [Monad Comprehensions]-            -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | BindStmt (XBindStmt idL idR body) -- Post typechecking,-                                -- result type of the function passed to bind;-                                -- that is, S in (>>=) :: Q -> (R -> S) -> T-             (LPat idL)-             body-             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]-             (SyntaxExpr idR) -- The fail operator-             -- The fail operator is noSyntaxExpr-             -- if the pattern match can't fail--  -- | 'ApplicativeStmt' represents an applicative expression built with-  -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the-  -- appropriate applicative expression by the desugarer, but it is intended-  -- to be invisible in error messages.-  ---  -- For full details, see Note [ApplicativeDo] in RnExpr-  ---  | ApplicativeStmt-             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body-             [ ( SyntaxExpr idR-               , ApplicativeArg idL) ]-                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]-             (Maybe (SyntaxExpr idR))  -- 'join', if necessary--  | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type-                                      -- of the RHS (used for arrows)-             body              -- See Note [BodyStmt]-             (SyntaxExpr idR)  -- The (>>) operator-             (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp-                               -- See notes [Monad Comprehensions]--  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet'-  --          'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@,--  -- For details on above see note [Api annotations] in ApiAnnotation-  | LetStmt  (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)--  -- ParStmts only occur in a list/monad comprehension-  | ParStmt  (XParStmt idL idR body)    -- Post typecheck,-                                        -- S in (>>=) :: Q -> (R -> S) -> T-             [ParStmtBlock idL idR]-             (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions-             (SyntaxExpr idR)           -- The `>>=` operator-                                        -- See notes [Monad Comprehensions]-            -- After renaming, the ids are the binders-            -- bound by the stmts and used after themp--  | TransStmt {-      trS_ext   :: XTransStmt idL idR body, -- Post typecheck,-                                            -- R in (>>=) :: Q -> (R -> S) -> T-      trS_form  :: TransForm,-      trS_stmts :: [ExprLStmt idL],   -- Stmts to the *left* of the 'group'-                                      -- which generates the tuples to be grouped--      trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map]--      trS_using :: LHsExpr idR,-      trS_by :: Maybe (LHsExpr idR),  -- "by e" (optional)-        -- Invariant: if trS_form = GroupBy, then grp_by = Just e--      trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for-                                      -- the inner monad comprehensions-      trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator-      trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring-                                      -- Only for 'group' forms-                                      -- Just a simple HsExpr, because it's-                                      -- too polymorphic for tcSyntaxOp-    }                                 -- See Note [Monad Comprehensions]--  -- Recursive statement (see Note [How RecStmt works] below)-  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | RecStmt-     { recS_ext :: XRecStmt idL idR body-     , recS_stmts :: [LStmtLR idL idR body]--        -- The next two fields are only valid after renaming-     , recS_later_ids :: [IdP idR]-                         -- The ids are a subset of the variables bound by the-                         -- stmts that are used in stmts that follow the RecStmt--     , recS_rec_ids :: [IdP idR]-                         -- Ditto, but these variables are the "recursive" ones,-                         -- that are used before they are bound in the stmts of-                         -- the RecStmt.-        -- An Id can be in both groups-        -- Both sets of Ids are (now) treated monomorphically-        -- See Note [How RecStmt works] for why they are separate--        -- Rebindable syntax-     , recS_bind_fn :: SyntaxExpr idR -- The bind function-     , recS_ret_fn  :: SyntaxExpr idR -- The return function-     , recS_mfix_fn :: SyntaxExpr idR -- The mfix function-      }-  | XStmtLR (XXStmtLR idL idR body)---- Extra fields available post typechecking for RecStmt.-data RecStmtTc =-  RecStmtTc-     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T-     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)-     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1-                                  -- with recS_later_ids and recS_rec_ids,-                                  -- and are the expressions that should be-                                  -- returned by the recursion.-                                  -- They may not quite be the Ids themselves,-                                  -- because the Id may be *polymorphic*, but-                                  -- the returned thing has to be *monomorphic*,-                                  -- so they may be type applications--      , recS_ret_ty :: Type        -- The type of-                                   -- do { stmts; return (a,b,c) }-                                   -- With rebindable syntax the type might not-                                   -- be quite as simple as (m (tya, tyb, tyc)).-      }---type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField--type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBindStmt        (GhcPass _) GhcRn b = NoExtField-type instance XBindStmt        (GhcPass _) GhcTc b = Type--type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcTc b = Type--type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcTc b = Type--type instance XLetStmt         (GhcPass _) (GhcPass _) b = NoExtField--type instance XParStmt         (GhcPass _) GhcPs b = NoExtField-type instance XParStmt         (GhcPass _) GhcRn b = NoExtField-type instance XParStmt         (GhcPass _) GhcTc b = Type--type instance XTransStmt       (GhcPass _) GhcPs b = NoExtField-type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField-type instance XTransStmt       (GhcPass _) GhcTc b = Type--type instance XRecStmt         (GhcPass _) GhcPs b = NoExtField-type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField-type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc--type instance XXStmtLR         (GhcPass _) (GhcPass _) b = NoExtCon--data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function-  = ThenForm     -- then f               or    then f by e             (depending on trS_by)-  | GroupForm    -- then group using f   or    then group by e using f (depending on trS_by)-  deriving Data---- | Parenthesised Statement Block-data ParStmtBlock idL idR-  = ParStmtBlock-        (XParStmtBlock idL idR)-        [ExprLStmt idL]-        [IdP idR]          -- The variables to be returned-        (SyntaxExpr idR)   -- The return operator-  | XParStmtBlock (XXParStmtBlock idL idR)--type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon---- | Applicative Argument-data ApplicativeArg idL-  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)-    { xarg_app_arg_one  :: (XApplicativeArgOne idL)-    , app_arg_pattern   :: (LPat idL) -- WildPat if it was a BodyStmt (see below)-    , arg_expr          :: (LHsExpr idL)-    , is_body_stmt      :: Bool -- True <=> was a BodyStmt-                              -- False <=> was a BindStmt-                              -- See Note [Applicative BodyStmt]-    , fail_operator     :: (SyntaxExpr idL) -- The fail operator-                         -- The fail operator is needed if this is a BindStmt-                         -- where the pattern can fail. E.g.:-                         -- (Just a) <- stmt-                         -- The fail operator will be invoked if the pattern-                         -- match fails.-                         -- The fail operator is noSyntaxExpr-                         -- if the pattern match can't fail-    }-  | ApplicativeArgMany     -- do { stmts; return vars }-    { xarg_app_arg_many :: (XApplicativeArgMany idL)-    , app_stmts         :: [ExprLStmt idL] -- stmts-    , final_expr        :: (HsExpr idL)    -- return (v1,..,vn), or just (v1,..,vn)-    , bv_pattern        :: (LPat idL)      -- (v1,...,vn)-    }-  | XApplicativeArg (XXApplicativeArg idL)--type instance XApplicativeArgOne  (GhcPass _) = NoExtField-type instance XApplicativeArgMany (GhcPass _) = NoExtField-type instance XXApplicativeArg    (GhcPass _) = NoExtCon--{--Note [The type of bind in Stmts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some Stmts, notably BindStmt, keep the (>>=) bind operator.-We do NOT assume that it has type-    (>>=) :: m a -> (a -> m b) -> m b-In some cases (see #303, #1537) it might have a more-exotic type, such as-    (>>=) :: m i j a -> (a -> m j k b) -> m i k b-So we must be careful not to make assumptions about the type.-In particular, the monad may not be uniform throughout.--Note [TransStmt binder map]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The [(idR,idR)] in a TransStmt behaves as follows:--  * Before renaming: []--  * After renaming:-          [ (x27,x27), ..., (z35,z35) ]-    These are the variables-       bound by the stmts to the left of the 'group'-       and used either in the 'by' clause,-                or     in the stmts following the 'group'-    Each item is a pair of identical variables.--  * After typechecking:-          [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]-    Each pair has the same unique, but different *types*.--Note [BodyStmt]-~~~~~~~~~~~~~~~-BodyStmts are a bit tricky, because what they mean-depends on the context.  Consider the following contexts:--        A do expression of type (m res_ty)-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E any_ty:   do { ....; E; ... }-                E :: m any_ty-          Translation: E >> ...--        A list comprehensions of type [elt_ty]-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E Bool:   [ .. | .... E ]-                        [ .. | ..., E, ... ]-                        [ .. | .... | ..., E | ... ]-                E :: Bool-          Translation: if E then fail else ...--        A guard list, guarding a RHS of type rhs_ty-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E BooParStmtBlockl:   f x | ..., E, ... = ...rhs...-                E :: Bool-          Translation: if E then fail else ...--        A monad comprehension of type (m res_ty)-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E Bool:   [ .. | .... E ]-                E :: Bool-          Translation: guard E >> ...--Array comprehensions are handled like list comprehensions.--Note [How RecStmt works]-~~~~~~~~~~~~~~~~~~~~~~~~-Example:-   HsDo [ BindStmt x ex--        , RecStmt { recS_rec_ids   = [a, c]-                  , recS_stmts     = [ BindStmt b (return (a,c))-                                     , LetStmt a = ...b...-                                     , BindStmt c ec ]-                  , recS_later_ids = [a, b]--        , return (a b) ]--Here, the RecStmt binds a,b,c; but-  - Only a,b are used in the stmts *following* the RecStmt,-  - Only a,c are used in the stmts *inside* the RecStmt-        *before* their bindings--Why do we need *both* rec_ids and later_ids?  For monads they could be-combined into a single set of variables, but not for arrows.  That-follows from the types of the respective feedback operators:--        mfix :: MonadFix m => (a -> m a) -> m a-        loop :: ArrowLoop a => a (b,d) (c,d) -> a b c--* For mfix, the 'a' covers the union of the later_ids and the rec_ids-* For 'loop', 'c' is the later_ids and 'd' is the rec_ids--Note [Typing a RecStmt]-~~~~~~~~~~~~~~~~~~~~~~~-A (RecStmt stmts) types as if you had written--  (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->-                                 do { stmts-                                    ; return (v1,..vn, r1, ..., rm) })--where v1..vn are the later_ids-      r1..rm are the rec_ids--Note [Monad Comprehensions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Monad comprehensions require separate functions like 'return' and-'>>=' for desugaring. These functions are stored in the statements-used in monad comprehensions. For example, the 'return' of the 'LastStmt'-expression is used to lift the body of the monad comprehension:--  [ body | stmts ]-   =>-  stmts >>= \bndrs -> return body--In transform and grouping statements ('then ..' and 'then group ..') the-'return' function is required for nested monad comprehensions, for example:--  [ body | stmts, then f, rest ]-   =>-  f [ env | stmts ] >>= \bndrs -> [ body | rest ]--BodyStmts require the 'Control.Monad.guard' function for boolean-expressions:--  [ body | exp, stmts ]-   =>-  guard exp >> [ body | stmts ]--Parallel statements require the 'Control.Monad.Zip.mzip' function:--  [ body | stmts1 | stmts2 | .. ]-   =>-  mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body--In any other context than 'MonadComp', the fields for most of these-'SyntaxExpr's stay bottom.---Note [Applicative BodyStmt]--(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt-as if it was a BindStmt with a wildcard pattern.  For example,--  do-    x <- A-    B-    return x--is transformed as if it were--  do-    x <- A-    _ <- B-    return x--so it transforms to--  (\(x,_) -> x) <$> A <*> B--But we have to remember when we treat a BodyStmt like a BindStmt,-because in error messages we want to emit the original syntax the user-wrote, not our internal representation.  So ApplicativeArgOne has a-Bool flag that is True when the original statement was a BodyStmt, so-that we can pretty-print it correctly.--}--instance (Outputable (StmtLR idL idL (LHsExpr idL)),-          Outputable (XXParStmtBlock idL idR))-        => Outputable (ParStmtBlock idL idR) where-  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts-  ppr (XParStmtBlock x)          = ppr x--instance (OutputableBndrId pl, OutputableBndrId pr,-          Outputable body)-         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where-    ppr stmt = pprStmt stmt--pprStmt :: forall idL idR body . (OutputableBndrId idL,-                                  OutputableBndrId idR,-                                  Outputable body)-        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc-pprStmt (LastStmt _ expr ret_stripped _)-  = whenPprDebug (text "[last]") <+>-       (if ret_stripped then text "return" else empty) <+>-       ppr expr-pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr]-pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds]-pprStmt (BodyStmt _ expr _ _)     = ppr expr-pprStmt (ParStmt _ stmtss _ _)   = sep (punctuate (text " | ") (map ppr stmtss))--pprStmt (TransStmt { trS_stmts = stmts, trS_by = by-                   , trS_using = using, trS_form = form })-  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])--pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids-                 , recS_later_ids = later_ids })-  = text "rec" <+>-    vcat [ ppr_do_stmts segment-         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids-                            , text "later_ids=" <> ppr later_ids])]--pprStmt (ApplicativeStmt _ args mb_join)-  = getPprStyle $ \style ->-      if userStyle style-         then pp_for_user-         else pp_debug-  where-  -- make all the Applicative stuff invisible in error messages by-  -- flattening the whole ApplicativeStmt nest back to a sequence-  -- of statements.-   pp_for_user = vcat $ concatMap flattenArg args--   -- ppr directly rather than transforming here, because we need to-   -- inject a "return" which is hard when we're polymorphic in the id-   -- type.-   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]-   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args-   flattenStmt stmt = [ppr stmt]--   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]-   flattenArg (_, ApplicativeArgOne _ pat expr isBody _)-     | isBody =  -- See Note [Applicative BodyStmt]-     [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr-             :: ExprStmt (GhcPass idL))]-     | otherwise =-     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr-             :: ExprStmt (GhcPass idL))]-   flattenArg (_, ApplicativeArgMany _ stmts _ _) =-     concatMap flattenStmt stmts-   flattenArg (_, XApplicativeArg nec) = noExtCon nec--   pp_debug =-     let-         ap_expr = sep (punctuate (text " |") (map pp_arg args))-     in-       if isNothing mb_join-          then ap_expr-          else text "join" <+> parens ap_expr--   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc-   pp_arg (_, applicativeArg) = ppr applicativeArg--pprStmt (XStmtLR x) = ppr x---instance (OutputableBndrId idL)-      => Outputable (ApplicativeArg (GhcPass idL)) where-  ppr = pprArg--pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc-pprArg (ApplicativeArgOne _ pat expr isBody _)-  | isBody =  -- See Note [Applicative BodyStmt]-    ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr-            :: ExprStmt (GhcPass idL))-  | otherwise =-    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr-            :: ExprStmt (GhcPass idL))-pprArg (ApplicativeArgMany _ stmts return pat) =-     ppr pat <+>-     text "<-" <+>-     ppr (HsDo (panic "pprStmt") DoExpr (noLoc-               (stmts ++-                   [noLoc (LastStmt noExtField (noLoc return) False noSyntaxExpr)])))-pprArg (XApplicativeArg x) = ppr x--pprTransformStmt :: (OutputableBndrId p)-                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)-                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc-pprTransformStmt bndrs using by-  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))-        , nest 2 (ppr using)-        , nest 2 (pprBy by)]--pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc-pprTransStmt by using ThenForm-  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]-pprTransStmt by using GroupForm-  = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]--pprBy :: Outputable body => Maybe body -> SDoc-pprBy Nothing  = empty-pprBy (Just e) = text "by" <+> ppr e--pprDo :: (OutputableBndrId p, Outputable body)-      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc-pprDo DoExpr        stmts = text "do"  <+> ppr_do_stmts stmts-pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts-pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts-pprDo MDoExpr       stmts = text "mdo" <+> ppr_do_stmts stmts-pprDo ListComp      stmts = brackets    $ pprComp stmts-pprDo MonadComp     stmts = brackets    $ pprComp stmts-pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt--ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,-                 Outputable body)-             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc--- Print a bunch of do stmts-ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)--pprComp :: (OutputableBndrId p, Outputable body)-        => [LStmt (GhcPass p) body] -> SDoc-pprComp quals     -- Prints:  body | qual1, ..., qualn-  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals-  = if null initStmts-       -- If there are no statements in a list comprehension besides the last-       -- one, we simply treat it like a normal list. This does arise-       -- occasionally in code that GHC generates, e.g., in implementations of-       -- 'range' for derived 'Ix' instances for product datatypes with exactly-       -- one constructor (e.g., see #12583).-       then ppr body-       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)-  | otherwise-  = pprPanic "pprComp" (pprQuals quals)--pprQuals :: (OutputableBndrId p, Outputable body)-         => [LStmt (GhcPass p) body] -> SDoc--- Show list comprehension qualifiers separated by commas-pprQuals quals = interpp'SP quals--{--************************************************************************-*                                                                      *-                Template Haskell quotation brackets-*                                                                      *-************************************************************************--}---- | Haskell Splice-data HsSplice id-   = HsTypedSplice       --  $$z  or $$(f 4)-        (XTypedSplice id)-        SpliceDecoration -- Whether $$( ) variant found, for pretty printing-        (IdP id)         -- A unique name to identify this splice point-        (LHsExpr id)     -- See Note [Pending Splices]--   | HsUntypedSplice     --  $z  or $(f 4)-        (XUntypedSplice id)-        SpliceDecoration -- Whether $( ) variant found, for pretty printing-        (IdP id)         -- A unique name to identify this splice point-        (LHsExpr id)     -- See Note [Pending Splices]--   | HsQuasiQuote        -- See Note [Quasi-quote overview] in TcSplice-        (XQuasiQuote id)-        (IdP id)         -- Splice point-        (IdP id)         -- Quoter-        SrcSpan          -- The span of the enclosed string-        FastString       -- The enclosed string--   -- AZ:TODO: use XSplice instead of HsSpliced-   | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in-                -- RnSplice.-                -- This is the result of splicing a splice. It is produced by-                -- the renamer and consumed by the typechecker. It lives only-                -- between the two.-        (XSpliced id)-        ThModFinalizers     -- TH finalizers produced by the splice.-        (HsSplicedThing id) -- The result of splicing-   | HsSplicedT-      DelayedSplice-   | XSplice (XXSplice id)  -- Note [Trees that Grow] extension point--type instance XTypedSplice   (GhcPass _) = NoExtField-type instance XUntypedSplice (GhcPass _) = NoExtField-type instance XQuasiQuote    (GhcPass _) = NoExtField-type instance XSpliced       (GhcPass _) = NoExtField-type instance XXSplice       (GhcPass _) = NoExtCon---- | A splice can appear with various decorations wrapped around it. This data--- type captures explicitly how it was originally written, for use in the pretty--- printer.-data SpliceDecoration-  = HasParens -- ^ $( splice ) or $$( splice )-  | HasDollar -- ^ $splice or $$splice-  | NoParens  -- ^ bare splice-  deriving (Data, Eq, Show)--instance Outputable SpliceDecoration where-  ppr x = text $ show x---isTypedSplice :: HsSplice id -> Bool-isTypedSplice (HsTypedSplice {}) = True-isTypedSplice _                  = False   -- Quasi-quotes are untyped splices---- | Finalizers produced by a splice with--- 'Language.Haskell.TH.Syntax.addModFinalizer'------ See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how--- this is used.----newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]---- A Data instance which ignores the argument of 'ThModFinalizers'.-instance Data ThModFinalizers where-  gunfold _ z _ = z $ ThModFinalizers []-  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]---- See Note [Running typed splices in the zonker]--- These are the arguments that are passed to `TcSplice.runTopSplice`-data DelayedSplice =-  DelayedSplice-    TcLclEnv          -- The local environment to run the splice in-    (LHsExpr GhcRn)   -- The original renamed expression-    TcType            -- The result type of running the splice, unzonked-    (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result---- A Data instance which ignores the argument of 'DelayedSplice'.-instance Data DelayedSplice where-  gunfold _ _ _ = panic "DelayedSplice"-  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]---- | Haskell Spliced Thing------ Values that can result from running a splice.-data HsSplicedThing id-    = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression-    | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type-    | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern----- See Note [Pending Splices]-type SplicePointName = Name---- | Pending Renamer Splice-data PendingRnSplice-  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)--data UntypedSpliceFlavour-  = UntypedExpSplice-  | UntypedPatSplice-  | UntypedTypeSplice-  | UntypedDeclSplice-  deriving Data---- | Pending Type-checker Splice-data PendingTcSplice-  = PendingTcSplice SplicePointName (LHsExpr GhcTc)--{--Note [Pending Splices]-~~~~~~~~~~~~~~~~~~~~~~-When we rename an untyped bracket, 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.  So for example-    [| f $(g x) |]-looks like--    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))--which the renamer rewrites to--    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))-                   [PendingRnSplice UntypedExpSplice sn (g x)]--* The 'sn' is the Name of the splice point, the SplicePointName--* The PendingRnExpSplice gives the splice that splice-point name maps to;-  and the typechecker can now conveniently find these sub-expressions--* The other copy of the splice, in the second argument of HsSpliceE-                                in the renamed first arg of HsRnBracketOut-  is used only for pretty printing--There are four varieties of pending splices generated by the renamer,-distinguished by their UntypedSpliceFlavour-- * Pending expression splices (UntypedExpSplice), e.g.,-       [|$(f x) + 2|]--   UntypedExpSplice is also used for-     * quasi-quotes, where the pending expression expands to-          $(quoter "...blah...")-       (see RnSplice.makePending, HsQuasiQuote case)--     * cross-stage lifting, where the pending expression expands to-          $(lift x)-       (see RnSplice.checkCrossStageLifting)-- * Pending pattern splices (UntypedPatSplice), e.g.,-       [| \$(f x) -> x |]-- * Pending type splices (UntypedTypeSplice), e.g.,-       [| f :: $(g x) |]-- * Pending declaration (UntypedDeclSplice), e.g.,-       [| let $(f x) in ... |]--There is a fifth variety of pending splice, which is generated by the type-checker:--  * Pending *typed* expression splices, (PendingTcSplice), e.g.,-        [||1 + $$(f 2)||]--It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the-output of the renamer. However, when pretty printing the output of the renamer,-e.g., in a type error message, we *do not* want to print out the pending-splices. In contrast, when pretty printing the output of the type checker, we-*do* want to print the pending splices. So splitting them up seems to make-sense, although I hate to add another constructor to HsExpr.--}--instance OutputableBndrId p-       => Outputable (HsSplicedThing (GhcPass p)) where-  ppr (HsSplicedExpr e) = ppr_expr e-  ppr (HsSplicedTy   t) = ppr t-  ppr (HsSplicedPat  p) = ppr p--instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where-  ppr s = pprSplice s--pprPendingSplice :: (OutputableBndrId p)-                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e)--pprSpliceDecl ::  (OutputableBndrId p)-          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc-pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e-pprSpliceDecl e ExplicitSplice   = text "$(" <> ppr_splice_decl e <> text ")"-pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e--ppr_splice_decl :: (OutputableBndrId p)-                => HsSplice (GhcPass p) -> SDoc-ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty-ppr_splice_decl e = pprSplice e--pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc-pprSplice (HsTypedSplice _ HasParens  n e)-  = ppr_splice (text "$$(") n e (text ")")-pprSplice (HsTypedSplice _ HasDollar n e)-  = ppr_splice (text "$$") n e empty-pprSplice (HsTypedSplice _ NoParens n e)-  = ppr_splice empty n e empty-pprSplice (HsUntypedSplice _ HasParens  n e)-  = ppr_splice (text "$(") n e (text ")")-pprSplice (HsUntypedSplice _ HasDollar n e)-  = ppr_splice (text "$")  n e empty-pprSplice (HsUntypedSplice _ NoParens n e)-  = ppr_splice empty  n e empty-pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s-pprSplice (HsSpliced _ _ thing)         = ppr thing-pprSplice (HsSplicedT {})               = text "Unevaluated typed splice"-pprSplice (XSplice x)                   = ppr x--ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc-ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>-                           char '[' <> ppr quoter <> vbar <>-                           ppr quote <> text "|]"--ppr_splice :: (OutputableBndrId p)-           => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc-ppr_splice herald n e trail-    = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail---- | Haskell Bracket-data HsBracket p-  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]-  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]-  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser-  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer-  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]-  | VarBr  (XVarBr p)   Bool (IdP p)  -- True: 'x, False: ''T-                                -- (The Bool flag is used only in pprHsBracket)-  | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]-  | XBracket (XXBracket p)            -- Note [Trees that Grow] extension point--type instance XExpBr      (GhcPass _) = NoExtField-type instance XPatBr      (GhcPass _) = NoExtField-type instance XDecBrL     (GhcPass _) = NoExtField-type instance XDecBrG     (GhcPass _) = NoExtField-type instance XTypBr      (GhcPass _) = NoExtField-type instance XVarBr      (GhcPass _) = NoExtField-type instance XTExpBr     (GhcPass _) = NoExtField-type instance XXBracket   (GhcPass _) = NoExtCon--isTypedBracket :: HsBracket id -> Bool-isTypedBracket (TExpBr {}) = True-isTypedBracket _           = False--instance OutputableBndrId p-          => Outputable (HsBracket (GhcPass p)) where-  ppr = pprHsBracket---pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc-pprHsBracket (ExpBr _ e)   = thBrackets empty (ppr e)-pprHsBracket (PatBr _ p)   = thBrackets (char 'p') (ppr p)-pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)-pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))-pprHsBracket (TypBr _ t)   = thBrackets (char 't') (ppr t)-pprHsBracket (VarBr _ True n)-  = char '\'' <> pprPrefixOcc n-pprHsBracket (VarBr _ False n)-  = text "''" <> pprPrefixOcc n-pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)-pprHsBracket (XBracket e)  = ppr e--thBrackets :: SDoc -> SDoc -> SDoc-thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>-                             pp_body <+> text "|]"--thTyBrackets :: SDoc -> SDoc-thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")--instance Outputable PendingRnSplice where-  ppr (PendingRnSplice _ n e) = pprPendingSplice n e--instance Outputable PendingTcSplice where-  ppr (PendingTcSplice n e) = pprPendingSplice n e--{--************************************************************************-*                                                                      *-\subsection{Enumerations and list comprehensions}-*                                                                      *-************************************************************************--}---- | Arithmetic Sequence Information-data ArithSeqInfo id-  = From            (LHsExpr id)-  | FromThen        (LHsExpr id)-                    (LHsExpr id)-  | FromTo          (LHsExpr id)-                    (LHsExpr id)-  | FromThenTo      (LHsExpr id)-                    (LHsExpr id)-                    (LHsExpr id)--- AZ: Sould ArithSeqInfo have a TTG extension?--instance OutputableBndrId p-         => Outputable (ArithSeqInfo (GhcPass p)) where-    ppr (From e1)             = hcat [ppr e1, pp_dotdot]-    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]-    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]-    ppr (FromThenTo e1 e2 e3)-      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]--pp_dotdot :: SDoc-pp_dotdot = text " .. "--{--************************************************************************-*                                                                      *-\subsection{HsMatchCtxt}-*                                                                      *-************************************************************************--}---- | Haskell Match Context------ Context of a pattern match. This is more subtle than it would seem. See Note--- [Varieties of pattern matches].-data HsMatchContext id -- Not an extensible tag-  = FunRhs { mc_fun        :: Located id    -- ^ function binder of @f@-           , mc_fixity     :: LexicalFixity -- ^ fixing of @f@-           , mc_strictness :: SrcStrictness -- ^ was @f@ banged?-                                            -- See Note [FunBind vs PatBind]-           }-                                -- ^A pattern matching on an argument of a-                                -- function binding-  | LambdaExpr                  -- ^Patterns of a lambda-  | CaseAlt                     -- ^Patterns and guards on a case alternative-  | IfAlt                       -- ^Guards of a multi-way if alternative-  | ProcExpr                    -- ^Patterns of a proc-  | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e-  | PatBindGuards               -- ^Guards of pattern bindings, e.g.,-                                --    (Just b) | Just _ <- x = e-                                --             | otherwise   = e'--  | RecUpd                      -- ^Record update [used only in DsExpr to-                                --    tell matchWrapper what sort of-                                --    runtime error message to generate]--  | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension,-                                -- pattern guard, etc--  | ThPatSplice            -- ^A Template Haskell pattern splice-  | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]-  | PatSyn                 -- ^A pattern synonym declaration-  deriving Functor-deriving instance (Data id) => Data (HsMatchContext id)--instance OutputableBndr id => Outputable (HsMatchContext id) where-  ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)-  ppr LambdaExpr            = text "LambdaExpr"-  ppr CaseAlt               = text "CaseAlt"-  ppr IfAlt                 = text "IfAlt"-  ppr ProcExpr              = text "ProcExpr"-  ppr PatBindRhs            = text "PatBindRhs"-  ppr PatBindGuards         = text "PatBindGuards"-  ppr RecUpd                = text "RecUpd"-  ppr (StmtCtxt _)          = text "StmtCtxt _"-  ppr ThPatSplice           = text "ThPatSplice"-  ppr ThPatQuote            = text "ThPatQuote"-  ppr PatSyn                = text "PatSyn"--isPatSynCtxt :: HsMatchContext id -> Bool-isPatSynCtxt ctxt =-  case ctxt of-    PatSyn -> True-    _      -> False---- | Haskell Statement Context. It expects to be parameterised with one of--- 'RdrName', 'Name' or 'Id'-data HsStmtContext id-  = ListComp-  | MonadComp--  | DoExpr                           -- ^do { ... }-  | MDoExpr                          -- ^mdo { ... }  ie recursive do-expression-  | ArrowExpr                        -- ^do-notation in an arrow-command context--  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs-  | PatGuard (HsMatchContext id)     -- ^Pattern guard for specified thing-  | ParStmtCtxt (HsStmtContext id)   -- ^A branch of a parallel stmt-  | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt-  deriving Functor-deriving instance (Data id) => Data (HsStmtContext id)--isComprehensionContext :: HsStmtContext id -> Bool--- Uses comprehension syntax [ e | quals ]-isComprehensionContext ListComp          = True-isComprehensionContext MonadComp         = True-isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c-isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c-isComprehensionContext _ = False---- | Should pattern match failure in a 'HsStmtContext' be desugared using--- 'MonadFail'?-isMonadFailStmtContext :: HsStmtContext id -> Bool-isMonadFailStmtContext MonadComp            = True-isMonadFailStmtContext DoExpr               = True-isMonadFailStmtContext MDoExpr              = True-isMonadFailStmtContext GhciStmtCtxt         = True-isMonadFailStmtContext (ParStmtCtxt ctxt)   = isMonadFailStmtContext ctxt-isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt-isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr--isMonadCompContext :: HsStmtContext id -> Bool-isMonadCompContext MonadComp = True-isMonadCompContext _         = False--matchSeparator :: HsMatchContext id -> SDoc-matchSeparator (FunRhs {})   = text "="-matchSeparator CaseAlt       = text "->"-matchSeparator IfAlt         = text "->"-matchSeparator LambdaExpr    = text "->"-matchSeparator ProcExpr      = text "->"-matchSeparator PatBindRhs    = text "="-matchSeparator PatBindGuards = text "="-matchSeparator (StmtCtxt _)  = text "<-"-matchSeparator RecUpd        = text "=" -- This can be printed by the pattern-                                       -- match checker trace-matchSeparator ThPatSplice  = panic "unused"-matchSeparator ThPatQuote   = panic "unused"-matchSeparator PatSyn       = panic "unused"--pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id)-                => HsMatchContext id -> SDoc-pprMatchContext ctxt-  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt-  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt-  where-    want_an (FunRhs {}) = True  -- Use "an" in front-    want_an ProcExpr    = True-    want_an _           = False--pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id)-                    => HsMatchContext id -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=L _ fun})-                                    = text "equation for"-                                      <+> quotes (ppr fun)-pprMatchContextNoun CaseAlt         = text "case alternative"-pprMatchContextNoun IfAlt           = text "multi-way if alternative"-pprMatchContextNoun RecUpd          = text "record-update construct"-pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"-pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"-pprMatchContextNoun PatBindRhs      = text "pattern binding"-pprMatchContextNoun PatBindGuards   = text "pattern binding guards"-pprMatchContextNoun LambdaExpr      = text "lambda abstraction"-pprMatchContextNoun ProcExpr        = text "arrow abstraction"-pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"-                                      $$ pprAStmtContext ctxt-pprMatchContextNoun PatSyn          = text "pattern synonym declaration"--------------------pprAStmtContext, pprStmtContext :: (Outputable id,-                                    Outputable (NameOrRdrName id))-                                => HsStmtContext id -> SDoc-pprAStmtContext ctxt = article <+> pprStmtContext ctxt-  where-    pp_an = text "an"-    pp_a  = text "a"-    article = case ctxt of-                  MDoExpr       -> pp_an-                  GhciStmtCtxt  -> pp_an-                  _             -> pp_a---------------------pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"-pprStmtContext DoExpr          = text "'do' block"-pprStmtContext MDoExpr         = text "'mdo' block"-pprStmtContext ArrowExpr       = text "'do' block in an arrow command"-pprStmtContext ListComp        = text "list comprehension"-pprStmtContext MonadComp       = text "monad comprehension"-pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt---- Drop the inner contexts when reporting errors, else we get---     Unexpected transform statement---     in a transformed branch of---          transformed branch of---          transformed branch of monad comprehension-pprStmtContext (ParStmtCtxt c) =-  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])-             (pprStmtContext c)-pprStmtContext (TransStmtCtxt c) =-  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])-             (pprStmtContext c)--instance (Outputable (GhcPass p), Outputable (NameOrRdrName (GhcPass p)))-      => Outputable (HsStmtContext (GhcPass p)) where-    ppr = pprStmtContext---- Used to generate the string for a *runtime* error message-matchContextErrString :: Outputable id-                      => HsMatchContext id -> SDoc-matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun-matchContextErrString CaseAlt                    = text "case"-matchContextErrString IfAlt                      = text "multi-way if"-matchContextErrString PatBindRhs                 = text "pattern binding"-matchContextErrString PatBindGuards              = text "pattern binding guards"-matchContextErrString RecUpd                     = text "record update"-matchContextErrString LambdaExpr                 = text "lambda"-matchContextErrString ProcExpr                   = text "proc"-matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"-matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"-matchContextErrString (StmtCtxt DoExpr)            = text "'do' block"-matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"-matchContextErrString (StmtCtxt MDoExpr)           = text "'mdo' block"-matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"-matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"--pprMatchInCtxt :: (OutputableBndrId idR,-                   -- TODO:AZ these constraints do not make sense-                 Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))),-                 Outputable body)-               => Match (GhcPass idR) body -> SDoc-pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)-                                        <> colon)-                             4 (pprMatch match)--pprStmtInCtxt :: (OutputableBndrId idL,-                  OutputableBndrId idR,-                  Outputable body)-              => HsStmtContext (IdP (GhcPass idL))-              -> StmtLR (GhcPass idL) (GhcPass idR) body-              -> SDoc-pprStmtInCtxt ctxt (LastStmt _ e _ _)-  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"-  = hang (text "In the expression:") 2 (ppr e)--pprStmtInCtxt ctxt stmt-  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)-       2 (ppr_stmt stmt)-  where-    -- For Group and Transform Stmts, don't print the nested stmts!-    ppr_stmt (TransStmt { trS_by = by, trS_using = using-                        , trS_form = form }) = pprTransStmt by using form-    ppr_stmt stmt = pprStmt stmt+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Abstract Haskell syntax for expressions.+module GHC.Hs.Expr+  ( module Language.Haskell.Syntax.Expr+  , module GHC.Hs.Expr+  ) where++import Language.Haskell.Syntax.Expr++-- friends:+import GHC.Prelude++import GHC.Hs.Basic() -- import instances+import GHC.Hs.Decls() -- import instances+import GHC.Hs.Pat+import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Basic (FieldLabelString(..))+import GHC.Hs.Extension+import GHC.Hs.Type+import GHC.Hs.Binds+import GHC.Parser.Annotation++-- others:+import GHC.Tc.Types.Evidence+import GHC.Types.Id.Info ( RecSelParent )+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Types.Tickish (CoreTickish)+import GHC.Types.Unique.Set (UniqSet)+import GHC.Types.ThLevelIndex+import GHC.Core.ConLike ( conLikeName, ConLike )+import GHC.Unit.Module (ModuleName)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Core.Type+import GHC.Builtin.Types (mkTupleStr)+import GHC.Tc.Utils.TcType (TcType, TcTyVar)+import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)++import GHCi.RemoteTypes ( ForeignRef )+import qualified GHC.Boot.TH.Syntax as TH (Q)++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))+import qualified Data.Kind+import Data.Maybe (isJust)+import Data.Foldable ( toList )+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Void (Void)+import qualified Data.Set as S+{- *********************************************************************+*                                                                      *+                Expressions proper+*                                                                      *+********************************************************************* -}++-- | Post-Type checking Expression+--+-- PostTcExpr is an evidence expression attached to the syntax tree by the+-- type checker (c.f. postTcType).+type PostTcExpr  = HsExpr GhcTc++-- | Post-Type checking Table+--+-- We use a PostTcTable where there are a bunch of pieces of evidence, more+-- than is convenient to keep individually.+type PostTcTable = [(Name, PostTcExpr)]++-------------------------++-- Defining SyntaxExpr in two stages allows for better type inference, because+-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,+-- noSyntaxExpr would be ambiguous.+type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p++type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where+  SyntaxExprGhc 'Parsed      = NoExtField+  SyntaxExprGhc 'Renamed     = SyntaxExprRn+  SyntaxExprGhc 'Typechecked = SyntaxExprTc++-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].+data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)+    -- Why is the payload not just a Name?+    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+                  | NoSyntaxExprRn++-- | An expression with wrappers, used for rebindable syntax+--+-- This should desugar to+--+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)+-- >                         (syn_arg_wraps[1] arg1) ...+--+-- where the actual arguments come from elsewhere in the AST.+data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc+                                 , syn_arg_wraps :: [HsWrapper]+                                 , syn_res_wrap  :: HsWrapper }+                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]++-- | This is used for rebindable-syntax pieces that are too polymorphic+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)+noExpr :: HsExpr (GhcPass p)+noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))++noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)+                              -- Before renaming, and sometimes after+                              -- See Note [NoSyntaxExpr]+noSyntaxExpr = case ghcPass @p of+  GhcPs -> noExtField+  GhcRn -> NoSyntaxExprRn+  GhcTc -> NoSyntaxExprTc++-- | Make a 'SyntaxExpr GhcRn' from an expression+-- Used only in getMonadFailOp.+-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn+mkSyntaxExpr = SyntaxExprRn++instance Outputable SyntaxExprRn where+  ppr (SyntaxExprRn expr) = ppr expr+  ppr NoSyntaxExprRn      = text "<no syntax expr>"++instance Outputable SyntaxExprTc where+  ppr (SyntaxExprTc { syn_expr      = expr+                    , syn_arg_wraps = arg_wraps+                    , syn_res_wrap  = res_wrap })+    = sdocOption sdocPrintExplicitCoercions $ \print_co ->+      getPprDebug $ \debug ->+      if debug || print_co+      then ppr expr <> braces (pprWithCommas ppr arg_wraps)+                    <> braces (ppr res_wrap)+      else ppr expr++  ppr NoSyntaxExprTc = text "<no syntax expr>"++-- | HsWrap appears only in typechecker output+data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper+                            (hs_syn GhcTc) -- the thing that is wrapped++deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)++-- ---------------------------------------------------------------------++data HsBracketTc = HsBracketTc+  { hsb_quote   :: HsQuote GhcRn        -- See Note [The life cycle of a TH quotation]+  , hsb_ty      :: Type+  , hsb_wrap    :: Maybe QuoteWrapper   -- The wrapper to apply type and dictionary argument to the quote.+  , hsb_splices :: [PendingTcSplice]    -- Output of the type checker is the *original*+                                        -- renamed expression, plus+                                        -- _typechecked_ splices to be+                                        -- pasted back in by the desugarer+  }++type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]")+type instance XTypedBracket GhcRn = NoExtField+type instance XTypedBracket GhcTc = HsBracketTc+type instance XUntypedBracket GhcPs = NoExtField+type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]+                                                        -- Output of the renamer is the *original* renamed expression,+                                                        -- plus _renamed_ splices to be type checked+type instance XUntypedBracket GhcTc = HsBracketTc++data BracketAnn noE hasE+  = BracketNoE noE+  | BracketHasE hasE+  deriving Data++instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where+  noAnn = BracketNoE noAnn++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnHsCase = EpAnnHsCase+      { hsCaseAnnCase :: EpToken "case"+      , hsCaseAnnOf   :: EpToken "of"+      } deriving Data++instance NoAnn EpAnnHsCase where+  noAnn = EpAnnHsCase noAnn noAnn++data EpAnnLam = EpAnnLam+      { epl_lambda :: EpToken "\\"      -- ^ Location of '\' keyword+      , epl_case   :: Maybe EpaLocation -- ^ Location of 'case' or+                                        -- 'cases' keyword, depending+                                        -- on related 'HsLamVariant'.+      } deriving Data++instance NoAnn EpAnnLam where+  noAnn = EpAnnLam noAnn noAnn++-- Record selectors at parse time are HsVar; they convert to HsRecSel+-- on renaming.+type instance XRecSel              GhcPs = DataConCantHappen+type instance XRecSel              GhcRn = NoExtField+type instance XRecSel              GhcTc = NoExtField++-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOverLabel     GhcPs = SourceText+type instance XOverLabel     GhcRn = SourceText+type instance XOverLabel     GhcTc = DataConCantHappen++-- ---------------------------------------------------------------------++type instance XVar           (GhcPass _) = NoExtField++type instance XIPVar         GhcPs = NoExtField+type instance XIPVar         GhcRn = NoExtField+type instance XIPVar         GhcTc = DataConCantHappen+type instance XOverLitE      (GhcPass _) = NoExtField+type instance XLitE          (GhcPass _) = NoExtField+type instance XLam           (GhcPass _) = EpAnnLam+type instance XApp           (GhcPass _) = NoExtField++type instance XAppTypeE      GhcPs = EpToken "@"+type instance XAppTypeE      GhcRn = NoExtField+type instance XAppTypeE      GhcTc = Type++-- OpApp not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOpApp         GhcPs = NoExtField+type instance XOpApp         GhcRn = Fixity+type instance XOpApp         GhcTc = DataConCantHappen++-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XSectionL      GhcPs = NoExtField+type instance XSectionR      GhcPs = NoExtField+type instance XSectionL      GhcRn = NoExtField+type instance XSectionR      GhcRn = NoExtField+type instance XSectionL      GhcTc = DataConCantHappen+type instance XSectionR      GhcTc = DataConCantHappen+++type instance XNegApp        GhcPs = EpToken "-"+type instance XNegApp        GhcRn = NoExtField+type instance XNegApp        GhcTc = NoExtField++type instance XPar           GhcPs = (EpToken "(", EpToken ")")+type instance XPar           GhcRn = NoExtField+type instance XPar           GhcTc = NoExtField++type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation)+type instance XExplicitTuple GhcRn = NoExtField+type instance XExplicitTuple GhcTc = NoExtField++type instance XExplicitSum   GhcPs = AnnExplicitSum+type instance XExplicitSum   GhcRn = NoExtField+type instance XExplicitSum   GhcTc = [Type]++type instance XCase          GhcPs = EpAnnHsCase+type instance XCase          GhcRn = HsMatchContextRn+type instance XCase          GhcTc = HsMatchContextRn++type instance XIf            GhcPs = AnnsIf+type instance XIf            GhcRn = NoExtField+type instance XIf            GhcTc = NoExtField++type instance XMultiIf       GhcPs = (EpToken "if", EpToken "{", EpToken "}")+type instance XMultiIf       GhcRn = NoExtField+type instance XMultiIf       GhcTc = Type++type instance XLet           GhcPs = (EpToken "let", EpToken "in")+type instance XLet           GhcRn = NoExtField+type instance XLet           GhcTc = NoExtField++type instance XDo            GhcPs = AnnList EpaLocation+type instance XDo            GhcRn = NoExtField+type instance XDo            GhcTc = Type++type instance XExplicitList  GhcPs = AnnList ()+type instance XExplicitList  GhcRn = NoExtField+type instance XExplicitList  GhcTc = Type+-- GhcPs: ExplicitList includes all source-level+--   list literals, including overloaded ones+-- GhcRn and GhcTc: ExplicitList used only for list literals+--   that denote Haskell's built-in lists.  Overloaded lists+--   have been expanded away in the renamer+-- See Note [Handling overloaded and rebindable constructs]+-- in  GHC.Rename.Expr++type instance XRecordCon     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordCon     GhcRn = NoExtField+type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function++type instance XRecordUpd     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordUpd     GhcRn = NoExtField+type instance XRecordUpd     GhcTc = DataConCantHappen+  -- We desugar record updates in the typechecker.+  -- See [Handling overloaded and rebindable constructs],+  -- and [Record Updates] in GHC.Tc.Gen.Expr.++-- | Information about the parent of a record update:+--+--  - the parent type constructor or pattern synonym,+--  - the relevant con-likes,+--  - the field labels.+data family HsRecUpdParent x++data instance HsRecUpdParent GhcPs+data instance HsRecUpdParent GhcRn+  = RnRecUpdParent+  { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , rnRecUpdCons   :: UniqSet ConLikeName }+data instance HsRecUpdParent GhcTc+  = TcRecUpdParent+  { tcRecUpdParent :: RecSelParent+  , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , tcRecUpdCons   :: UniqSet ConLike }++type instance XLHsRecUpdLabels GhcPs = NoExtField+type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn)+                                      -- Possible parents for the record update.+type instance XLHsRecUpdLabels GhcTc = DataConCantHappen++type instance XLHsOLRecUpdLabels p = NoExtField++type instance XGetField     GhcPs = NoExtField+type instance XGetField     GhcRn = NoExtField+type instance XGetField     GhcTc = DataConCantHappen+-- HsGetField is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XProjection     GhcPs = AnnProjection+type instance XProjection     GhcRn = NoExtField+type instance XProjection     GhcTc = DataConCantHappen+-- HsProjection is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XExprWithTySig GhcPs = TokDcolon+type instance XExprWithTySig GhcRn = NoExtField+type instance XExprWithTySig GhcTc = NoExtField++type instance XArithSeq      GhcPs = AnnArithSeq+type instance XArithSeq      GhcRn = NoExtField+type instance XArithSeq      GhcTc = PostTcExpr++type instance XProc          (GhcPass _) = (EpToken "proc", TokRarrow)++type instance XStatic        GhcPs = EpToken "static"+type instance XStatic        GhcRn = NameSet+type instance XStatic        GhcTc = (NameSet, Type)+  -- Free variables and type of expression, this is stored for convenience as wiring in+  -- StaticPtr is a bit tricky (see #20150)++type instance XEmbTy         GhcPs = EpToken "type"+type instance XEmbTy         GhcRn = NoExtField+type instance XEmbTy         GhcTc = DataConCantHappen+  -- A free-standing HsEmbTy is an error.+  -- Valid usages are immediately desugared into Type.+++{-+Note [Holes in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note explains how GHC uses the `HsHole` constructor.++`HsHole` is used to represent:++  - anonymous ("_") and named ("_x") holes in expressions,+  - unbound variables,+  - and parse errors.++A `HsHole` can be thought of as any thing which is not necessarily a valid or+fully defined program fragment, but for which a type can be derived.++Note that holes (wildcards) in types, and partial type signatures, are not+handled using the mechanisms described here. Instead, see+Note [The wildcard story for types] for the relevant information.+++* User-facing behavior++  While GHC uses the same internal mechanism to derive the type for any+  `HsHole`, it gives different feedback to the user depending on the type of+  hole. For example, an anonymous hole of the form++    foo x = x && _++  gives the diagnostic++    Foo.hs:5:14: error: [GHC-88464]+      • Found hole: _ :: Bool+      • In the second argument of ‘(&&)’, namely ‘_’+        In the expression: x && _++  while an expression containing an unbound variable++    foo x = x && y++  gives++    Foo.hs:5:14: error: [GHC-88464]+      Variable not in scope: y :: Bool+++* HsHole during parsing, renaming, and type checking++  The usage of `HsHole` during the three phases is listed below.++  - Anynomous holes, i.e. the user wrote "_":++      Parser        HsHole (HoleVar "_")+      Renamer       HsHole (HoleVar "_")+      Typechecker   HsHole (HoleVar "_", ref :: HoleExprRef)++  - Unbound variables and named holes; i.e. the user wrote "x" or "_x", where+    `x` or `_x` is not in scope. A variable with a leading underscore has no+    special meaning to the parser.++      Parser        HsVar "_x"+      Renamer       HsHole (HoleVar "_x")+      Typechecker   HsHole (HoleVar "_x", ref :: HoleExprRef)++  - Parse errors currently do not survive beyond the parser because an error is+    thrown after parsing. However, in the future GHC is intended to be tolerant+    of parse errors until the type checking phase to provide diagnostics similar+    to holes. This current singular case looks like this:++      Parser        HsHole HoleError++  Note that between anonymous holes, named holes, and unbound variables only the+  parsing phase is distinct, while during the renaming and type checking phases+  the cases are handled identically. The distinction that the user can observe+  is only introduced during final error reporting. There the `RdrName` is+  examined to see whether it starts with an underscore or not to determine+  whether the `HsHole` came from a hole or an out of scope variable.+++* Contents of HoleExprRef++  The HoleExprRef type used in the type checking phase is a data structure+  containing:++   - The type of the hole.+   - A ref-cell that is filled in (by the typechecker) with an+     error thunk.   With -fdefer-type errors we use this as the+     value of the hole.+   - A Unique (see Note [Uniques and tags]).++* Typechecking holes++  When the typechecker encounters a `HsHole`, it returns one with the+  HoleExprRef, but also emits a `DelayedError` into the `WantedConstraints`.+  This DelayedError later triggers the error reporting, and the filling-in of+  the error thunk, in GHC.Tc.Errors.++  The user has the option of deferring errors until runtime with+  `-fdefer-type-errors`. In this case, the hole carries evidence in its+  `HoleExprRef`. This evidence is an erroring expression that prints an error+  and crashes at runtime.++* Desugaring holes++  During desugaring, the `(HsHole (HoleVar "x", ref))` is desugared by+  reading the ref-cell to find the error thunk evidence term, put there by the+  constraint solver.++* Wrinkles:++  - Prior to fixing #17812, we used to invent an Id to hold the erroring+    expression, and then bind it during type-checking. But this does not support+    representation-polymorphic out-of-scope identifiers. See+    typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach+    described above.++  - You might think that the type in the HoleExprRef is the same as the type of+    the hole. However, because the hole type (hole_ty) is rewritten with respect+    to givens, this might not be the case. That is, the hole_ty is always (~) to+    the type of the HoleExprRef, but they might not be `eqType`. We need the+    type of the generated evidence to match what is expected in the context of+    the hole, and so we must store these types separately.++  - We really don't need the whole HoleExprRef; just the IORef EvTerm would be+    enough. But then deriving a Data instance becomes impossible. Much, much+    easier just to define HoleExprRef with a Data instance and store the whole+    structure.+-}+-- | Expression Hole. See Note [Holes in expressions].+type instance XHole GhcPs = HoleKind+type instance XHole GhcRn = HoleKind+type instance XHole GhcTc = (HoleKind, HoleExprRef)++data HoleKind+  = HoleVar (LIdP GhcPs)+  | HoleError+  deriving Data++-- | The RdrName for an unnamed hole ("_").+unnamedHoleRdrName :: RdrName+unnamedHoleRdrName = mkUnqual varName (fsLit "_")+++type instance XForAll        GhcPs = NoExtField+type instance XForAll        GhcRn = NoExtField+type instance XForAll        GhcTc = DataConCantHappen++type instance XQual          GhcPs = NoExtField+type instance XQual          GhcRn = NoExtField+type instance XQual          GhcTc = DataConCantHappen++type instance XFunArr        GhcPs = NoExtField+type instance XFunArr        GhcRn = NoExtField+type instance XFunArr        GhcTc = DataConCantHappen++type instance XPragE         (GhcPass _) = NoExtField++type instance XFunRhs  = AnnFunRhs++type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW+type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA++multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn))+multAnnToHsExpr = expandHsMultAnnOf mkHsVar++mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVar n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr $ nameRdrName $ unLoc n) n+    GhcTc -> n++mkHsVarWithUserRdr :: forall p. IsPass p => RdrName -> LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVarWithUserRdr rdr n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr rdr) n+    GhcTc -> n++data AnnExplicitSum+  = AnnExplicitSum {+      aesOpen       :: EpaLocation,+      aesBarsBefore :: [EpToken "|"],+      aesBarsAfter  :: [EpToken "|"],+      aesClose      :: EpaLocation+      } deriving Data++instance NoAnn AnnExplicitSum where+  noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn++data AnnFieldLabel+  = AnnFieldLabel {+      afDot :: Maybe (EpToken ".")+      } deriving Data++instance NoAnn AnnFieldLabel where+  noAnn = AnnFieldLabel Nothing++data AnnProjection+  = AnnProjection {+      apOpen  :: EpToken "(",+      apClose :: EpToken ")"+      } deriving Data++instance NoAnn AnnProjection where+  noAnn = AnnProjection noAnn noAnn++data AnnArithSeq+  = AnnArithSeq {+      aas_open   :: EpToken "[",+      aas_comma  :: Maybe (EpToken ","),+      aas_dotdot :: EpToken "..",+      aas_close  :: EpToken "]"+      } deriving Data++instance NoAnn AnnArithSeq where+  noAnn = AnnArithSeq noAnn noAnn noAnn noAnn++data AnnsIf+  = AnnsIf {+      aiIf       :: EpToken "if",+      aiThen     :: EpToken "then",+      aiElse     :: EpToken "else",+      aiThenSemi :: Maybe (EpToken ";"),+      aiElseSemi :: Maybe (EpToken ";")+      } deriving Data++instance NoAnn AnnsIf where+  noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing++data AnnFunRhs+  = AnnFunRhs {+       afr_strict :: EpToken "!",+       afr_opens  :: [EpToken "("],+       afr_closes :: [EpToken ")"]+  } deriving Data++instance NoAnn AnnFunRhs where+  noAnn = AnnFunRhs noAnn noAnn noAnn++-- ---------------------------------------------------------------------++type instance XSCC           (GhcPass _) = (AnnPragma, SourceText)+type instance XXPragE        (GhcPass _) = DataConCantHappen++type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel+type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen++type instance XPresent         (GhcPass _) = NoExtField++type instance XMissing         GhcPs = EpAnn Bool -- True for empty last comma+type instance XMissing         GhcRn = NoExtField+type instance XMissing         GhcTc = Scaled Type++type instance XXTupArg         (GhcPass _) = DataConCantHappen++tupArgPresent :: HsTupArg (GhcPass p) -> Bool+tupArgPresent (Present {}) = True+tupArgPresent (Missing {}) = False++tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p))+tupArgPresent_maybe (Present _ e) = Just e+tupArgPresent_maybe (Missing {})  = Nothing++tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]+tupArgsPresent_maybe = traverse tupArgPresent_maybe+++{- *********************************************************************+*                                                                      *+            XXExpr: the extension constructor of HsExpr+*                                                                      *+********************************************************************* -}++type instance XXExpr GhcPs = DataConCantHappen+type instance XXExpr GhcRn = XXExprGhcRn+type instance XXExpr GhcTc = XXExprGhcTc+-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below+++{- *********************************************************************+*                                                                      *+              Generating code for ExpandedThingRn+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | The different source constructs that we use to instantiate the "original" field+--   in an `XXExprGhcRn original expansion`+data HsThingRn = OrigExpr (HsExpr GhcRn)+               | OrigStmt (ExprLStmt GhcRn)+               | OrigPat  (LPat GhcRn)++isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool+isHsThingRnExpr (OrigExpr{}) = True+isHsThingRnExpr _ = False++isHsThingRnStmt (OrigStmt{}) = True+isHsThingRnStmt _ = False++isHsThingRnPat (OrigPat{}) = True+isHsThingRnPat _ = False++data XXExprGhcRn+  = ExpandedThingRn { xrn_orig     :: HsThingRn       -- The original source thing+                    , xrn_expanded :: HsExpr GhcRn }  -- The compiler generated expanded thing++  | PopErrCtxt                                     -- A hint for typechecker to pop+    {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack+                                                   -- Does not presist post renaming phase+                                                   -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]+                                                   -- in `GHC.Tc.Gen.Do`+  | HsRecSelRn  (FieldOcc GhcRn)   -- ^ Variable pointing to record selector+                           -- See Note [Non-overloaded record field selectors] and+                           -- Note [Record selectors in the AST]++++-- | Wrap a located expression with a `PopErrCtxt`+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)++-- | Wrap a located expression with a PopSrcExpr with an appropriate location+mkPopErrCtxtExprAt :: SrcSpanAnnA ->  LHsExpr GhcRn -> LHsExpr GhcRn+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original expression and+--   expanded expressions.+mkExpandedExpr+  :: HsExpr GhcRn         -- ^ source expression+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression+mkExpandedStmt+  :: ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)++mkExpandedPatRn+  :: LPat   GhcRn      -- ^ source pattern+  -> HsExpr GhcRn      -- ^ expanded expression+  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression an associate with a provided location+mkExpandedStmtAt+  :: SrcSpanAnnA          -- ^ Location for the expansion expression+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped located 'XXExprGhcRn'+mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr++-- | Wrap the expanded version of the expression with a pop.+mkExpandedStmtPopAt+  :: SrcSpanAnnA          -- ^ Location for the expansion statement+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr+++data XXExprGhcTc+  = WrapExpr        -- Type and evidence application and abstractions+      HsWrapper (HsExpr GhcTc)++  | ExpandedThingTc                         -- See Note [Rebindable syntax and XXExprGhcRn]+                                            -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+         { xtc_orig     :: HsThingRn        -- The original user written thing+         , xtc_expanded :: HsExpr GhcTc }   -- The expanded typechecked expression++  | ConLikeTc      -- Result of typechecking a data-con+                   -- See Note [Typechecking data constructors] in+                   --     GHC.Tc.Gen.Head+                   -- The two arguments describe how to eta-expand+                   -- the data constructor when desugaring+        ConLike [TcTyVar] [Scaled TcType]++  ---------------------------------------+  -- Haskell program coverage (Hpc) Support++  | HsTick+     CoreTickish+     (LHsExpr GhcTc)                    -- sub-expression++  | HsBinTick+     Int                                -- module-local tick number for True+     Int                                -- module-local tick number for False+     (LHsExpr GhcTc)                    -- sub-expression++  | HsRecSelTc  (FieldOcc GhcTc) -- ^ Variable pointing to record selector+                             -- See Note [Non-overloaded record field selectors] and+                             -- Note [Record selectors in the AST]+++-- | Build a 'XXExprGhcRn' out of an extension constructor,+--   and the two components of the expansion: original and+--   expanded typechecked expressions.+mkExpandedExprTc+  :: HsExpr GhcRn           -- ^ source expression+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)++-- | Build a 'XXExprGhcRn' out of an extension constructor.+--   The two components of the expansion are: original statement and+--   expanded typechecked expression.+mkExpandedStmtTc+  :: ExprLStmt GhcRn        -- ^ source do statement+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)++{- *********************************************************************+*                                                                      *+            Pretty-printing expressions+*                                                                      *+********************************************************************* -}++instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where+    ppr expr = pprExpr expr++-----------------------+-- pprExpr, pprLExpr, pprBinds call pprDeeper;+-- the underscore versions do not+pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+pprLExpr (L _ e) = pprExpr e++pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e+          | otherwise                           = pprDeeper (ppr_expr e)++isQuietHsExpr :: HsExpr id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsExpr (HsPar {})        = True+-- applications don't display anything themselves+isQuietHsExpr (HsApp {})        = True+isQuietHsExpr (HsAppType {})    = True+isQuietHsExpr (OpApp {})        = True+isQuietHsExpr _ = False++pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)+         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc+pprBinds b = pprDeeper (ppr b)++-----------------------+ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+ppr_lexpr e = ppr_expr (unLoc e)++ppr_expr :: forall p. (OutputableBndrId p)+         => HsExpr (GhcPass p) -> SDoc+ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v+ppr_expr (HsHole x) = case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcRn, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcTc, (HoleVar (L _ v), _)) -> pprPrefixOcc v+  (GhcPs, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcRn, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcTc, (HoleError, _)) -> pprPrefixOcc unnamedHoleRdrName+ppr_expr (HsIPVar _ v)       = ppr v+ppr_expr (HsOverLabel s l) = case ghcPass @p of+               GhcPs -> helper s+               GhcRn -> helper s+               GhcTc -> dataConCantHappen s+    where helper s =+            char '#' <> case s of+                          NoSourceText -> ppr l+                          SourceText src -> ftext src+ppr_expr (HsLit _ lit)       = ppr lit+ppr_expr (HsOverLit _ lit)   = ppr lit+ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)++ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]++ppr_expr e@(HsApp {})        = ppr_apps e []+ppr_expr e@(HsAppType {})    = ppr_apps e []++ppr_expr (OpApp _ e1 op e2)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly++  where+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear++    pp_prefixly+      = hang (ppr op) 2 (sep [pp_e1, pp_e2])++    pp_infixly pp_op+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])++ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e++ppr_expr (SectionL _ expr op)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])+                       4 (hsep [pp_expr, text "x_ )"])++    pp_infixly v = (sep [pp_expr, v])++ppr_expr (SectionR _ op expr)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])+                       4 (pp_expr <> rparen)++    pp_infixly v = sep [v, pp_expr]++ppr_expr (ExplicitTuple _ exprs boxity)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `MkSolo x`, not `(x)`+  | [Present _ expr] <- exprs+  , Boxed <- boxity+  = hsep [text (mkTupleStr Boxed dataName 1), ppr expr]+  | otherwise+  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))+  where+    ppr_tup_args []               = []+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es++    punc (Present {} : _) = comma <> space+    punc (Missing {} : _) = comma+    punc (XTupArg {} : _) = comma <> space+    punc []               = empty++ppr_expr (ExplicitSum _ alt arity expr)+  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"+  where+    ppr_bars n = hsep (replicate n (char '|'))++ppr_expr (HsLam _ lam_variant matches)+  = case lam_variant of+       LamSingle -> pprMatches matches+       _         -> sep [ sep [lamCaseKeyword lam_variant]+                        , nest 2 (pprMatches matches) ]++ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          pp_alts ]+  where+    pp_alts | null alts = text "{}"+            | otherwise = nest 2 (pprMatches matches)++ppr_expr (HsIf _ e1 e2 e3)+  = sep [hsep [text "if", nest 2 (ppr e1), text "then"],+         nest 4 (ppr e2),+         text "else",+         nest 4 (ppr e3)]++ppr_expr (HsMultiIf _ alts)+  = hang (text "if") 3  (vcat $ toList $ NE.map ppr_alt alts)+  where ppr_alt (L _ (GRHS _ guards expr)) =+          hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr)))+        ppr_alt (L _ (XGRHS x)) = ppr x++-- special case: let ... in let ...+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lexpr expr]++ppr_expr (HsLet _ binds expr)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr expr)]++ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts++ppr_expr (ExplicitList _ exprs)+  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })+  = hang pp_con 2 (ppr rbinds)+  where+    -- con :: ConLikeP (GhcPass p)+    -- so we need case analysis to know to print it+    pp_con = case ghcPass @p of+               GhcPs -> ppr con+               GhcRn -> ppr con+               GhcTc -> ppr con++ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })+  = case flds of+      RegularRecUpdFields { recUpdFields= rbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))+      OverloadedRecUpdFields { olRecUpdFields = pbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))++ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })+  = ppr fexp <> dot <> ppr field++ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))++ppr_expr (ExprWithTySig _ expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)++ppr_expr (ArithSeq _ _ info) = brackets (ppr info)++ppr_expr (HsTypedSplice ext e)   =+    case ghcPass @p of+      GhcPs -> pprTypedSplice Nothing e+      GhcRn ->+        case ext of+          HsTypedSpliceNested n -> pprTypedSplice (Just n) e+          HsTypedSpliceTop {}   -> pprTypedSplice Nothing e+      GhcTc -> pprTypedSplice Nothing e+ppr_expr (HsUntypedSplice ext s) =+    case ghcPass @p of+      GhcPs -> pprUntypedSplice True Nothing s+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s+      GhcRn | HsUntypedSpliceTop _ e  <- ext -> ppr e+      GhcTc -> dataConCantHappen ext++ppr_expr (HsTypedBracket b e)+  = case ghcPass @p of+    GhcPs -> thTyBrackets (ppr e)+    GhcRn -> thTyBrackets (ppr e)+    GhcTc | HsBracketTc _  _ty _wrap ps <- b ->+      thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps+ppr_expr (HsUntypedBracket b q)+  = case ghcPass @p of+    GhcPs -> ppr q+    GhcRn -> case b of+      [] -> ppr q+      ps -> ppr q $$ whenPprDebug (text "pending(rn)" <+> ppr (map ppr_nested_splice ps))+    GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->+      ppr rnq `ppr_with_pending_tc_splices` ps+  where+    ppr_nested_splice (PendingRnSplice splice_name expr) = pprUntypedSplice False (Just splice_name) expr++ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))+  = hsep [text "proc", ppr pat, arrow, ppr cmd]++ppr_expr (HsStatic _ e)+  = hsep [text "static", ppr e]++ppr_expr (HsEmbTy _ ty)+  = hsep [text "type", ppr ty]++ppr_expr (HsQual _ ctxt ty)+  = sep [ppr_context ctxt, ppr_lexpr ty]+  where+    ppr_context (L _ ctxt) =+      case ctxt of+        []       -> parens empty             <+> darrow+        [L _ ty] -> ppr_expr ty              <+> darrow+        _        -> parens (interpp'SP ctxt) <+> darrow++ppr_expr (HsForAll _ tele ty)+  = sep [pprHsForAll tele Nothing, ppr_lexpr ty]++ppr_expr (HsFunArr _ arr arg res)+  = sep [ppr_lexpr arg, pprHsArrow arr <+> ppr_lexpr res]++ppr_expr (XExpr x) = case ghcPass @p of+  GhcRn -> ppr x+  GhcTc -> ppr x++instance Outputable HsThingRn where+  ppr thing+    = case thing of+        OrigExpr x -> ppr_builder "<OrigExpr>:" x+        OrigStmt x -> ppr_builder "<OrigStmt>:" x+        OrigPat x  -> ppr_builder "<OrigPat>:" x++    where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)++instance Outputable XXExprGhcRn where+  ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+  ppr (PopErrCtxt e)        = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)+  ppr (HsRecSelRn f)        = pprPrefixOcc f++instance Outputable XXExprGhcTc where+  ppr (WrapExpr co_fn e)+    = pprHsWrapper co_fn (\_parens -> pprExpr e)++  ppr (ExpandedThingTc o e)+    = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+            -- e is the expanded expression, we print the original+            -- expression (HsExpr GhcRn), not the+            -- expanded typechecked one (HsExpr GhcTc),+            -- unless we are in ppr's debug mode printed both++  ppr (ConLikeTc con _ _) = pprPrefixOcc con+   -- Used in error messages generated by+   -- the pattern match overlap checker++  ppr (HsTick tickish exp) =+    pprTicks (ppr exp) $+      ppr tickish <+> ppr_lexpr exp++  ppr (HsBinTick tickIdTrue tickIdFalse exp) =+    pprTicks (ppr exp) $+      hcat [text "bintick<",+            ppr tickIdTrue,+            text ",",+            ppr tickIdFalse,+            text ">(",+            ppr exp, text ")"]+  ppr (HsRecSelTc f)      = pprPrefixOcc f++ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc+ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)+ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> v+  (GhcRn, HoleVar (L _ v)) -> v+  (GhcTc, (HoleVar (L _ v), _)) -> v+  _ -> unnamedHoleRdrName -- TODO: this is the HoleError case; this should print the source text instead of "_".+ppr_infix_expr (XExpr x)            = case ghcPass @p of+                                        GhcRn -> ppr_infix_expr_rn x+                                        GhcTc -> ppr_infix_expr_tc x+ppr_infix_expr _ = Nothing++ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing+ppr_infix_expr_rn (PopErrCtxt (L _ a))      = ppr_infix_expr a+ppr_infix_expr_rn (HsRecSelRn f)            = Just (pprInfixOcc f)++ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc+ppr_infix_expr_tc (WrapExpr _ e)    = ppr_infix_expr e+ppr_infix_expr_tc (ExpandedThingTc thing _)  = ppr_infix_hs_expansion thing+ppr_infix_expr_tc (ConLikeTc {})             = Nothing+ppr_infix_expr_tc (HsTick {})                = Nothing+ppr_infix_expr_tc (HsBinTick {})             = Nothing+ppr_infix_expr_tc (HsRecSelTc f)            = Just (pprInfixOcc f)++ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc+ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e+ppr_infix_hs_expansion _            = Nothing++ppr_apps :: (OutputableBndrId p)+         => HsExpr (GhcPass p)+         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]+         -> SDoc+ppr_apps (HsApp _ (L _ fun) arg)        args+  = ppr_apps fun (Left arg : args)+ppr_apps (HsAppType _ (L _ fun) arg)    args+  = ppr_apps fun (Right arg : args)+ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))+  where+    pp (Left arg)                             = ppr arg+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))+    --   = char '@' <> pprHsType arg+    pp (Right arg)+      = text "@" <> ppr arg++pprDebugParendExpr :: (OutputableBndrId p)+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprDebugParendExpr p expr+  = getPprDebug $ \case+      True  -> pprParendLExpr p expr+      False -> pprLExpr         expr++pprParendLExpr :: (OutputableBndrId p)+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprParendLExpr p (L _ e) = pprParendExpr p e++pprParendExpr :: (OutputableBndrId p)+              => PprPrec -> HsExpr (GhcPass p) -> SDoc+pprParendExpr p expr+  | hsExprNeedsParens p expr = parens (pprExpr expr)+  | otherwise                = pprExpr expr+        -- Using pprLExpr makes sure that we go 'deeper'+        -- I think that is usually (always?) right++-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs+-- parentheses under precedence @p@.+hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool+hsExprNeedsParens prec = go+  where+    go :: HsExpr (GhcPass p) -> Bool+    go (HsVar{})                      = False+    go (HsIPVar{})                    = False+    go (HsOverLabel{})                = False+    go (HsLit _ l)                    = hsLitNeedsParens prec l+    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol+    go (HsPar{})                      = False+    go (HsApp{})                      = prec >= appPrec+    go (HsAppType {})                 = prec >= appPrec+    go (OpApp{})                      = prec >= opPrec+    go (NegApp{})                     = prec > topPrec+    go (SectionL{})                   = True+    go (SectionR{})                   = True+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (ExplicitTuple _ [Present{}] Boxed)+                                      = prec >= appPrec+    go (ExplicitTuple{})              = False+    go (ExplicitSum{})                = False+    go (HsLam{})                      = prec > topPrec+    go (HsCase{})                     = prec > topPrec+    go (HsIf{})                       = prec > topPrec+    go (HsMultiIf{})                  = prec > topPrec+    go (HsLet{})                      = prec > topPrec+    go (HsDo _ sc _)+      | isDoComprehensionContext sc   = False+      | otherwise                     = prec > topPrec+    go (ExplicitList{})               = False+    go (RecordUpd{})                  = False+    go (ExprWithTySig{})              = prec >= sigPrec+    go (ArithSeq{})                   = False+    go (HsPragE{})                    = prec >= appPrec+    go (HsTypedSplice{})              = False+    go (HsUntypedSplice{})            = False+    go (HsTypedBracket{})             = False+    go (HsUntypedBracket{})           = False+    go (HsProc{})                     = prec > topPrec+    go (HsStatic{})                   = prec >= appPrec+    go (RecordCon{})                  = False+    go (HsProjection{})               = True+    go (HsGetField{})                 = False+    go (HsEmbTy{})                    = prec > topPrec+    go (HsHole{})                     = False+    go (HsForAll{})                   = prec >= funPrec+    go (HsQual{})                     = prec >= funPrec+    go (HsFunArr{})                   = prec >= funPrec+    go (XExpr x) = case ghcPass @p of+                     GhcTc -> go_x_tc x+                     GhcRn -> go_x_rn x++    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)                   = hsExprNeedsParens prec e+    go_x_tc (ExpandedThingTc thing _)        = hsExpandedNeedsParens thing+    go_x_tc (ConLikeTc {})                   = False+    go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e+    go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e+    go_x_tc (HsRecSelTc{})                   = False++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _)    = hsExpandedNeedsParens thing+    go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a+    go_x_rn (HsRecSelRn{})               = False++    hsExpandedNeedsParens :: HsThingRn -> Bool+    hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e+    hsExpandedNeedsParens _            = False++-- | Parenthesize an expression without token information+gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+gHsPar e = HsPar x e+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.+parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+parenthesizeHsExpr p le@(L loc e)+  | hsExprNeedsParens p e = L loc (gHsPar le)+  | otherwise             = le++stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr e = e++stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)+stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+stripParensHsExpr e = e++isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool+-- True of a single token+isAtomicHsExpr (HsVar {})        = True+isAtomicHsExpr (HsLit {})        = True+isAtomicHsExpr (HsOverLit {})    = True+isAtomicHsExpr (HsIPVar {})      = True+isAtomicHsExpr (HsOverLabel {})  = True+isAtomicHsExpr (HsHole{})        = True+isAtomicHsExpr (XExpr x)+  | GhcTc <- ghcPass @p          = go_x_tc x+  | GhcRn <- ghcPass @p          = go_x_rn x+  where+    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)            = isAtomicHsExpr e+    go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing+    go_x_tc (ConLikeTc {})            = True+    go_x_tc (HsTick {})               = False+    go_x_tc (HsBinTick {})            = False+    go_x_tc (HsRecSelTc{})            = True++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing+    go_x_rn (PopErrCtxt (L _ a))      = isAtomicHsExpr a+    go_x_rn (HsRecSelRn{})            = True++    isAtomicExpandedThingRn :: HsThingRn -> Bool+    isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e+    isAtomicExpandedThingRn _            = False++isAtomicHsExpr _ = False++instance Outputable (HsPragE (GhcPass p)) where+  ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) =+    pprWithSourceText st (text "{-# SCC")+     -- no doublequotes if stl empty, for the case where the SCC was written+     -- without quotes.+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"+++{- *********************************************************************+*                                                                      *+             XXExprGhcRn and rebindable syntax+*                                                                      *+********************************************************************* -}++{- Note [Rebindable syntax and XXExprGhcRn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We implement rebindable syntax (RS) support by performing a desugaring+in the renamer. We transform GhcPs expressions and patterns affected by+RS into the appropriate desugared form, but **annotated with the original+expression/pattern**.++Let us consider a piece of code like:++    {-# LANGUAGE RebindableSyntax #-}+    ifThenElse :: Char -> () -> () -> ()+    ifThenElse _ _ _ = ()+    x = if 'a' then () else True++The parsed AST for the RHS of x would look something like (slightly simplified):++    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))++Upon seeing such an AST with RS on, we could transform it into a+mere function call, as per the RS rules, equivalent to the+following function application:++    ifThenElse 'a' () True++which doesn't typecheck. But GHC would report an error about+not being able to match the third argument's type (Bool) with the+expected type: (), in the expression _as desugared_, i.e in+the aforementioned function application. But the user never+wrote a function application! This would be pretty bad.++To remedy this, instead of transforming the original HsIf+node into mere applications of 'ifThenElse', we keep the+original 'if' expression around too, using the TTG+XExpr extension point to allow GHC to construct an+'XXExprGhcRn' value that will keep track of the original+expression in its first field, and the desugared one in the+second field. The resulting renamed AST would look like:++    L locif (XExpr+      (ExpandedThingRn+        (HsIf (L loca 'a')+              (L loctrue ())+              (L locfalse True)+        )+        (App (L generatedSrcSpan+                (App (L generatedSrcSpan+                        (App (L generatedSrcSpan (Var ifThenElse))+                             (L loca 'a')+                        )+                     )+                     (L loctrue ())+                )+             )+             (L locfalse True)+        )+      )+    )++When comes the time to typecheck the program, we end up calling+tcMonoExpr on the AST above. If this expression gives rise to+a type error, then it will appear in a context line and GHC+will pretty-print it using the 'Outputable (XXExprGhcRn a b)'+instance defined below, which *only prints the original+expression*. This is the gist of the idea, but is not quite+enough to recover the error messages that we had with the+SyntaxExpr-based, typechecking/desugaring-to-core time+implementation of rebindable syntax. The key idea is to decorate+some elements of the desugared expression so as to be able to+give them a special treatment when typechecking the desugared+expression, to print a different context line or skip one+altogether.++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we+entered generated code, i.e code fabricated by the compiler when rebinding some+syntax. If someone tries to push some error context line while that field is set+to True, the pushing won't actually happen and the context line is just dropped.+Once we 'setSrcSpan' a real span (for an expression that was in the original+source code), we set 'tcl_in_gen_code' back to False, indicating that we+"emerged from the generated code tunnel", and that the expressions we will be+processing are relevant to report in context lines again.++You might wonder why TcLclEnv has both+   tcl_loc         :: RealSrcSpan+   tcl_in_gen_code :: Bool+Could we not store a Maybe RealSrcSpan? The problem is that we still+generate constraints when processing generated code, and a CtLoc must+contain a RealSrcSpan -- otherwise, error messages might appear+without source locations. So tcl_loc keeps the RealSrcSpan of the last+location spotted that wasn't generated; it's as good as we're going to+get in generated code. Once we get to sub-trees that are not+generated, then we update the RealSrcSpan appropriately, and set the+tcl_in_gen_code Bool to False.++---++An overview of the constructs that are desugared in this way is laid out in+Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.++A general recipe to follow this approach for new constructs could go as follows:++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your+  construct, in HsExpr or related syntax data types.+- At renaming-time:+    - take your original node of interest (HsIf above)+    - rename its subexpressions/subpatterns (condition and true/false+      branches above)+    - construct the suitable "rebound"-and-renamed result (ifThenElse call+      above), where the 'SrcSpan' attached to any _fabricated node_ (the+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'+    - take both the original node and that rebound-and-renamed result and wrap+      them into an expansion construct:+        for expressions, XExpr (ExpandedThingRn <original node> <desugared>)+        for patterns, XPat (HsPatExpanded <original node> <desugared>)+ - At typechecking-time:+    - remove any logic that was previously dealing with your rebindable+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.+    - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we+      typecheck the desugared expression while reporting the original one in+      errors+-}++{- Note [Overview of record dot syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the note that explains all the moving parts for record dot+syntax.++The language extensions @OverloadedRecordDot@ and+@OverloadedRecordUpdate@ (providing "record dot syntax") are+implemented using the techniques of Note [Rebindable syntax and+XXExprGhcRn].++When OverloadedRecordDot is enabled:+- Field selection expressions+  - e.g. foo.bar.baz+  - Have abstract syntax HsGetField+  - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions+- Field selector expressions e.g. (.x.y)+  - Have abstract syntax HsProjection+  - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions++When OverloadedRecordUpdate is enabled:+- Record update expressions+  - e.g. a{foo.bar=1, quux="corge", baz}+  - Have abstract syntax RecordUpd+    - With rupd_flds containting a Right+    - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)+  - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions+    - Note that this is true for all record updates even for those that do not involve '.'++When OverloadedRecordDot is enabled and RebindableSyntax is not+enabled the name 'getField' is resolved to GHC.Records.getField. When+OverloadedRecordDot is enabled and RebindableSyntax is enabled the+name 'getField' is whatever in-scope name that is.++When OverloadedRecordUpd is enabled and RebindableSyntax is not+enabled it is an error for now (temporary while we wait on native+setField support; see+https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When+OverloadedRecordUpd is enabled and RebindableSyntax is enabled the+names 'getField' and 'setField' are whatever in-scope names they are.+-}+++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************+-}++type instance XCmdArrApp  GhcPs = (IsUnicodeSyntax, EpaLocation)+type instance XCmdArrApp  GhcRn = NoExtField+type instance XCmdArrApp  GhcTc = Type++type instance XCmdArrForm GhcPs = AnnList ()+-- | fixity (filled in by the renamer), for forms that were converted from+-- OpApp's by the renamer+type instance XCmdArrForm GhcRn = Maybe Fixity+type instance XCmdArrForm GhcTc = Maybe Fixity++type instance XCmdApp     (GhcPass _) = NoExtField+type instance XCmdLam     (GhcPass _) = NoExtField++type instance XCmdPar     GhcPs = (EpToken "(", EpToken ")")+type instance XCmdPar     GhcRn = NoExtField+type instance XCmdPar     GhcTc = NoExtField++type instance XCmdCase    GhcPs = EpAnnHsCase+type instance XCmdCase    GhcRn = NoExtField+type instance XCmdCase    GhcTc = NoExtField++type instance XCmdLamCase (GhcPass _) = EpAnnLam++type instance XCmdIf      GhcPs = AnnsIf+type instance XCmdIf      GhcRn = NoExtField+type instance XCmdIf      GhcTc = NoExtField++type instance XCmdLet     GhcPs = (EpToken "let", EpToken "in")+type instance XCmdLet     GhcRn = NoExtField+type instance XCmdLet     GhcTc = NoExtField++type instance XCmdDo      GhcPs = AnnList EpaLocation+type instance XCmdDo      GhcRn = NoExtField+type instance XCmdDo      GhcTc = Type++type instance XCmdWrap    (GhcPass _) = NoExtField++type instance XXCmd       GhcPs = DataConCantHappen+type instance XXCmd       GhcRn = DataConCantHappen+type instance XXCmd       GhcTc = HsWrap HsCmd++    -- If   cmd :: arg1 --> res+    --      wrap :: arg1 "->" arg2+    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res++-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable p = [(Name, HsExpr p)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxTable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+  For example, for the 'arr' method+   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+             where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <expression>)]+  where <expression> is the evidence for the method.  This evidence is+  instantiated with the class, but is still polymorphic in everything+  else.  For example, in the case of 'arr', the evidence has type+         forall b c. (b->c) -> a b c+  where 'a' is the ambient type of the arrow.  This polymorphism is+  important because the desugarer uses the same evidence at multiple+  different types.++This is Less Cool than what we normally do for rebindable syntax, which is to+make fully-instantiated piece of evidence at every use site.  The Cmd way+is Less Cool because+  * The renamer has to predict which methods are needed.+    See the tedious GHC.Rename.Expr.methodNamesCmd.++  * The desugarer has to know the polymorphic type of the instantiated+    method. This is checked by Inst.tcSyntaxName, but is less flexible+    than the rest of rebindable syntax, where the type is less+    pre-ordained.  (And this flexibility is useful; for example we can+    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}++data CmdTopTc+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack+             Type    -- return type of the command+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]++type instance XCmdTop  GhcPs = NoExtField+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]+type instance XCmdTop  GhcTc = CmdTopTc+++type instance XXCmdTop (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where+    ppr cmd = pprCmd cmd++-----------------------+-- pprCmd and pprLCmd call pprDeeper;+-- the underscore versions do not+pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+pprLCmd (L _ c) = pprCmd c++pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc+pprCmd c | isQuietHsCmd c =            ppr_cmd c+         | otherwise      = pprDeeper (ppr_cmd c)++isQuietHsCmd :: HsCmd id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsCmd (HsCmdPar {}) = True+-- applications don't display anything themselves+isQuietHsCmd (HsCmdApp {}) = True+isQuietHsCmd _ = False++-----------------------+ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+ppr_lcmd c = ppr_cmd (unLoc c)++ppr_cmd :: forall p. (OutputableBndrId p+                     ) => HsCmd (GhcPass p) -> SDoc+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)++ppr_cmd (HsCmdApp _ c e)+  = let (fun, args) = collect_args c [e] in+    hang (ppr_lcmd fun) 2 (sep (map ppr args))+  where+    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)+    collect_args fun args = (fun, args)++ppr_cmd (HsCmdLam _ LamSingle matches)+  = pprMatches matches+ppr_cmd (HsCmdLam _ lam_variant matches)+  = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdCase _ expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdIf _ _ e ct ce)+  = sep [hsep [text "if", nest 2 (ppr e), text "then"],+         nest 4 (ppr ct),+         text "else",+         nest 4 (ppr ce)]++-- special case: let ... in let ...+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lcmd cmd]++ppr_cmd (HsCmdLet _ binds cmd)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr cmd)]++ppr_cmd (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts++ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args)+  | HsVar _ (L _ v) <- op+  = ppr_cmd_infix v+  | GhcTc <- ghcPass @p+  , XExpr (ConLikeTc c _ _) <- op+  = ppr_cmd_infix (conLikeName c)+  | otherwise+  = fall_through+  where+    fall_through = hang (text "(|" <+> ppr_expr op)+                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")++    ppr_cmd_infix :: OutputableBndr v => v -> SDoc+    ppr_cmd_infix v+      | [arg1, arg2] <- args+      , case ghcPass @p of+          GhcPs -> ps_fix == Infix+          GhcRn -> isJust rn_fix || ps_fix == Infix+          GhcTc -> isJust rn_fix || ps_fix == Infix+      = hang (pprCmdArg (unLoc arg1))+           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])+      | otherwise+      = fall_through++ppr_cmd (XCmd x) = case ghcPass @p of+  GhcTc -> case x of+    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))++pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc+pprCmdArg (HsCmdTop _ cmd)+  = ppr_lcmd cmd++instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where+    ppr = pprCmdArg++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************+-}++type instance XMG         GhcPs b = Origin+type instance XMG         GhcRn b = Origin -- See Note [Generated code and pattern-match checking]+type instance XMG         GhcTc b = MatchGroupTc++data MatchGroupTc+  = MatchGroupTc+       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn+       , mg_res_ty  :: Type    -- Type of the result, tr+       , mg_origin  :: Origin  -- Origin (Generated vs FromSource)+       } deriving Data++type instance XXMatchGroup (GhcPass _) b = DataConCantHappen++type instance XCMatch (GhcPass _) b = NoExtField+type instance XXMatch (GhcPass _) b = DataConCantHappen++instance (OutputableBndrId pr, Outputable body)+            => Outputable (Match (GhcPass pr) body) where+  ppr = pprMatch++isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms++-- | Is there only one RHS in this list of matches?+isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool+isSingletonMatchGroup matches+  | [L _ match] <- matches+  , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match+  = True+  | otherwise+  = False++matchGroupArity :: MatchGroup (GhcPass id) body -> Arity+-- This is called before type checking, when mg_arg_tys is not set+matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]+matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1)++hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]+hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats++isInfixMatch :: Match (GhcPass p) body -> Bool+isInfixMatch match = case m_ctxt match of+  FunRhs {mc_fixity = Infix} -> True+  _                          -> False++-- We keep the type checker happy by providing EpAnnComments.  They+-- can only be used if they follow a `where` keyword with no binds,+-- but in that case the comment is attached to the following parsed+-- item. So this can never be used in practice.+type instance XCGRHSs (GhcPass _) _ = EpAnnComments++type instance XXGRHSs (GhcPass _) _ = DataConCantHappen++data GrhsAnn+  = GrhsAnn {+      ga_vbar :: Maybe (EpToken "|"),+      ga_sep  :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->`+      } deriving (Data)++instance NoAnn GrhsAnn where+  noAnn = GrhsAnn Nothing noAnn++type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn+                                   -- Location of matchSeparator+                                   -- TODO:AZ does this belong on the GRHS, or GRHSs?++type instance XXGRHS (GhcPass _) b = DataConCantHappen++pprMatches :: (OutputableBndrId idR, Outputable body)+           => MatchGroup (GhcPass idR) body -> SDoc+pprMatches MG { mg_alts = matches }+    = vcat (map pprMatch (map unLoc (unLoc matches)))+      -- Don't print the type; it's only a place-holder before typechecking++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc+pprFunBind matches = pprMatches matches++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc+pprPatBind pat grhss+ = sep [ppr pat,+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)]++pprMatch :: (OutputableBndrId idR, Outputable body)+         => Match (GhcPass idR) body -> SDoc+pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss })+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)+        , nest 2 (pprGRHSs ctxt grhss) ]+  where+    -- lam_cases_result: we don't simply return (empty, pats) to avoid+    -- introducing an additional `nest 2` via the empty herald+    lam_cases_result = case pats of+                          []     -> (empty, [])+                          (p:ps) -> (pprParendLPat appPrec p, ps)++    (herald, other_pats)+        = case ctxt of+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}+                | SrcStrict <- strictness+                -> assert (null pats)     -- A strict variable binding+                   (char '!'<>pprPrefixOcc fun, pats)++                | Prefix <- fixity+                -> (pprPrefixOcc fun, pats) -- f x y z = e+                                            -- Not pprBndr; the AbsBinds will+                                            -- have printed the signature+                | otherwise+                -> case pats of+                     (p1:p2:rest)+                        | null rest -> (pp_infix, [])           -- x &&& y = e+                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e+                        where+                          pp_infix = pprParendLPat opPrec p1+                                     <+> pprInfixOcc fun+                                     <+> pprParendLPat opPrec p2+                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++            LamAlt LamSingle                       -> (char '\\', pats)+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)+            LamAlt LamCases                        -> lam_cases_result+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> lam_cases_result++            ArrowMatchCtxt ProcExpr -> (text "proc", pats)++            _ -> case pats of+                   []    -> (empty, [])+                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case+                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++pprGRHSs :: (OutputableBndrId idR, Outputable body)+         => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc+pprGRHSs ctxt (GRHSs _ grhss binds)+  = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss)+  -- Print the "where" even if the contents of the binds is empty. Only+  -- EmptyLocalBinds means no "where" keyword+ $$ ppUnless (eqEmptyLocalBinds binds)+      (text "where" $$ nest 4 (pprBinds binds))++pprGRHS :: (OutputableBndrId idR, Outputable body)+        => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc+pprGRHS ctxt (GRHS _ [] body)+ =  pp_rhs ctxt body++pprGRHS ctxt (GRHS _ guards body)+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]++pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)++matchSeparator :: HsMatchContext fn -> SDoc+matchSeparator FunRhs{}         = text "="+matchSeparator CaseAlt          = arrow+matchSeparator LamAlt{}         = arrow+matchSeparator IfAlt            = arrow+matchSeparator ArrowMatchCtxt{} = arrow+matchSeparator PatBindRhs       = text "="+matchSeparator PatBindGuards    = text "="+matchSeparator StmtCtxt{}       = text "<-"+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern+matchSeparator PatSyn           = text "<-" -- match checker trace+matchSeparator LazyPatCtx       = panic "unused"+matchSeparator ThPatSplice      = panic "unused"+matchSeparator ThPatQuote       = panic "unused"++instance Outputable GrhsAnn where+  ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- Extra fields available post typechecking for RecStmt.+data RecStmtTc =+  RecStmtTc+     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1+                                  -- with recS_later_ids and recS_rec_ids,+                                  -- and are the expressions that should be+                                  -- returned by the recursion.+                                  -- They may not quite be the Ids themselves,+                                  -- because the Id may be *polymorphic*, but+                                  -- the returned thing has to be *monomorphic*,+                                  -- so they may be type applications++      , recS_ret_ty :: Type        -- The type of+                                   -- do { stmts; return (a,b,c) }+                                   -- With rebindable syntax the type might not+                                   -- be quite as simple as (m (tya, tyb, tyc)).+      }+++type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField++type instance XBindStmt        (GhcPass _) GhcPs b = EpUniToken "<-" "←"+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc++data XBindStmtRn = XBindStmtRn+  { xbsrn_bindOp :: SyntaxExpr GhcRn+  , xbsrn_failOp :: FailOperator GhcRn+  }++data XBindStmtTc = XBindStmtTc+  { xbstc_bindOp :: SyntaxExpr GhcTc+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_failOp :: FailOperator GhcTc+  }++type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcTc = Type++type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcTc b = Type++type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpToken "let"++type instance XParStmt         (GhcPass _) GhcPs b = NoExtField+type instance XParStmt         (GhcPass _) GhcRn b = NoExtField+type instance XParStmt         (GhcPass _) GhcTc b = Type++type instance XTransStmt       (GhcPass _) GhcPs b = AnnTransStmt+type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField+type instance XTransStmt       (GhcPass _) GhcTc b = Type++type instance XRecStmt         (GhcPass _) GhcPs b = AnnList (EpToken "rec")+type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField+type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc++type instance XXStmtLR         (GhcPass _) GhcPs b = DataConCantHappen+type instance XXStmtLR         (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn+type instance XXStmtLR         (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc++data AnnTransStmt+  = AnnTransStmt {+      ats_then  :: EpToken "then",+      ats_group :: Maybe (EpToken "group"),+      ats_by    :: Maybe (EpToken "by"),+      ats_using :: Maybe (EpToken "using")+      } deriving Data++instance NoAnn AnnTransStmt where+  noAnn = AnnTransStmt noAnn noAnn noAnn noAnn+++-- | 'ApplicativeStmt' represents an applicative expression built with+-- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the+-- appropriate applicative expression by the desugarer, but it is intended+-- to be invisible in error messages.+--+-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"+--+data ApplicativeStmt idL idR+  = ApplicativeStmt+             (XApplicativeStmt idL idR) -- Post typecheck, Type of the body+             [ ( SyntaxExpr idR+               , ApplicativeArg idL) ]+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary++-- | Applicative Argument+data ApplicativeArg idL+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)+    { xarg_app_arg_one  :: XApplicativeArgOne idL+      -- ^ The fail operator, after renaming+      --+      -- The fail operator is needed if this is a BindStmt+      -- where the pattern can fail. E.g.:+      -- (Just a) <- stmt+      -- The fail operator will be invoked if the pattern+      -- match fails.+      -- It is also used for guards in MonadComprehensions.+      -- The fail operator is Nothing+      -- if the pattern match can't fail+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)+    , arg_expr          :: LHsExpr idL+    , is_body_stmt      :: Bool+      -- ^ True <=> was a BodyStmt,+      -- False <=> was a BindStmt.+      -- See Note [Applicative BodyStmt]+    }+  | ApplicativeArgMany     -- do { stmts; return vars }+    { xarg_app_arg_many :: XApplicativeArgMany idL+    , app_stmts         :: [ExprLStmt idL] -- stmts+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)+    , bv_pattern        :: LPat idL      -- (v1,...,vn)+    , stmt_context      :: HsDoFlavour+      -- ^ context of the do expression, used in pprArg+    }+  | XApplicativeArg !(XXApplicativeArg idL)++type family XApplicativeStmt x x'++-- ApplicativeArg type families+type family XApplicativeArgOne   x+type family XApplicativeArgMany  x+type family XXApplicativeArg     x++type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen++type instance XApplicativeArgOne GhcPs = NoExtField+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc++type instance XApplicativeArgMany (GhcPass _) = NoExtField+type instance XXApplicativeArg    (GhcPass _) = DataConCantHappen++instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),+          Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))+        => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts++instance (OutputableBndrId pl, OutputableBndrId pr,+                 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,+          Outputable body)+         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where+    ppr stmt = pprStmt stmt++pprStmt :: forall idL idR body . (OutputableBndrId idL,+                                  OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                                  Outputable body)+        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc+pprStmt (LastStmt _ expr m_dollar_stripped _)+  = whenPprDebug (text "[last]") <+>+      (case m_dollar_stripped of+        Just True -> text "return $"+        Just False -> text "return"+        Nothing -> empty) <+>+      ppr expr+pprStmt (BindStmt _ pat expr)  = pprBindStmt pat expr+pprStmt (LetStmt _ binds)      = hsep [text "let", pprBinds binds]+pprStmt (BodyStmt _ expr _ _)  = ppr expr+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss))++pprStmt (TransStmt { trS_stmts = stmts, trS_by = by+                   , trS_using = using, trS_form = form })+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])++pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids+                 , recS_later_ids = later_ids })+  = text "rec" <+>+    vcat [ ppr_do_stmts (unLoc segment)+         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids+                            , text "later_ids=" <> ppr later_ids])]++pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of+    GhcRn -> pprApplicativeStmt x+    GhcTc -> pprApplicativeStmt x++  where+    pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc+    pprApplicativeStmt (ApplicativeStmt _ args mb_join) =+      getPprStyle $ \style ->+          if userStyle style+             then pp_for_user+             else pp_debug+      where+        -- make all the Applicative stuff invisible in error messages by+        -- flattening the whole ApplicativeStmt nest back to a sequence+        -- of statements.+        pp_for_user = vcat $ concatMap flattenArg args++        -- ppr directly rather than transforming here, because we need to+        -- inject a "return" which is hard when we're polymorphic in the id+        -- type.+        flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]+        flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of+            GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+            GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+        flattenStmt stmt = [ppr stmt]++        flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]+        flattenArg (_, ApplicativeArgOne _ pat expr isBody)+          | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]+          | otherwise = [pprBindStmt pat expr]+        flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =+          concatMap flattenStmt stmts++        pp_debug =+          let+              ap_expr = sep (punctuate (text " |") (map pp_arg args))+          in+            whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>+            (if lengthAtLeast args 2 then parens else id) ap_expr++        pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc+        pp_arg (_, applicativeArg) = ppr applicativeArg++pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc+pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]++instance (OutputableBndrId idL)+      => Outputable (ApplicativeArg (GhcPass idL)) where+  ppr = pprArg++pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc+pprArg (ApplicativeArgOne _ pat expr isBody)+  | isBody = ppr expr -- See Note [Applicative BodyStmt]+  | otherwise = pprBindStmt pat expr+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =+     ppr pat <+>+     text "<-" <+>+     pprDo ctxt (stmts +++                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])++pprTransformStmt :: (OutputableBndrId p)+                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc+pprTransformStmt bndrs using by+  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))+        , nest 2 (ppr using)+        , nest 2 (pprBy by)]++pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc+pprTransStmt by using ThenForm+  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]+pprTransStmt by using GroupForm+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]++pprBy :: Outputable body => Maybe body -> SDoc+pprBy Nothing  = empty+pprBy (Just e) = text "by" <+> ppr e++pprDo :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc+pprDo (DoExpr m)    stmts =+  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts+pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts+pprDo (MDoExpr m)   stmts =+  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts+pprDo ListComp      stmts = brackets    $ pprComp stmts+pprDo MonadComp     stmts = brackets    $ pprComp stmts++pprArrowExpr :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => [LStmt (GhcPass p) body] -> SDoc+pprArrowExpr stmts = text "do"  <+> ppr_do_stmts stmts++ppr_module_name_prefix :: Maybe ModuleName -> SDoc+ppr_module_name_prefix = \case+  Nothing -> empty+  Just module_name -> ppr module_name <> char '.'++ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                 Outputable body)+             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc+-- Print a bunch of do stmts+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)++pprComp :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+        => [LStmt (GhcPass p) body] -> SDoc+pprComp quals     -- Prints:  body | qual1, ..., qualn+  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals+  = if null initStmts+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list. This does arise+       -- occasionally in code that GHC generates, e.g., in implementations of+       -- 'range' for derived 'Ix' instances for product datatypes with exactly+       -- one constructor (e.g., see #12583).+       then ppr body+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)+  | otherwise+  = pprPanic "pprComp" (pprQuals quals)++pprQuals :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+         => [LStmt (GhcPass p) body] -> SDoc+-- Show list comprehension qualifiers separated by commas+pprQuals quals = interpp'SP quals++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++-- | Finalizers produced by a splice with+-- 'Language.Haskell.TH.Syntax.addModFinalizer'+--+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how+-- this is used.+--+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]++-- A Data instance which ignores the argument of 'ThModFinalizers'.+instance Data ThModFinalizers where+  gunfold _ z _ = z $ ThModFinalizers []+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]++-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.+-- This is the result of splicing a splice. It is produced by+-- the renamer and consumed by the typechecker. It lives only between the two.+data HsUntypedSpliceResult thing  -- 'thing' can be HsExpr or HsType+  = HsUntypedSpliceTop+      { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice.+      , utsplice_result            :: thing           -- ^ The result of splicing; See Note [Lifecycle of a splice]+      }+  | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point++-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- for an explanation of the Template Haskell extension points.+data HsTypedSpliceResult+  = HsTypedSpliceTop+  | HsTypedSpliceNested SplicePointName++type instance XTypedSplice   GhcPs = NoExtField+type instance XTypedSplice   GhcRn = HsTypedSpliceResult+type instance XTypedSplice   GhcTc = DelayedSplice++type instance XUntypedSplice GhcPs = NoExtField+type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn)+type instance XUntypedSplice GhcTc = DataConCantHappen++-- HsUntypedSplice+type instance XUntypedSpliceExpr GhcPs = EpToken "$"+type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt+type instance XUntypedSpliceExpr GhcTc = DataConCantHappen++type instance XTypedSpliceExpr GhcPs = EpToken "$$"+type instance XTypedSpliceExpr GhcRn = NoExtField+type instance XTypedSpliceExpr GhcTc = NoExtField++type instance XQuasiQuote        GhcPs = NoExtField+type instance XQuasiQuote        GhcRn = HsQuasiQuoteExt+type instance XQuasiQuote        GhcTc = DataConCantHappen+++type instance XXUntypedSplice    GhcPs = DataConCantHappen+type instance XXUntypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXUntypedSplice    GhcTc = DataConCantHappen++type instance XXTypedSplice    GhcPs = DataConCantHappen+type instance XXTypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXTypedSplice    GhcTc = DataConCantHappen++-- See Note [Running typed splices in the zonker]+-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`+data DelayedSplice =+  DelayedSplice+    TcLclEnv          -- The local environment to run the splice in+    (LHsExpr GhcRn)   -- The original renamed expression+    TcType            -- The result type of running the splice, unzonked+    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result++-- A Data instance which ignores the argument of 'DelayedSplice'.+instance Data DelayedSplice where+  gunfold _ _ _ = panic "DelayedSplice"+  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]++-- See Note [Pending Splices]+type SplicePointName = Name++data UntypedSpliceFlavour+  = UntypedExpSplice+  | UntypedPatSplice+  | UntypedTypeSplice+  | UntypedDeclSplice+  deriving Data+++-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- A 'PendingRnSplice' is lifted from an untyped quotation and then typechecked.+data PendingRnSplice = PendingRnSplice SplicePointName (HsUntypedSplice GhcRn)++instance Outputable PendingRnSplice where+  ppr (PendingRnSplice sp expr) =+    angleBrackets (ppr sp <> comma <+> pprUntypedSplice False Nothing expr)++-- | Pending Type-checker Splice+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data PendingTcSplice+  = PendingTcSplice SplicePointName (LHsExpr GhcTc)++-- | Information about an implicit lift, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsImplicitLiftSplice =+        HsImplicitLiftSplice+          { implicit_lift_bind_lvl :: S.Set ThLevelIndex+          , implicit_lift_used_lvl :: ThLevelIndex+          , implicit_lift_gre :: Maybe GlobalRdrElt+          , implicit_lift_lid :: LIdOccP GhcRn+          }++-- | Information about a user-written splice, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsUserSpliceExt =+  HsUserSpliceExt+    { user_splice_flavour :: UntypedSpliceFlavour+    }++-- | Information about a quasi-quoter, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsQuasiQuoteExt =+  HsQuasiQuoteExt+    { quasi_quote_flavour :: UntypedSpliceFlavour+    }+++pprTypedSplice :: forall p . (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc+pprTypedSplice n (HsTypedSpliceExpr _ e) = ppr_splice (text "$$") n e+pprTypedSplice n (XTypedSplice p) =+  case ghcPass @p of+    GhcRn -> case p of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid <+> whenPprDebug (maybe empty (brackets . ppr) n)++pprUntypedSplice :: forall p. (OutputableBndrId p)+                 => Bool -- Whether to precede the splice with "$"+                 -> Maybe SplicePointName -- Used for pretty printing when exists+                 -> HsUntypedSplice (GhcPass p)+                 -> SDoc+pprUntypedSplice True  n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e+pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e+pprUntypedSplice _     _ (HsQuasiQuote _ q s)      = ppr_quasi (unLoc q) (unLoc s)+pprUntypedSplice _     _ (XUntypedSplice x) =+  case ghcPass @p of+    GhcRn -> case x of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid++ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc+ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <>+                           ppr quote <> text "|]"++ppr_splice :: (OutputableBndrId p)+           => SDoc+           -> Maybe SplicePointName+           -> LHsExpr (GhcPass p)+           -> SDoc+ppr_splice herald mn e+    = herald+    <> (case mn of+         Nothing -> empty+         Just splice_name -> whenPprDebug (brackets (ppr splice_name)))+    <> ppr e+++type instance XExpBr  GhcPs       = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧")+type instance XPatBr  GhcPs       = (EpToken "[p|", EpUniToken "|]" "⟧")+type instance XDecBrL GhcPs       = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}"))+type instance XDecBrG GhcPs       = NoExtField+type instance XTypBr  GhcPs       = (EpToken "[t|", EpUniToken "|]" "⟧")+type instance XVarBr  GhcPs       = EpaLocation+type instance XXQuote GhcPs       = DataConCantHappen++type instance XExpBr  GhcRn       = NoExtField+type instance XPatBr  GhcRn       = NoExtField+type instance XDecBrL GhcRn       = NoExtField+type instance XDecBrG GhcRn       = NoExtField+type instance XTypBr  GhcRn       = NoExtField+type instance XVarBr  GhcRn       = NoExtField+type instance XXQuote GhcRn       = DataConCantHappen++-- See Note [The life cycle of a TH quotation]+type instance XExpBr  GhcTc       = DataConCantHappen+type instance XPatBr  GhcTc       = DataConCantHappen+type instance XDecBrL GhcTc       = DataConCantHappen+type instance XDecBrG GhcTc       = DataConCantHappen+type instance XTypBr  GhcTc       = DataConCantHappen+type instance XVarBr  GhcTc       = DataConCantHappen+type instance XXQuote GhcTc       = NoExtField++instance OutputableBndrId p+          => Outputable (HsQuote (GhcPass p)) where+  ppr = pprHsQuote+    where+      pprHsQuote :: forall p. (OutputableBndrId p)+                   => HsQuote (GhcPass p) -> SDoc+      pprHsQuote (ExpBr _ e)   = thBrackets empty (ppr e)+      pprHsQuote (PatBr _ p)   = thBrackets (char 'p') (ppr p)+      pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)+      pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))+      pprHsQuote (TypBr _ t)   = thBrackets (char 't') (ppr t)+      pprHsQuote (VarBr _ True n)+        = char '\'' <> pprPrefixOcc (unLoc n)+      pprHsQuote (VarBr _ False n)+        = text "''" <> pprPrefixOcc (unLoc n)+      pprHsQuote (XQuote b)  = case ghcPass @p of+          GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)+                   -- See Note [The life cycle of a TH quotation]++thBrackets :: SDoc -> SDoc -> SDoc+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>+                             pp_body <+> text "|]"++thTyBrackets :: SDoc -> SDoc+thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"++instance Outputable PendingTcSplice where+  ppr (PendingTcSplice n e) = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))++ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc+ppr_with_pending_tc_splices x [] = x+ppr_with_pending_tc_splices x ps = x $$ whenPprDebug (text "pending(tc)" <+> ppr ps)++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p+         => Outputable (ArithSeqInfo (GhcPass p)) where+    ppr (From e1)             = hcat [ppr e1, pp_dotdot]+    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]+    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]+    ppr (FromThenTo e1 e2 e3)+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]++pp_dotdot :: SDoc+pp_dotdot = text " .. "++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++type HsMatchContextPs = HsMatchContext (LIdP GhcPs)+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)++type HsStmtContextRn = HsStmtContext (LIdP GhcRn)++instance Outputable fn => Outputable (HsMatchContext fn) where+  ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr CaseAlt                 = text "CaseAlt"+  ppr (LamAlt lam_variant)    = text "LamAlt" <+> ppr lam_variant+  ppr IfAlt                   = text "IfAlt"+  ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c+  ppr PatBindRhs              = text "PatBindRhs"+  ppr PatBindGuards           = text "PatBindGuards"+  ppr RecUpd                  = text "RecUpd"+  ppr (StmtCtxt _)            = text "StmtCtxt _"+  ppr ThPatSplice             = text "ThPatSplice"+  ppr ThPatQuote              = text "ThPatQuote"+  ppr PatSyn                  = text "PatSyn"+  ppr LazyPatCtx              = text "LazyPatCtx"++instance Outputable HsLamVariant where+  ppr = text . \case+    LamSingle -> "LamSingle"+    LamCase   -> "LamCase"+    LamCases  -> "LamCases"++lamCaseKeyword :: HsLamVariant -> SDoc+lamCaseKeyword LamSingle = text "lambda"+lamCaseKeyword LamCase   = text "\\case"+lamCaseKeyword LamCases  = text "\\cases"++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))+  = ppr (src,(n1,n2),(n3,n4))++instance Outputable HsArrowMatchContext where+  ppr ProcExpr                  = text "ProcExpr"+  ppr ArrowCaseAlt              = text "ArrowCaseAlt"+  ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant++pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp  = text "first order arrow application"++-----------------++instance Outputable fn => Outputable (HsStmtContext fn) where+    ppr = pprStmtContext++-- Used to generate the string for a *runtime* error message+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc+matchContextErrString (FunRhs{mc_fun=fun})          = text "function" <+> ppr fun+matchContextErrString CaseAlt                       = text "case"+matchContextErrString (LamAlt lam_variant)          = lamCaseKeyword lam_variant+matchContextErrString IfAlt                         = text "multi-way if"+matchContextErrString PatBindRhs                    = text "pattern binding"+matchContextErrString PatBindGuards                 = text "pattern binding guards"+matchContextErrString RecUpd                        = text "record update"+matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c+matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString PatSyn                        = text "pattern synonym"+matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"+matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour+matchContextErrString LazyPatCtx                    = text "irrefutable pattern"++matchArrowContextErrString :: HsArrowMatchContext -> SDoc+matchArrowContextErrString ProcExpr                  = text "proc"+matchArrowContextErrString ArrowCaseAlt              = text "case"+matchArrowContextErrString (ArrowLamAlt LamSingle)   = text "kappa"+matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant++matchDoContextErrString :: HsDoFlavour -> SDoc+matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"+matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")+matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")+matchDoContextErrString ListComp     = text "list comprehension"+matchDoContextErrString MonadComp    = text "monad comprehension"++pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)+               => Match (GhcPass idR) body -> SDoc+pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)+                                        <> colon)+                             4 (pprMatch match)++pprStmtInCtxt :: (OutputableBndrId idL,+                  OutputableBndrId idR,+                  Outputable fn,+                  Outputable body,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)+              => HsStmtContext fn+              -> StmtLR (GhcPass idL) (GhcPass idR) body+              -> SDoc+pprStmtInCtxt ctxt (LastStmt _ e _ _)+  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"+  = hang (text "In the expression:") 2 (ppr e)++pprStmtInCtxt ctxt stmt+  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)+       2 (ppr_stmt stmt)+  where+    -- For Group and Transform Stmts, don't print the nested stmts!+    ppr_stmt (TransStmt { trS_by = by, trS_using = using+                        , trS_form = form }) = pprTransStmt by using form+    ppr_stmt stmt = pprStmt stmt+++pprMatchContext :: Outputable p => HsMatchContext p -> SDoc+pprMatchContext ctxt+  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt+  where+    want_an (FunRhs {})                              = True  -- Use "an" in front+    want_an (ArrowMatchCtxt ProcExpr)                = True+    want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True+    want_an LazyPatCtx                               = True+    want_an _                                        = False++pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for" <+> quotes (ppr fun)+pprMatchContextNoun CaseAlt                 = text "case alternative"+pprMatchContextNoun (LamAlt LamSingle)      = text "lambda abstraction"+pprMatchContextNoun (LamAlt lam_variant)    = lamCaseKeyword lam_variant+                                              <+> text "alternative"+pprMatchContextNoun IfAlt                   = text "multi-way if alternative"+pprMatchContextNoun RecUpd                  = text "record update"+pprMatchContextNoun ThPatSplice             = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs              = text "pattern binding"+pprMatchContextNoun PatBindGuards           = text "pattern binding guards"+pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"+                                              $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"+pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern"++pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for" <+> quotes (ppr fun)+pprMatchContextNouns PatBindGuards           = text "pattern binding guards"+pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c+pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"+                                               $$ pprAStmtContext ctxt+pprMatchContextNouns ctxt                    = pprMatchContextNoun ctxt <> char 's'++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"+pprArrowMatchContextNoun (ArrowLamAlt LamSingle)   = text "arrow kappa abstraction"+pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                     <+> text "alternative within arrow notation"++pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNouns ArrowCaseAlt              = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamAlt LamSingle)   = text "arrow kappa abstractions"+pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                      <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt                      = pprArrowMatchContextNoun ctxt <> char 's'++-----------------+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt++-----------------+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"++-- Drop the inner contexts when reporting errors, else we get+--     Unexpected transform statement+--     in a transformed branch of+--          transformed branch of+--          transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])+             (pprStmtContext c)+pprStmtContext (TransStmtCtxt c) =+  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])+             (pprStmtContext c)++pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) 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 (XStmtLR _)          = text "applicative"++pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour+  where+    pp_an = text "an"+    pp_a  = text "a"+    article = case flavour of+                  MDoExpr Nothing -> pp_an+                  GhciStmtCtxt  -> pp_an+                  _             -> pp_a+pprHsDoFlavour (DoExpr m)      = prependQualified m (text "'do' block")+pprHsDoFlavour (MDoExpr m)     = prependQualified m (text "'mdo' block")+pprHsDoFlavour ListComp        = text "list comprehension"+pprHsDoFlavour MonadComp       = text "monad comprehension"+pprHsDoFlavour GhciStmtCtxt    = text "interactive GHCi command"++prependQualified :: Maybe ModuleName -> SDoc -> SDoc+prependQualified Nothing  t = t+prependQualified (Just _) t = text "qualified" <+> t++{-+************************************************************************+*                                                                      *+FieldLabelStrings+*                                                                      *+************************************************************************+-}++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where+  ppr (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where+  pprInfixOcc = pprFieldLabelStrings+  pprPrefixOcc = pprFieldLabelStrings++instance (UnXRec p,  Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where+  pprInfixOcc = pprInfixOcc . unLoc+  pprPrefixOcc = pprInfixOcc . unLoc++pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc+pprFieldLabelStrings (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++pprPrefixFastString :: FastString -> SDoc+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)++instance UnXRec p => Outputable (DotFieldOcc p) where+  ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s+  ppr XDotFieldOcc{} = text "XDotFieldOcc"++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA+type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnLW+type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA+type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA+type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = EpAnnCO+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA++type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO+type instance Anno FieldLabelString                = SrcSpanAnnN++type instance Anno FastString                      = EpAnnCO+  -- Used in HsQuasiQuote and perhaps elsewhere++type instance Anno (DotFieldOcc (GhcPass p))       = EpAnnCO++instance (HasAnnotation (Anno a))+   => WrapXRec (GhcPass p) a where+  wrapXRec = noLocA
GHC/Hs/Expr.hs-boot view
@@ -1,52 +1,54 @@-{-# LANGUAGE CPP, KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ module GHC.Hs.Expr where -import SrcLoc     ( Located )-import Outputable ( SDoc, Outputable )-import {-# SOURCE #-} GHC.Hs.Pat  ( LPat )-import BasicTypes ( SpliceExplicitFlag(..))+import GHC.Utils.Outputable ( SDoc, Outputable )+import Language.Haskell.Syntax.Pat ( LPat )+import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable+import Language.Haskell.Syntax.Expr+  ( HsExpr, LHsExpr+  , HsCmd+  , MatchGroup+  , GRHSs+  , HsUntypedSplice+  , HsTypedSplice+  ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass )--type role HsExpr nominal-type role HsCmd nominal-type role MatchGroup nominal nominal-type role GRHSs nominal nominal-type role HsSplice nominal-type role SyntaxExpr nominal-data HsExpr (i :: *)-data HsCmd  (i :: *)-data HsSplice (i :: *)-data MatchGroup (a :: *) (body :: *)-data GRHSs (a :: *) (body :: *)-data SyntaxExpr (i :: *)+import GHC.Types.Name   ( Name )+import Data.Bool  ( Bool )+import Data.Maybe ( Maybe ) -instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))-instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))+type SplicePointName = Name -type LHsExpr a = Located (HsExpr a)+instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p))+instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p))  pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc  pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc+pprTypedSplice   :: (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc+pprUntypedSplice :: (OutputableBndrId p) => Bool -> Maybe SplicePointName -> HsUntypedSplice (GhcPass p) -> SDoc -pprSpliceDecl ::  (OutputableBndrId p)-          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc -pprPatBind :: forall bndr p body. (OutputableBndrId bndr,-                                   OutputableBndrId p,-                                   Outputable body)-           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc -pprFunBind :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc+data ThModFinalizers+type role HsUntypedSpliceResult representational+data HsUntypedSpliceResult thing+  = HsUntypedSpliceTop+      { utsplice_result_finalizers :: ThModFinalizers+      , utsplice_result            :: thing+      }+  | HsUntypedSpliceNested SplicePointName
GHC/Hs/Extension.hs view
@@ -1,1181 +1,268 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder--module GHC.Hs.Extension where---- This module captures the type families to precisely identify the extension--- points for GHC.Hs syntax--import GhcPrelude--import Data.Data hiding ( Fixity )-import GHC.Hs.PlaceHolder-import Name-import RdrName-import Var-import Outputable-import SrcLoc (Located)--import Data.Kind--{--Note [Trees that grow]-~~~~~~~~~~~~~~~~~~~~~~--See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow--The hsSyn AST is reused across multiple compiler passes. We also have the-Template Haskell AST, and the haskell-src-exts one (outside of GHC)--Supporting multiple passes means the AST has various warts on it to cope with-the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut',-'SigPatOut' etc.--The growable AST will allow each of these variants to be captured explicitly,-such that they only exist in the given compiler pass AST, as selected by the-type parameter to the AST.--In addition it will allow tool writers to define their own extensions to capture-additional information for the tool, in a natural way.--A further goal is to provide a means to harmonise the Template Haskell and-haskell-src-exts ASTs as well.---}---- | A placeholder type for TTG extension points that are not currently--- unused to represent any particular value.------ This should not be confused with 'NoExtCon', which are found in unused--- extension /constructors/ and therefore should never be inhabited. In--- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of--- some constructor), so it must have an inhabitant to construct AST passes--- that manipulate fields with that extension point as their type.-data NoExtField = NoExtField-  deriving (Data,Eq,Ord)--instance Outputable NoExtField where-  ppr _ = text "NoExtField"---- | Used when constructing a term with an unused extension point.-noExtField :: NoExtField-noExtField = NoExtField---- | Used in TTG extension constructors that have yet to be extended with--- anything. If an extension constructor has 'NoExtCon' as its field, it is--- not intended to ever be constructed anywhere, and any function that consumes--- the extension constructor can eliminate it by way of 'noExtCon'.------ This should not be confused with 'NoExtField', which are found in unused--- extension /points/ (not /constructors/) and therefore can be inhabited.---- See also [NoExtCon and strict fields].-data NoExtCon-  deriving (Data,Eq,Ord)--instance Outputable NoExtCon where-  ppr = noExtCon---- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'.-noExtCon :: NoExtCon -> a-noExtCon x = case x of {}--{--Note [NoExtCon and strict fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Currently, any unused TTG extension constructor will generally look like the-following:--  type instance XXHsDecl (GhcPass _) = NoExtCon-  data HsDecl p-    = ...-    | XHsDecl (XXHsDecl p)--This means that any function that wishes to consume an HsDecl will need to-have a case for XHsDecl. This might look like this:--  ex :: HsDecl GhcPs -> HsDecl GhcRn-  ...-  ex (XHsDecl nec) = noExtCon nec--Ideally, we wouldn't need a case for XHsDecl at all (it /is/ supposed to be-an unused extension constructor, after all). There is a way to achieve this-on GHC 8.8 or later: make the field of XHsDecl strict:--  data HsDecl p-    = ...-    | XHsDecl !(XXHsDecl p)--If this is done, GHC's pattern-match coverage checker is clever enough to-figure out that the XHsDecl case of `ex` is unreachable, so it can simply be-omitted. (See Note [Extensions to GADTs Meet Their Match] in Check for more on-how this works.)--When GHC drops support for bootstrapping with GHC 8.6 and earlier, we can make-the strict field changes described above and delete gobs of code involving-`noExtCon`. Until then, it is necessary to use, so be aware of it when writing-code that consumes unused extension constructors.--}---- | Used as a data type index for the hsSyn AST-data GhcPass (c :: Pass)-deriving instance Eq (GhcPass c)-deriving instance Typeable c => Data (GhcPass c)--data Pass = Parsed | Renamed | Typechecked-         deriving (Data)---- Type synonyms as a shorthand for tagging-type GhcPs   = GhcPass 'Parsed      -- Old 'RdrName' type param-type GhcRn   = GhcPass 'Renamed     -- Old 'Name' type param-type GhcTc   = GhcPass 'Typechecked -- Old 'Id' type para,-type GhcTcId = GhcTc                -- Old 'TcId' type param---- | GHC's L prefixed variants wrap their vanilla variant in this type family,--- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not--- interested in location information can define this instance as @f p@.-type family XRec p (f :: * -> *) = r | r -> p f-type instance XRec (GhcPass p) f = Located (f (GhcPass p))---- | Maps the "normal" id type for a given pass-type family IdP p-type instance IdP GhcPs = RdrName-type instance IdP GhcRn = Name-type instance IdP GhcTc = Id--type LIdP p = Located (IdP p)---- | Marks that a field uses the GhcRn variant even when the pass--- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because--- HsType GhcTc should never occur.-type family NoGhcTc (p :: Type) where-    -- this way, GHC can figure out that the result is a GhcPass-  NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)-  NoGhcTc other          = other--type family NoGhcTcPass (p :: Pass) :: Pass where-  NoGhcTcPass 'Typechecked = 'Renamed-  NoGhcTcPass other        = other---- =====================================================================--- Type families for the HsBinds extension points---- HsLocalBindsLR type families-type family XHsValBinds      x x'-type family XHsIPBinds       x x'-type family XEmptyLocalBinds x x'-type family XXHsLocalBindsLR x x'--type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =-       ( c (XHsValBinds      x x')-       , c (XHsIPBinds       x x')-       , c (XEmptyLocalBinds x x')-       , c (XXHsLocalBindsLR x x')-       )---- ValBindsLR type families-type family XValBinds    x x'-type family XXValBindsLR x x'--type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =-       ( c (XValBinds    x x')-       , c (XXValBindsLR x x')-       )----- HsBindsLR type families-type family XFunBind    x x'-type family XPatBind    x x'-type family XVarBind    x x'-type family XAbsBinds   x x'-type family XPatSynBind x x'-type family XXHsBindsLR x x'--type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) =-       ( c (XFunBind    x x')-       , c (XPatBind    x x')-       , c (XVarBind    x x')-       , c (XAbsBinds   x x')-       , c (XPatSynBind x x')-       , c (XXHsBindsLR x x')-       )---- ABExport type families-type family XABE x-type family XXABExport x--type ForallXABExport (c :: * -> Constraint) (x :: *) =-       ( c (XABE       x)-       , c (XXABExport x)-       )---- PatSynBind type families-type family XPSB x x'-type family XXPatSynBind x x'--type ForallXPatSynBind  (c :: * -> Constraint) (x :: *) (x' :: *) =-       ( c (XPSB         x x')-       , c (XXPatSynBind x x')-       )---- HsIPBinds type families-type family XIPBinds    x-type family XXHsIPBinds x--type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) =-       ( c (XIPBinds    x)-       , c (XXHsIPBinds x)-       )---- IPBind type families-type family XCIPBind x-type family XXIPBind x--type ForallXIPBind (c :: * -> Constraint) (x :: *) =-       ( c (XCIPBind x)-       , c (XXIPBind x)-       )---- Sig type families-type family XTypeSig          x-type family XPatSynSig        x-type family XClassOpSig       x-type family XIdSig            x-type family XFixSig           x-type family XInlineSig        x-type family XSpecSig          x-type family XSpecInstSig      x-type family XMinimalSig       x-type family XSCCFunSig        x-type family XCompleteMatchSig x-type family XXSig             x--type ForallXSig (c :: * -> Constraint) (x :: *) =-       ( c (XTypeSig          x)-       , c (XPatSynSig        x)-       , c (XClassOpSig       x)-       , c (XIdSig            x)-       , c (XFixSig           x)-       , c (XInlineSig        x)-       , c (XSpecSig          x)-       , c (XSpecInstSig      x)-       , c (XMinimalSig       x)-       , c (XSCCFunSig        x)-       , c (XCompleteMatchSig x)-       , c (XXSig             x)-       )---- FixitySig type families-type family XFixitySig          x-type family XXFixitySig         x--type ForallXFixitySig (c :: * -> Constraint) (x :: *) =-       ( c (XFixitySig         x)-       , c (XXFixitySig        x)-       )---- StandaloneKindSig type families-type family XStandaloneKindSig  x-type family XXStandaloneKindSig x---- =====================================================================--- Type families for the HsDecls extension points---- HsDecl type families-type family XTyClD       x-type family XInstD       x-type family XDerivD      x-type family XValD        x-type family XSigD        x-type family XKindSigD    x-type family XDefD        x-type family XForD        x-type family XWarningD    x-type family XAnnD        x-type family XRuleD       x-type family XSpliceD     x-type family XDocD        x-type family XRoleAnnotD  x-type family XXHsDecl     x--type ForallXHsDecl (c :: * -> Constraint) (x :: *) =-       ( c (XTyClD       x)-       , c (XInstD       x)-       , c (XDerivD      x)-       , c (XValD        x)-       , c (XSigD        x)-       , c (XKindSigD    x)-       , c (XDefD        x)-       , c (XForD        x)-       , c (XWarningD    x)-       , c (XAnnD        x)-       , c (XRuleD       x)-       , c (XSpliceD     x)-       , c (XDocD        x)-       , c (XRoleAnnotD  x)-       , c (XXHsDecl    x)-       )---- ---------------------------------------- HsGroup type families-type family XCHsGroup      x-type family XXHsGroup      x--type ForallXHsGroup (c :: * -> Constraint) (x :: *) =-       ( c (XCHsGroup       x)-       , c (XXHsGroup       x)-       )---- ---------------------------------------- SpliceDecl type families-type family XSpliceDecl       x-type family XXSpliceDecl      x--type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) =-       ( c (XSpliceDecl        x)-       , c (XXSpliceDecl       x)-       )---- ---------------------------------------- TyClDecl type families-type family XFamDecl       x-type family XSynDecl       x-type family XDataDecl      x-type family XClassDecl     x-type family XXTyClDecl     x--type ForallXTyClDecl (c :: * -> Constraint) (x :: *) =-       ( c (XFamDecl       x)-       , c (XSynDecl       x)-       , c (XDataDecl      x)-       , c (XClassDecl     x)-       , c (XXTyClDecl     x)-       )---- ---------------------------------------- TyClGroup type families-type family XCTyClGroup      x-type family XXTyClGroup      x--type ForallXTyClGroup (c :: * -> Constraint) (x :: *) =-       ( c (XCTyClGroup       x)-       , c (XXTyClGroup       x)-       )---- ---------------------------------------- FamilyResultSig type families-type family XNoSig            x-type family XCKindSig         x -- Clashes with XKindSig above-type family XTyVarSig         x-type family XXFamilyResultSig x--type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) =-       ( c (XNoSig            x)-       , c (XCKindSig         x)-       , c (XTyVarSig         x)-       , c (XXFamilyResultSig x)-       )---- ---------------------------------------- FamilyDecl type families-type family XCFamilyDecl      x-type family XXFamilyDecl      x--type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCFamilyDecl       x)-       , c (XXFamilyDecl       x)-       )---- ---------------------------------------- HsDataDefn type families-type family XCHsDataDefn      x-type family XXHsDataDefn      x--type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) =-       ( c (XCHsDataDefn       x)-       , c (XXHsDataDefn       x)-       )---- ---------------------------------------- HsDerivingClause type families-type family XCHsDerivingClause      x-type family XXHsDerivingClause      x--type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) =-       ( c (XCHsDerivingClause       x)-       , c (XXHsDerivingClause       x)-       )---- ---------------------------------------- ConDecl type families-type family XConDeclGADT   x-type family XConDeclH98    x-type family XXConDecl      x--type ForallXConDecl (c :: * -> Constraint) (x :: *) =-       ( c (XConDeclGADT    x)-       , c (XConDeclH98     x)-       , c (XXConDecl       x)-       )---- ---------------------------------------- FamEqn type families-type family XCFamEqn      x r-type family XXFamEqn      x r--type ForallXFamEqn (c :: * -> Constraint) (x :: *) (r :: *) =-       ( c (XCFamEqn       x r)-       , c (XXFamEqn       x r)-       )---- ---------------------------------------- ClsInstDecl type families-type family XCClsInstDecl      x-type family XXClsInstDecl      x--type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCClsInstDecl       x)-       , c (XXClsInstDecl       x)-       )---- ---------------------------------------- ClsInstDecl type families-type family XClsInstD      x-type family XDataFamInstD  x-type family XTyFamInstD    x-type family XXInstDecl     x--type ForallXInstDecl (c :: * -> Constraint) (x :: *) =-       ( c (XClsInstD       x)-       , c (XDataFamInstD   x)-       , c (XTyFamInstD     x)-       , c (XXInstDecl      x)-       )---- ---------------------------------------- DerivDecl type families-type family XCDerivDecl      x-type family XXDerivDecl      x--type ForallXDerivDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCDerivDecl       x)-       , c (XXDerivDecl       x)-       )---- ---------------------------------------- DerivStrategy type family-type family XViaStrategy x---- ---------------------------------------- DefaultDecl type families-type family XCDefaultDecl      x-type family XXDefaultDecl      x--type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCDefaultDecl       x)-       , c (XXDefaultDecl       x)-       )---- ---------------------------------------- DefaultDecl type families-type family XForeignImport     x-type family XForeignExport     x-type family XXForeignDecl      x--type ForallXForeignDecl (c :: * -> Constraint) (x :: *) =-       ( c (XForeignImport      x)-       , c (XForeignExport      x)-       , c (XXForeignDecl       x)-       )---- ---------------------------------------- RuleDecls type families-type family XCRuleDecls      x-type family XXRuleDecls      x--type ForallXRuleDecls (c :: * -> Constraint) (x :: *) =-       ( c (XCRuleDecls       x)-       , c (XXRuleDecls       x)-       )----- ---------------------------------------- RuleDecl type families-type family XHsRule          x-type family XXRuleDecl       x--type ForallXRuleDecl (c :: * -> Constraint) (x :: *) =-       ( c (XHsRule           x)-       , c (XXRuleDecl        x)-       )---- ---------------------------------------- RuleBndr type families-type family XCRuleBndr      x-type family XRuleBndrSig    x-type family XXRuleBndr      x--type ForallXRuleBndr (c :: * -> Constraint) (x :: *) =-       ( c (XCRuleBndr       x)-       , c (XRuleBndrSig     x)-       , c (XXRuleBndr       x)-       )---- ---------------------------------------- WarnDecls type families-type family XWarnings        x-type family XXWarnDecls      x--type ForallXWarnDecls (c :: * -> Constraint) (x :: *) =-       ( c (XWarnings        x)-       , c (XXWarnDecls      x)-       )---- ---------------------------------------- AnnDecl type families-type family XWarning        x-type family XXWarnDecl      x--type ForallXWarnDecl (c :: * -> Constraint) (x :: *) =-       ( c (XWarning        x)-       , c (XXWarnDecl      x)-       )---- ---------------------------------------- AnnDecl type families-type family XHsAnnotation  x-type family XXAnnDecl      x--type ForallXAnnDecl (c :: * -> Constraint) (x :: *) =-       ( c (XHsAnnotation  x)-       , c (XXAnnDecl      x)-       )---- ---------------------------------------- RoleAnnotDecl type families-type family XCRoleAnnotDecl  x-type family XXRoleAnnotDecl  x--type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCRoleAnnotDecl  x)-       , c (XXRoleAnnotDecl  x)-       )---- =====================================================================--- Type families for the HsExpr extension points--type family XVar            x-type family XUnboundVar     x-type family XConLikeOut     x-type family XRecFld         x-type family XOverLabel      x-type family XIPVar          x-type family XOverLitE       x-type family XLitE           x-type family XLam            x-type family XLamCase        x-type family XApp            x-type family XAppTypeE       x-type family XOpApp          x-type family XNegApp         x-type family XPar            x-type family XSectionL       x-type family XSectionR       x-type family XExplicitTuple  x-type family XExplicitSum    x-type family XCase           x-type family XIf             x-type family XMultiIf        x-type family XLet            x-type family XDo             x-type family XExplicitList   x-type family XRecordCon      x-type family XRecordUpd      x-type family XExprWithTySig  x-type family XArithSeq       x-type family XSCC            x-type family XCoreAnn        x-type family XBracket        x-type family XRnBracketOut   x-type family XTcBracketOut   x-type family XSpliceE        x-type family XProc           x-type family XStatic         x-type family XTick           x-type family XBinTick        x-type family XTickPragma     x-type family XWrap           x-type family XXExpr          x--type ForallXExpr (c :: * -> Constraint) (x :: *) =-       ( c (XVar            x)-       , c (XUnboundVar     x)-       , c (XConLikeOut     x)-       , c (XRecFld         x)-       , c (XOverLabel      x)-       , c (XIPVar          x)-       , c (XOverLitE       x)-       , c (XLitE           x)-       , c (XLam            x)-       , c (XLamCase        x)-       , c (XApp            x)-       , c (XAppTypeE       x)-       , c (XOpApp          x)-       , c (XNegApp         x)-       , c (XPar            x)-       , c (XSectionL       x)-       , c (XSectionR       x)-       , c (XExplicitTuple  x)-       , c (XExplicitSum    x)-       , c (XCase           x)-       , c (XIf             x)-       , c (XMultiIf        x)-       , c (XLet            x)-       , c (XDo             x)-       , c (XExplicitList   x)-       , c (XRecordCon      x)-       , c (XRecordUpd      x)-       , c (XExprWithTySig  x)-       , c (XArithSeq       x)-       , c (XSCC            x)-       , c (XCoreAnn        x)-       , c (XBracket        x)-       , c (XRnBracketOut   x)-       , c (XTcBracketOut   x)-       , c (XSpliceE        x)-       , c (XProc           x)-       , c (XStatic         x)-       , c (XTick           x)-       , c (XBinTick        x)-       , c (XTickPragma     x)-       , c (XWrap           x)-       , c (XXExpr          x)-       )--- -----------------------------------------------------------------------type family XUnambiguous        x-type family XAmbiguous          x-type family XXAmbiguousFieldOcc x--type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =-       ( c (XUnambiguous        x)-       , c (XAmbiguous          x)-       , c (XXAmbiguousFieldOcc x)-       )---- ------------------------------------------------------------------------type family XPresent  x-type family XMissing  x-type family XXTupArg  x--type ForallXTupArg (c :: * -> Constraint) (x :: *) =-       ( c (XPresent x)-       , c (XMissing x)-       , c (XXTupArg x)-       )---- -----------------------------------------------------------------------type family XTypedSplice   x-type family XUntypedSplice x-type family XQuasiQuote    x-type family XSpliced       x-type family XXSplice       x--type ForallXSplice (c :: * -> Constraint) (x :: *) =-       ( c (XTypedSplice   x)-       , c (XUntypedSplice x)-       , c (XQuasiQuote    x)-       , c (XSpliced       x)-       , c (XXSplice       x)-       )---- -----------------------------------------------------------------------type family XExpBr      x-type family XPatBr      x-type family XDecBrL     x-type family XDecBrG     x-type family XTypBr      x-type family XVarBr      x-type family XTExpBr     x-type family XXBracket   x--type ForallXBracket (c :: * -> Constraint) (x :: *) =-       ( c (XExpBr      x)-       , c (XPatBr      x)-       , c (XDecBrL     x)-       , c (XDecBrG     x)-       , c (XTypBr      x)-       , c (XVarBr      x)-       , c (XTExpBr     x)-       , c (XXBracket   x)-       )---- -----------------------------------------------------------------------type family XCmdTop  x-type family XXCmdTop x--type ForallXCmdTop (c :: * -> Constraint) (x :: *) =-       ( c (XCmdTop  x)-       , c (XXCmdTop x)-       )---- ---------------------------------------type family XMG           x b-type family XXMatchGroup  x b--type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XMG          x b)-       , c (XXMatchGroup x b)-       )---- ---------------------------------------type family XCMatch  x b-type family XXMatch  x b--type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XCMatch  x b)-       , c (XXMatch  x b)-       )---- ---------------------------------------type family XCGRHSs  x b-type family XXGRHSs  x b--type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XCGRHSs  x b)-       , c (XXGRHSs  x b)-       )---- ---------------------------------------type family XCGRHS  x b-type family XXGRHS  x b--type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XCGRHS  x b)-       , c (XXGRHS  x b)-       )---- ---------------------------------------type family XLastStmt        x x' b-type family XBindStmt        x x' b-type family XApplicativeStmt x x' b-type family XBodyStmt        x x' b-type family XLetStmt         x x' b-type family XParStmt         x x' b-type family XTransStmt       x x' b-type family XRecStmt         x x' b-type family XXStmtLR         x x' b--type ForallXStmtLR (c :: * -> Constraint) (x :: *)  (x' :: *) (b :: *) =-       ( c (XLastStmt         x x' b)-       , c (XBindStmt         x x' b)-       , c (XApplicativeStmt  x x' b)-       , c (XBodyStmt         x x' b)-       , c (XLetStmt          x x' b)-       , c (XParStmt          x x' b)-       , c (XTransStmt        x x' b)-       , c (XRecStmt          x x' b)-       , c (XXStmtLR          x x' b)-       )---- -----------------------------------------------------------------------type family XCmdArrApp  x-type family XCmdArrForm x-type family XCmdApp     x-type family XCmdLam     x-type family XCmdPar     x-type family XCmdCase    x-type family XCmdIf      x-type family XCmdLet     x-type family XCmdDo      x-type family XCmdWrap    x-type family XXCmd       x--type ForallXCmd (c :: * -> Constraint) (x :: *) =-       ( c (XCmdArrApp  x)-       , c (XCmdArrForm x)-       , c (XCmdApp     x)-       , c (XCmdLam     x)-       , c (XCmdPar     x)-       , c (XCmdCase    x)-       , c (XCmdIf      x)-       , c (XCmdLet     x)-       , c (XCmdDo      x)-       , c (XCmdWrap    x)-       , c (XXCmd       x)-       )---- -----------------------------------------------------------------------type family XParStmtBlock  x x'-type family XXParStmtBlock x x'--type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) =-       ( c (XParStmtBlock  x x')-       , c (XXParStmtBlock x x')-       )---- -----------------------------------------------------------------------type family XApplicativeArgOne   x-type family XApplicativeArgMany  x-type family XXApplicativeArg     x--type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) =-       ( c (XApplicativeArgOne   x)-       , c (XApplicativeArgMany  x)-       , c (XXApplicativeArg     x)-       )---- =====================================================================--- Type families for the HsImpExp extension points---- TODO---- =====================================================================--- Type families for the HsLit extension points---- We define a type family for each extension point. This is based on prepending--- 'X' to the constructor name, for ease of reference.-type family XHsChar x-type family XHsCharPrim x-type family XHsString x-type family XHsStringPrim x-type family XHsInt x-type family XHsIntPrim x-type family XHsWordPrim x-type family XHsInt64Prim x-type family XHsWord64Prim x-type family XHsInteger x-type family XHsRat x-type family XHsFloatPrim x-type family XHsDoublePrim x-type family XXLit x---- | Helper to apply a constraint to all extension points. It has one--- entry per extension point type family.-type ForallXHsLit (c :: * -> Constraint) (x :: *) =-  ( c (XHsChar       x)-  , c (XHsCharPrim   x)-  , c (XHsDoublePrim x)-  , c (XHsFloatPrim  x)-  , c (XHsInt        x)-  , c (XHsInt64Prim  x)-  , c (XHsIntPrim    x)-  , c (XHsInteger    x)-  , c (XHsRat        x)-  , c (XHsString     x)-  , c (XHsStringPrim x)-  , c (XHsWord64Prim x)-  , c (XHsWordPrim   x)-  , c (XXLit         x)-  )--type family XOverLit  x-type family XXOverLit x--type ForallXOverLit (c :: * -> Constraint) (x :: *) =-       ( c (XOverLit  x)-       , c (XXOverLit x)-       )---- =====================================================================--- Type families for the HsPat extension points--type family XWildPat   x-type family XVarPat    x-type family XLazyPat   x-type family XAsPat     x-type family XParPat    x-type family XBangPat   x-type family XListPat   x-type family XTuplePat  x-type family XSumPat    x-type family XConPat    x-type family XViewPat   x-type family XSplicePat x-type family XLitPat    x-type family XNPat      x-type family XNPlusKPat x-type family XSigPat    x-type family XCoPat     x-type family XXPat      x---type ForallXPat (c :: * -> Constraint) (x :: *) =-       ( c (XWildPat   x)-       , c (XVarPat    x)-       , c (XLazyPat   x)-       , c (XAsPat     x)-       , c (XParPat    x)-       , c (XBangPat   x)-       , c (XListPat   x)-       , c (XTuplePat  x)-       , c (XSumPat    x)-       , c (XViewPat   x)-       , c (XSplicePat x)-       , c (XLitPat    x)-       , c (XNPat      x)-       , c (XNPlusKPat x)-       , c (XSigPat    x)-       , c (XCoPat     x)-       , c (XXPat      x)-       )---- =====================================================================--- Type families for the HsTypes type families--type family XHsQTvs       x-type family XXLHsQTyVars  x--type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) =-       ( c (XHsQTvs       x)-       , c (XXLHsQTyVars  x)-       )---- ---------------------------------------type family XHsIB              x b-type family XXHsImplicitBndrs  x b--type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XHsIB              x b)-       , c (XXHsImplicitBndrs  x b)-       )---- ---------------------------------------type family XHsWC              x b-type family XXHsWildCardBndrs  x b--type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) =-       ( c (XHsWC              x b)-       , c (XXHsWildCardBndrs  x b)-       )---- ---------------------------------------type family XForAllTy        x-type family XQualTy          x-type family XTyVar           x-type family XAppTy           x-type family XAppKindTy       x-type family XFunTy           x-type family XListTy          x-type family XTupleTy         x-type family XSumTy           x-type family XOpTy            x-type family XParTy           x-type family XIParamTy        x-type family XStarTy          x-type family XKindSig         x-type family XSpliceTy        x-type family XDocTy           x-type family XBangTy          x-type family XRecTy           x-type family XExplicitListTy  x-type family XExplicitTupleTy x-type family XTyLit           x-type family XWildCardTy      x-type family XXType           x---- | Helper to apply a constraint to all extension points. It has one--- entry per extension point type family.-type ForallXType (c :: * -> Constraint) (x :: *) =-       ( c (XForAllTy        x)-       , c (XQualTy          x)-       , c (XTyVar           x)-       , c (XAppTy           x)-       , c (XAppKindTy       x)-       , c (XFunTy           x)-       , c (XListTy          x)-       , c (XTupleTy         x)-       , c (XSumTy           x)-       , c (XOpTy            x)-       , c (XParTy           x)-       , c (XIParamTy        x)-       , c (XStarTy          x)-       , c (XKindSig         x)-       , c (XSpliceTy        x)-       , c (XDocTy           x)-       , c (XBangTy          x)-       , c (XRecTy           x)-       , c (XExplicitListTy  x)-       , c (XExplicitTupleTy x)-       , c (XTyLit           x)-       , c (XWildCardTy      x)-       , c (XXType           x)-       )---- -----------------------------------------------------------------------type family XUserTyVar   x-type family XKindedTyVar x-type family XXTyVarBndr  x--type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) =-       ( c (XUserTyVar      x)-       , c (XKindedTyVar    x)-       , c (XXTyVarBndr     x)-       )---- -----------------------------------------------------------------------type family XConDeclField  x-type family XXConDeclField x--type ForallXConDeclField (c :: * -> Constraint) (x :: *) =-       ( c (XConDeclField  x)-       , c (XXConDeclField x)-       )---- -----------------------------------------------------------------------type family XCFieldOcc x-type family XXFieldOcc x--type ForallXFieldOcc (c :: * -> Constraint) (x :: *) =-       ( c (XCFieldOcc x)-       , c (XXFieldOcc x)-       )----- =====================================================================--- Type families for the HsImpExp type families--type family XCImportDecl       x-type family XXImportDecl       x--type ForallXImportDecl (c :: * -> Constraint) (x :: *) =-       ( c (XCImportDecl x)-       , c (XXImportDecl x)-       )---- ---------------------------------------type family XIEVar             x-type family XIEThingAbs        x-type family XIEThingAll        x-type family XIEThingWith       x-type family XIEModuleContents  x-type family XIEGroup           x-type family XIEDoc             x-type family XIEDocNamed        x-type family XXIE               x--type ForallXIE (c :: * -> Constraint) (x :: *) =-       ( c (XIEVar x)-       , c (XIEThingAbs        x)-       , c (XIEThingAll        x)-       , c (XIEThingWith       x)-       , c (XIEModuleContents  x)-       , c (XIEGroup           x)-       , c (XIEDoc             x)-       , c (XIEDocNamed        x)-       , c (XXIE               x)-       )---- ------------------------------------------ =====================================================================--- End of Type family definitions--- =====================================================================---- ------------------------------------------------------------------------- | Conversion of annotations from one type index to another. This is required--- where the AST is converted from one pass to another, and the extension values--- need to be brought along if possible. So for example a 'SourceText' is--- converted via 'id', but needs a type signature to keep the type checker--- happy.-class Convertable a b  | a -> b where-  convert :: a -> b--instance Convertable a a where-  convert = id---- | A constraint capturing all the extension points that can be converted via--- @instance Convertable a a@-type ConvertIdX a b =-  (XHsDoublePrim a ~ XHsDoublePrim b,-   XHsFloatPrim a ~ XHsFloatPrim b,-   XHsRat a ~ XHsRat b,-   XHsInteger a ~ XHsInteger b,-   XHsWord64Prim a ~ XHsWord64Prim b,-   XHsInt64Prim a ~ XHsInt64Prim b,-   XHsWordPrim a ~ XHsWordPrim b,-   XHsIntPrim a ~ XHsIntPrim b,-   XHsInt a ~ XHsInt b,-   XHsStringPrim a ~ XHsStringPrim b,-   XHsString a ~ XHsString b,-   XHsCharPrim a ~ XHsCharPrim b,-   XHsChar a ~ XHsChar b,-   XXLit a ~ XXLit b)---- -------------------------------------------------------------------------- Note [OutputableX]--- ~~~~~~~~~~~~~~~~~~------ is required because the type family resolution--- process cannot determine that all cases are handled for a `GhcPass p`--- case where the cases are listed separately.------ So------   type instance XXHsIPBinds    (GhcPass p) = NoExtCon------ will correctly deduce Outputable for (GhcPass p), but------   type instance XIPBinds       GhcPs = NoExt---   type instance XIPBinds       GhcRn = NoExt---   type instance XIPBinds       GhcTc = TcEvBinds------ will not.----- | Provide a summary constraint that gives all am Outputable constraint to--- extension points needing one-type OutputableX p = -- See Note [OutputableX]-  ( Outputable (XIPBinds    p)-  , Outputable (XViaStrategy p)-  , Outputable (XViaStrategy GhcRn)-  )--- TODO: Should OutputableX be included in OutputableBndrId?---- -------------------------------------------------------------------------- |Constraint type to bundle up the requirement for 'OutputableBndr' on both--- the @p@ and the 'NameOrRdrName' type for it-type OutputableBndrId pass =-  ( OutputableBndr (NameOrRdrName (IdP (GhcPass pass)))-  , OutputableBndr (IdP (GhcPass pass))-  , OutputableBndr (NameOrRdrName (IdP (NoGhcTc (GhcPass pass))))-  , OutputableBndr (IdP (NoGhcTc (GhcPass pass)))-  , NoGhcTc (GhcPass pass) ~ NoGhcTc (NoGhcTc (GhcPass pass))-  , OutputableX (GhcPass pass)-  , OutputableX (NoGhcTc (GhcPass pass))-  )+{-# LANGUAGE AllowAmbiguousTypes     #-}      -- for pprIfTc, etc.+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DeriveDataTypeable      #-}+{-# LANGUAGE EmptyDataDeriving       #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE RankNTypes              #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilyDependencies  #-}+{-# LANGUAGE StandaloneDeriving      #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]+{-# LANGUAGE UndecidableInstances    #-} -- Wrinkle in Note [Trees That Grow]+                                         -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++module GHC.Hs.Extension where++-- This module captures the type families to precisely identify the extension+-- points for GHC.Hs syntax++import GHC.Prelude++import Data.Data hiding ( Fixity )+import Language.Haskell.Syntax.Extension+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Var+import GHC.Utils.Outputable hiding ((<>))+import GHC.Types.SrcLoc (GenLocated(..), unLoc)+import GHC.Utils.Panic+import GHC.Parser.Annotation++{-+Note [IsPass]+~~~~~~~~~~~~~+One challenge with the Trees That Grow approach+is that we sometimes have different information in different passes.+For example, we have++  type instance XViaStrategy GhcPs = LHsSigType GhcPs+  type instance XViaStrategy GhcRn = LHsSigType GhcRn+  type instance XViaStrategy GhcTc = Type++This means that printing a DerivStrategy (which contains an XViaStrategy)+might need to print a LHsSigType, or it might need to print a type. Yet we+want one Outputable instance for a DerivStrategy, instead of one per pass. We+could have a large constraint, including e.g. (Outputable (XViaStrategy p),+Outputable (XViaStrategy GhcTc)), and pass that around in every context where+we might output a DerivStrategy. But a simpler alternative is to pass a+witness to whichever pass we're in. When we pattern-match on that (GADT)+witness, we learn the pass identity and can then print away. To wit, we get+the definition of GhcPass and the functions isPass. These allow us to do away+with big constraints, passing around all manner of dictionaries we might or+might not use. It does mean that we have to manually use isPass when printing,+but these places are few.++See Note [NoGhcTc] about the superclass constraint to IsPass.++Note [NoGhcTc]+~~~~~~~~~~~~~~+An expression is parsed into HsExpr GhcPs, renamed into HsExpr GhcRn, and+then type-checked into HsExpr GhcTc. Not so for types! These get parsed+into HsType GhcPs, renamed into HsType GhcRn, and then type-checked into+Type. We never build an HsType GhcTc. Why do this? Because we need to be+able to compare type-checked types for equality, and we don't want to do+this with HsType.++This causes wrinkles within the AST, where we normally think that the whole+AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we+have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that+user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc.++For example, this is used in ExprWithTySig:+    | ExprWithTySig+                (XExprWithTySig p)++                (LHsExpr p)+                (LHsSigWcType (NoGhcTc p))++If we have (e :: ty), we still want to be able to print that (with the :: ty)+after type-checking. So we retain the LHsSigWcType GhcRn, even in an+HsExpr GhcTc. That's what NoGhcTc does.++When we're printing the type annotation, we need to know+(Outputable (LHsSigWcType GhcRn)), even though we've assumed only that+(OutputableBndrId GhcTc). We thus must be able to prove OutputableBndrId (NoGhcTc p)+from OutputableBndrId p. The extra constraints in OutputableBndrId and+the superclass constraints of IsPass allow this. Note that the superclass+constraint of IsPass is *recursive*: it asserts that IsPass (NoGhcTcPass p) holds.+For this to make sense, we need -XUndecidableSuperClasses and the other constraint,+saying that NoGhcTcPass is idempotent.++-}++-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation+type instance XRec (GhcPass p) a = XRecGhc a++-- (XRecGhc tree) wraps `tree` in a GHC-specific,+-- but pass-independent, source location+type XRecGhc a = GenLocated (Anno a) a++type instance Anno RdrName = SrcSpanAnnN+type instance Anno Name    = SrcSpanAnnN+type instance Anno Id      = SrcSpanAnnN++type instance Anno (WithUserRdr a) = Anno a++type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a,+                          Anno (IdOccGhcP p) ~ EpAnn a,+                          NoAnn a,+                          IsPass p)++instance UnXRec (GhcPass p) where+  unXRec = unLoc+instance MapXRec (GhcPass p) where+  mapXRec = fmap++-- instance WrapXRec (GhcPass p) a where+--   wrapXRec = noLocA++{-+Note [DataConCantHappen and strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, any unused TTG extension constructor will generally look like the+following:++  type instance XXHsDecl (GhcPass _) = DataConCantHappen+  data HsDecl p+    = ...+    | XHsDecl !(XXHsDecl p)++The field of type `XXHsDecl p` is strict for a good reason: it allows the+pattern-match coverage checker to conclude that any matches against XHsDecl+are unreachable whenever `p ~ GhcPass _`. To see why this is the case, consider+the following function which consumes an HsDecl:++  ex :: HsDecl GhcPs -> HsDecl GhcRn+  ...+  ex (XHsDecl nec) = dataConCantHappen nec++Because `p` equals GhcPs (i.e., GhcPass 'Parsed), XHsDecl's field has the type+DataConCantHappen. But since (1) the field is strict and (2) DataConCantHappen+is an empty data type, there is no possible way to reach the right-hand side+of the XHsDecl case. As a result, the coverage checker concludes that+the XHsDecl case is inaccessible, so it can be removed.+(See Note [Strict argument type constraints] in GHC.HsToCore.Pmc.Solver for+more on how this works.)++Bottom line: if you add a TTG extension constructor that uses DataConCantHappen, make+sure that any uses of it as a field are strict.+-}++-- | Used as a data type index for the hsSyn AST; also serves+-- as a singleton type for Pass+data GhcPass (c :: Pass) where+  GhcPs :: GhcPass 'Parsed+  GhcRn :: GhcPass 'Renamed+  GhcTc :: GhcPass 'Typechecked++-- This really should never be entered, but the data-deriving machinery+-- needs the instance to exist.+instance Typeable p => Data (GhcPass p) where+  gunfold _ _ _ = panic "instance Data GhcPass"+  toConstr  _   = panic "instance Data GhcPass"+  dataTypeOf _  = panic "instance Data GhcPass"++data Pass = Parsed | Renamed | Typechecked+         deriving (Data)++-- Type synonyms as a shorthand for tagging+type GhcPs   = GhcPass 'Parsed      -- Output of parser+type GhcRn   = GhcPass 'Renamed     -- Output of renamer+type GhcTc   = GhcPass 'Typechecked -- Output of typechecker++-- | Allows us to check what phase we're in at GHC's runtime.+-- For example, this class allows us to write+--+-- @+-- f :: forall p. IsPass p => HsExpr (GhcPass p) -> blah+-- f e = case ghcPass @p of+--         GhcPs ->    ... in this RHS we have HsExpr GhcPs...+--         GhcRn ->    ... in this RHS we have HsExpr GhcRn...+--         GhcTc ->    ... in this RHS we have HsExpr GhcTc...+-- @+--+-- which is very useful, for example, when pretty-printing.+-- See Note [IsPass].+class ( NoGhcTcPass (NoGhcTcPass p) ~ NoGhcTcPass p+      , IsPass (NoGhcTcPass p)+      ) => IsPass p where+  ghcPass :: GhcPass p++instance IsPass 'Parsed where+  ghcPass = GhcPs+instance IsPass 'Renamed where+  ghcPass = GhcRn+instance IsPass 'Typechecked where+  ghcPass = GhcTc++type instance IdP (GhcPass p) = IdGhcP p++-- | Maps the "normal" id type for a given GHC pass+type family IdGhcP pass where+  IdGhcP 'Parsed      = RdrName+  IdGhcP 'Renamed     = Name+  IdGhcP 'Typechecked = Id++type LIdGhcP p = XRecGhc (IdGhcP p)++type instance IdOccP (GhcPass p) = IdOccGhcP p++type family IdOccGhcP pass where+  IdOccGhcP 'Parsed      = RdrName+  IdOccGhcP 'Renamed     = WithUserRdr Name+  IdOccGhcP 'Typechecked = Id+type LIdOccGhcP p = XRecGhc (IdOccGhcP p)++-- | Marks that a field uses the GhcRn variant even when the pass+-- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because+-- HsType GhcTc should never occur.+-- See Note [NoGhcTc]++-- Breaking it up this way, GHC can figure out that the result is a GhcPass+type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)++type family NoGhcTcPass (p :: Pass) :: Pass where+  NoGhcTcPass 'Typechecked = 'Renamed+  NoGhcTcPass other        = other++-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both+-- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc].+type OutputableBndrId pass =+  ( OutputableBndr (IdGhcP pass)+  , OutputableBndr (IdOccGhcP pass)+  , OutputableBndr (IdGhcP (NoGhcTcPass pass))+  , OutputableBndr (IdOccGhcP (NoGhcTcPass pass))+  , Outputable (LIdGhcP pass)+  , Outputable (LIdOccGhcP pass)+  , Outputable (LIdGhcP (NoGhcTcPass pass))+  , Outputable (LIdOccGhcP (NoGhcTcPass pass))+  , IsPass pass+  )++-- useful helper functions:+pprIfPs :: forall p. IsPass p => (p ~ 'Parsed => SDoc) -> SDoc+pprIfPs pp = case ghcPass @p of GhcPs -> pp+                                _     -> empty++pprIfRn :: forall p. IsPass p => (p ~ 'Renamed => SDoc) -> SDoc+pprIfRn pp = case ghcPass @p of GhcRn -> pp+                                _     -> empty++pprIfTc :: forall p. IsPass p => (p ~ 'Typechecked => SDoc) -> SDoc+pprIfTc pp = case ghcPass @p of GhcTc -> pp+                                _     -> empty++--- Outputable++instance Outputable NoExtField where+  ppr _ = text "NoExtField"++instance Outputable DataConCantHappen where+  ppr = dataConCantHappen
GHC/Hs/ImpExp.hs view
@@ -1,3 +1,15 @@+{-# OPTIONS_GHC -Wno-orphans      #-} -- Outputable and IEWrappedName+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE MultiWayIf           #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,143 +18,150 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder+module GHC.Hs.ImpExp+    ( module Language.Haskell.Syntax.ImpExp+    , module GHC.Hs.ImpExp+    ) where -module GHC.Hs.ImpExp where+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name+import Language.Haskell.Syntax.ImpExp -import GhcPrelude+import GHC.Prelude -import Module           ( ModuleName )-import GHC.Hs.Doc       ( HsDocString )-import OccName          ( HasOccName(..), isTcOcc, isSymOcc )-import BasicTypes       ( SourceText(..), StringLiteral(..), pprWithSourceText )-import FieldLabel       ( FieldLbl(..) )+import GHC.Types.SourceText   ( SourceText(..) )+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.PkgQual -import Outputable-import FastString-import SrcLoc+import GHC.Parser.Annotation import GHC.Hs.Extension +import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.Module.Warnings+ import Data.Data import Data.Maybe+import GHC.Hs.Doc (LHsDoc) + {- ************************************************************************ *                                                                      *-\subsection{Import and export declaration lists}+    Import and export declaration lists *                                                                      * ************************************************************************ -One per \tr{import} declaration in a module.+One per import declaration in a module. -} --- | Located Import Declaration-type LImportDecl pass = Located (ImportDecl pass)-        -- ^ When in a list this may have-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi'+type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA -        -- For details on above see note [Api annotations] in ApiAnnotation --- | If/how an import is 'qualified'.-data ImportDeclQualifiedStyle-  = QualifiedPre  -- ^ 'qualified' appears in prepositive position.-  | QualifiedPost -- ^ 'qualified' appears in postpositive position.-  | NotQualified  -- ^ Not qualified.-  deriving (Eq, Data) --- | Given two possible located 'qualified' tokens, compute a style--- (in a conforming Haskell program only one of the two can be not--- 'Nothing'). This is called from 'Parser.y'.-importDeclQualifiedStyle :: Maybe (Located a)-                         -> Maybe (Located a)-                         -> ImportDeclQualifiedStyle-importDeclQualifiedStyle mPre mPost =-  if isJust mPre then QualifiedPre-  else if isJust mPost then QualifiedPost else NotQualified- -- | Convenience function to answer the question if an import decl. is -- qualified. isImportDeclQualified :: ImportDeclQualifiedStyle -> Bool isImportDeclQualified NotQualified = False isImportDeclQualified _ = True --- | Import Declaration------ A single Haskell @import@ declaration.-data ImportDecl pass-  = ImportDecl {-      ideclExt       :: XCImportDecl pass,-      ideclSourceSrc :: SourceText,-                                 -- Note [Pragma source text] in BasicTypes-      ideclName      :: Located ModuleName, -- ^ Module name.-      ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.-      ideclSource    :: Bool,          -- ^ True <=> {-\# SOURCE \#-} import-      ideclSafe      :: Bool,          -- ^ True => safe import-      ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.-      ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)-      ideclAs        :: Maybe (Located ModuleName),  -- ^ as Module-      ideclHiding    :: Maybe (Bool, Located [LIE pass])-                                       -- ^ (True => hiding, names)+++type instance ImportDeclPkgQual GhcPs = RawPkgQual+type instance ImportDeclPkgQual GhcRn = PkgQual+type instance ImportDeclPkgQual GhcTc = PkgQual++type instance XCImportDecl  GhcPs = XImportDeclPass+type instance XCImportDecl  GhcRn = XImportDeclPass+type instance XCImportDecl  GhcTc = DataConCantHappen++data XImportDeclPass = XImportDeclPass+    { ideclAnn        :: EpAnn EpAnnImportDecl+    , ideclSourceText :: SourceText -- Note [Pragma source text] in "GHC.Types.SourceText"+    , ideclImplicit   :: Bool+        -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude`+        -- that appears in any file that omits `import Prelude`, setting+        -- this field to indicate that the import doesn't appear in the+        -- original source. True => implicit import (of Prelude)     }-  | XImportDecl (XXImportDecl pass)-     -- ^-     --  'ApiAnnotation.AnnKeywordId's-     ---     --  - 'ApiAnnotation.AnnImport'-     ---     --  - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource-     ---     --  - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified',-     --    'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs',-     --    'ApiAnnotation.AnnVal'-     ---     --  - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen',-     --    'ApiAnnotation.AnnClose' attached-     --     to location in ideclHiding+    deriving (Data) -     -- For details on above see note [Api annotations] in ApiAnnotation+type instance XXImportDecl  (GhcPass _) = DataConCantHappen -type instance XCImportDecl  (GhcPass _) = NoExtField-type instance XXImportDecl  (GhcPass _) = NoExtCon+type instance Anno ModuleName = SrcSpanAnnA+type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnLI -simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)+deriving instance Data (IEWrappedName GhcPs)+deriving instance Data (IEWrappedName GhcRn)+deriving instance Data (IEWrappedName GhcTc)++deriving instance Eq (IEWrappedName GhcPs)+deriving instance Eq (IEWrappedName GhcRn)+deriving instance Eq (IEWrappedName GhcTc)++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnImportDecl = EpAnnImportDecl+  { importDeclAnnImport    :: EpToken "import" -- ^ The location of the @import@ keyword+  , importDeclAnnPragma    :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively+  , importDeclAnnSafe      :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword+  , importDeclAnnLevel     :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword+  , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword+  , importDeclAnnPackage   :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@)+  , importDeclAnnAs        :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword+  } deriving (Data)+++instance NoAnn EpAnnImportDecl where+  noAnn = EpAnnImportDecl noAnn  Nothing Nothing  noAnn  Nothing  Nothing  Nothing++data EpAnnLevel = EpAnnLevelSplice (EpToken "splice")+                | EpAnnLevelQuote (EpToken "quote")+                deriving Data++instance HasLoc EpAnnLevel where+  getHasLoc (EpAnnLevelSplice tok) = getEpTokenSrcSpan tok+  getHasLoc (EpAnnLevelQuote tok) = getEpTokenSrcSpan tok++-- ---------------------------------------------------------------------++simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl {-      ideclExt       = noExtField,-      ideclSourceSrc = NoSourceText,-      ideclName      = noLoc mn,-      ideclPkgQual   = Nothing,-      ideclSource    = False,-      ideclSafe      = False,-      ideclImplicit  = False,-      ideclQualified = NotQualified,-      ideclAs        = Nothing,-      ideclHiding    = Nothing+      ideclExt        = XImportDeclPass noAnn NoSourceText False,+      ideclName       = noLocA mn,+      ideclPkgQual    = NoRawPkgQual,+      ideclSource     = NotBoot,+      ideclSafe       = False,+      ideclLevelSpec  = NotLevelled,+      ideclQualified  = NotQualified,+      ideclAs         = Nothing,+      ideclImportList = Nothing     } -instance OutputableBndrId p+instance (OutputableBndrId p+         , Outputable (Anno (IE (GhcPass p)))+         , Outputable (ImportDeclPkgQual (GhcPass p)))        => Outputable (ImportDecl (GhcPass p)) where-    ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'+    ppr (ImportDecl { ideclExt = impExt, ideclName = mod'                     , ideclPkgQual = pkg                     , ideclSource = from, ideclSafe = safe-                    , ideclQualified = qual, ideclImplicit = implicit-                    , ideclAs = as, ideclHiding = spec })-      = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,-                    pp_qual qual False, pp_pkg pkg, ppr mod', pp_qual qual True, pp_as as])+                    , ideclQualified = qual+                    , ideclAs = as, ideclImportList = spec })+      = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe,+                    pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as])              4 (pp_spec spec)       where-        pp_implicit False = empty-        pp_implicit True = ptext (sLit ("(implicit)"))--        pp_pkg Nothing                    = empty-        pp_pkg (Just (StringLiteral st p))-          = pprWithSourceText st (doubleQuotes (ftext p))+        pp_implicit ext =+            let implicit = case ghcPass @p of+                            GhcPs | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit+                            GhcRn | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit+                            GhcTc -> dataConCantHappen ext+            in if implicit then text "(implicit)"+                           else empty          pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position.         pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position.@@ -156,18 +175,22 @@         pp_as Nothing   = empty         pp_as (Just a)  = text "as" <+> ppr a -        ppr_imp True  = case mSrcText of-                          NoSourceText   -> text "{-# SOURCE #-}"-                          SourceText src -> text src <+> text "#-}"-        ppr_imp False = empty+        ppr_imp ext IsBoot =+            let mSrcText = case ghcPass @p of+                                GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+                                GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+                                GhcTc -> dataConCantHappen ext+            in case mSrcText of+                  NoSourceText   -> text "{-# SOURCE #-}"+                  SourceText src -> ftext src <+> text "#-}"+        ppr_imp _ NotBoot = empty          pp_spec Nothing             = empty-        pp_spec (Just (False, (L _ ies))) = ppr_ies ies-        pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies+        pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies+        pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies          ppr_ies []  = text "()"         ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'-    ppr (XImportDecl x) = ppr x  {- ************************************************************************@@ -177,160 +200,149 @@ ************************************************************************ -} --- | A name in an import or export specification which may have adornments. Used--- primarily for accurate pretty printing of ParsedSource, and API Annotation--- placement.-data IEWrappedName name-  = IEName    (Located name)  -- ^ no extra-  | IEPattern (Located name)  -- ^ pattern X-  | IEType    (Located name)  -- ^ type (:+:)-  deriving (Eq,Data)---- | Located name with possible adornment--- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType',---         'ApiAnnotation.AnnPattern'-type LIEWrappedName name = Located (IEWrappedName name)--- For details on above see note [Api annotations] in ApiAnnotation----- | Located Import or Export-type LIE pass = Located (IE pass)-        -- ^ When in a list this may have-        ---        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma'+type instance XIEName    (GhcPass _) = NoExtField+type instance XIEDefault (GhcPass _) = EpToken "default"+type instance XIEPattern (GhcPass _) = EpToken "pattern"+type instance XIEType    (GhcPass _) = EpToken "type"+type instance XIEData    (GhcPass _) = EpToken "data"+type instance XXIEWrappedName (GhcPass _) = DataConCantHappen -        -- For details on above see note [Api annotations] in ApiAnnotation+type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA --- | Imported or exported entity.-data IE pass-  = IEVar       (XIEVar pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or Exported Variable+type instance Anno (IE (GhcPass p)) = SrcSpanAnnA -  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or exported Thing with Absent list-        ---        -- The thing is a Class/Type (can't tell)-        --  - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern',-        --             'ApiAnnotation.AnnType','ApiAnnotation.AnnVal'+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEVar       GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEVar       GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEVar       GhcTc = NoExtField -        -- For details on above see note [Api annotations] in ApiAnnotation-        -- See Note [Located RdrNames] in GHC.Hs.Expr-  | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or exported Thing with All imported or exported-        ---        -- The thing is a Class/Type and the All refers to methods/constructors-        ---        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',-        --       'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose',-        --                                 'ApiAnnotation.AnnType'+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingAbs  GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEThingAbs  GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEThingAbs  GhcTc = () -        -- For details on above see note [Api annotations] in ApiAnnotation-        -- See Note [Located RdrNames] in GHC.Hs.Expr+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingAll  GhcPs = (Maybe (LWarningTxt GhcPs), (EpToken "(", EpToken "..", EpToken ")"))+type instance XIEThingAll  GhcRn = (Maybe (LWarningTxt GhcRn), (EpToken "(", EpToken "..", EpToken ")"))+type instance XIEThingAll  GhcTc = (EpToken "(", EpToken "..", EpToken ")") -  | IEThingWith (XIEThingWith pass)-                (LIEWrappedName (IdP pass))-                IEWildcard-                [LIEWrappedName (IdP pass)]-                [Located (FieldLbl (IdP pass))]-        -- ^ Imported or exported Thing With given imported or exported-        ---        -- The thing is a Class/Type and the imported or exported things are-        -- methods/constructors and record fields; see Note [IEThingWith]-        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen',-        --                                   'ApiAnnotation.AnnClose',-        --                                   'ApiAnnotation.AnnComma',-        --                                   'ApiAnnotation.AnnType'+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), IEThingWithAnns)+type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), IEThingWithAnns)+type instance XIEThingWith GhcTc = IEThingWithAnns -        -- For details on above see note [Api annotations] in ApiAnnotation-  | IEModuleContents  (XIEModuleContents pass) (Located ModuleName)-        -- ^ Imported or exported module contents-        ---        -- (Export Only)-        ---        -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule'+type IEThingWithAnns = (EpToken "(", EpToken "..", EpToken ",", EpToken ")") -        -- For details on above see note [Api annotations] in ApiAnnotation-  | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading-  | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation-  | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc-  | XIE (XXIE pass)+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEModuleContents  GhcPs = (Maybe (LWarningTxt GhcPs), EpToken "module")+type instance XIEModuleContents  GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEModuleContents  GhcTc = NoExtField -type instance XIEVar             (GhcPass _) = NoExtField-type instance XIEThingAbs        (GhcPass _) = NoExtField-type instance XIEThingAll        (GhcPass _) = NoExtField-type instance XIEThingWith       (GhcPass _) = NoExtField-type instance XIEModuleContents  (GhcPass _) = NoExtField type instance XIEGroup           (GhcPass _) = NoExtField type instance XIEDoc             (GhcPass _) = NoExtField type instance XIEDocNamed        (GhcPass _) = NoExtField-type instance XXIE               (GhcPass _) = NoExtCon---- | Imported or Exported Wildcard-data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)--{--Note [IEThingWith]-~~~~~~~~~~~~~~~~~~--A definition like--    module M ( T(MkT, x) ) where-      data T = MkT { x :: Int }--gives rise to+type instance XXIE               (GhcPass _) = DataConCantHappen -    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)-    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)+type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA -See Note [Representing fields in AvailInfo] in Avail for more details.--}+ieLIEWrappedName :: IE (GhcPass p) -> LIEWrappedName (GhcPass p)+ieLIEWrappedName (IEVar _ n _)           = n+ieLIEWrappedName (IEThingAbs  _ n _)     = n+ieLIEWrappedName (IEThingWith _ n _ _ _) = n+ieLIEWrappedName (IEThingAll  _ n _)     = n+ieLIEWrappedName _ = panic "ieLIEWrappedName failed pattern match!"  ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n))              = ieWrappedName n-ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n-ieName (IEThingAll  _ (L _ n))        = ieWrappedName n-ieName _ = panic "ieName failed pattern match!"+ieName = lieWrappedName . ieLIEWrappedName  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]-ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n-                                       : map (ieWrappedName . unLoc) ns+ieNames (IEVar       _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAbs  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAll  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = [] ieNames (IEDocNamed       {})     = []-ieNames (XIE nec) = noExtCon nec -ieWrappedName :: IEWrappedName name -> name-ieWrappedName (IEName    (L _ n)) = n-ieWrappedName (IEPattern (L _ n)) = n-ieWrappedName (IEType    (L _ n)) = n+ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p))+ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p)+  where+    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p))+    ie_deprecation GhcPs (IEVar xie _ _) = xie+    ie_deprecation GhcPs (IEThingAbs xie _ _) = xie+    ie_deprecation GhcPs (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _ _) = xie+    ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie+    ie_deprecation GhcRn (IEVar xie _ _) = xie+    ie_deprecation GhcRn (IEThingAbs xie _ _) = xie+    ie_deprecation GhcRn (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _ _) = xie+    ie_deprecation GhcRn (IEModuleContents xie _) = xie+    ie_deprecation _ _ = Nothing -lieWrappedName :: LIEWrappedName name -> name+ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p)+ieWrappedLName (IEDefault _ (L l n)) = L l n+ieWrappedLName (IEName    _ (L l n)) = L l n+ieWrappedLName (IEPattern _ (L l n)) = L l n+ieWrappedLName (IEType    _ (L l n)) = L l n+ieWrappedLName (IEData    _ (L l n)) = L l n++ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p)+ieWrappedName = unLoc . ieWrappedLName+++lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> Located name-ieLWrappedName (L l n) = L l (ieWrappedName n)+ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p)+ieLWrappedName (L _ n) = ieWrappedLName n -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2-replaceWrappedName (IEName    (L l _)) n = IEName    (L l n)-replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)-replaceWrappedName (IEType    (L l _)) n = IEType    (L l n)+replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn+replaceWrappedName (IEDefault r (L l _)) n = IEDefault r (L l n)+replaceWrappedName (IEName    x (L l _)) n = IEName    x (L l n)+replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n)+replaceWrappedName (IEType    r (L l _)) n = IEType    r (L l n)+replaceWrappedName (IEData    r (L l _)) n = IEData    r (L l n) -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2+replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') +exportDocstring :: LHsDoc pass -> SDoc+exportDocstring doc = braces (text "docstring: " <> ppr doc)+ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where-    ppr (IEVar       _     var) = ppr (unLoc var)-    ppr (IEThingAbs  _   thing) = ppr (unLoc thing)-    ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]-    ppr (IEThingWith _ thing wc withs flds)-        = ppr (unLoc thing) <> parens (fsep (punctuate comma-                                              (ppWiths ++-                                              map (ppr . flLabel . unLoc) flds)))+    ppr ie@(IEVar       _     var doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc var)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAbs  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAll  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ hcat [ppr (unLoc thing)+                      , text "(..)"]+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingWith _ thing wc withs doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))+                      , exportDocstring <$> doc+                      ]       where         ppWiths =           case wc of@@ -339,25 +351,26 @@               IEWildcard pos ->                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)                 in bs ++ [text ".."] ++ as-    ppr (IEModuleContents _ mod')-        = text "module" <+> ppr mod'+    ppr ie@(IEModuleContents _ mod')+        = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod']     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")     ppr (IEDoc _ doc)             = ppr doc     ppr (IEDocNamed _ string)     = text ("<IEDocNamed: " ++ string ++ ">")-    ppr (XIE x) = ppr x -instance (HasOccName name) => HasOccName (IEWrappedName name) where+instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where   occName w = occName (ieWrappedName w) -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where+instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where   pprBndr bs   w = pprBndr bs   (ieWrappedName w)   pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)   pprInfixOcc  w = pprInfixOcc  (ieWrappedName w) -instance (OutputableBndr name) => Outputable (IEWrappedName name) where-  ppr (IEName    n) = pprPrefixOcc (unLoc n)-  ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)-  ppr (IEType    n) = text "type"    <+> pprPrefixOcc (unLoc n)+instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where+  ppr (IEDefault _ (L _ n)) = text "default" <+> pprPrefixOcc n+  ppr (IEName    _ (L _ n)) = pprPrefixOcc n+  ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n+  ppr (IEType    _ (L _ n)) = text "type"    <+> pprPrefixOcc n+  ppr (IEData    _ (L _ n)) = text "data"    <+> pprPrefixOcc n  pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name
GHC/Hs/Instances.hs view
@@ -5,6 +5,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-}++-- This module contains exclusively Data instances, which are going to be slow+-- no matter what we do. Furthermore, they are incredibly slow to compile with+-- optimisation (see #9557). Consequently we compile this with -O0.+-- See #18254.+{-# OPTIONS_GHC -O0 #-}+ module GHC.Hs.Instances where  -- This module defines the Data instances for the hsSyn AST.@@ -16,15 +23,19 @@  import Data.Data hiding ( Fixity ) -import GhcPrelude+import GHC.Prelude import GHC.Hs.Extension import GHC.Hs.Binds import GHC.Hs.Decls import GHC.Hs.Expr import GHC.Hs.Lit-import GHC.Hs.Types+import GHC.Hs.Type import GHC.Hs.Pat import GHC.Hs.ImpExp+import GHC.Parser.Annotation+import GHC.Types.Name.Reader (WithUserRdr(..))+import GHC.Data.BooleanFormula (BooleanFormula(..))+import Language.Haskell.Syntax.Extension (Anno)  -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs-----------------------------------------@@ -55,11 +66,15 @@ deriving instance Data (HsBindLR GhcRn GhcRn) deriving instance Data (HsBindLR GhcTc GhcTc) --- deriving instance (DataId p)       => Data (ABExport p)-deriving instance Data (ABExport GhcPs)-deriving instance Data (ABExport GhcRn)-deriving instance Data (ABExport GhcTc)+deriving instance Data AbsBinds +deriving instance Data ABExport++-- deriving instance DataId p => Data (RecordPatSynField p)+deriving instance Data (RecordPatSynField GhcPs)+deriving instance Data (RecordPatSynField GhcRn)+deriving instance Data (RecordPatSynField GhcTc)+ -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn)@@ -119,6 +134,11 @@ deriving instance Data (TyClDecl GhcRn) deriving instance Data (TyClDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (FunDep p)+deriving instance Data (FunDep GhcPs)+deriving instance Data (FunDep GhcRn)+deriving instance Data (FunDep GhcTc)+ -- deriving instance (DataIdLR p p) => Data (TyClGroup p) deriving instance Data (TyClGroup GhcPs) deriving instance Data (TyClGroup GhcRn)@@ -154,11 +174,21 @@ deriving instance Data (HsDerivingClause GhcRn) deriving instance Data (HsDerivingClause GhcTc) +-- deriving instance DataIdLR p p => Data (DerivClauseTys p)+deriving instance Data (DerivClauseTys GhcPs)+deriving instance Data (DerivClauseTys GhcRn)+deriving instance Data (DerivClauseTys GhcTc)+ -- deriving instance (DataIdLR p p) => Data (ConDecl p) deriving instance Data (ConDecl GhcPs) deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) +-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p)+deriving instance Data (HsConDeclGADTDetails GhcPs)+deriving instance Data (HsConDeclGADTDetails GhcRn)+deriving instance Data (HsConDeclGADTDetails GhcTc)+ -- deriving instance DataIdLR p p   => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn)@@ -204,6 +234,16 @@ deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (ForeignImport p)+deriving instance Data (ForeignImport GhcPs)+deriving instance Data (ForeignImport GhcRn)+deriving instance Data (ForeignImport GhcTc)++-- deriving instance (DataIdLR p p) => Data (ForeignExport p)+deriving instance Data (ForeignExport GhcPs)+deriving instance Data (ForeignExport GhcRn)+deriving instance Data (ForeignExport GhcTc)+ -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn)@@ -219,6 +259,13 @@ deriving instance Data (RuleBndr GhcRn) deriving instance Data (RuleBndr GhcTc) +deriving instance Data (RuleBndrs GhcPs)+deriving instance Data (RuleBndrs GhcRn)+deriving instance Data (RuleBndrs GhcTc)++deriving instance Data TcSpecPrags+deriving instance Data TcSpecPrag+ -- deriving instance (DataId p)     => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn)@@ -230,6 +277,10 @@ deriving instance Data (WarnDecl GhcTc)  -- deriving instance (DataIdLR p p) => Data (AnnDecl p)+deriving instance Data (AnnProvenance GhcPs)+deriving instance Data (AnnProvenance GhcRn)+deriving instance Data (AnnProvenance GhcTc)+ deriving instance Data (AnnDecl GhcPs) deriving instance Data (AnnDecl GhcRn) deriving instance Data (AnnDecl GhcTc)@@ -242,11 +293,27 @@ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- --- deriving instance (DataIdLR p p) => Data (SyntaxExpr p)-deriving instance Data (SyntaxExpr GhcPs)-deriving instance Data (SyntaxExpr GhcRn)-deriving instance Data (SyntaxExpr GhcTc)+deriving instance Data (FieldLabelStrings GhcPs)+deriving instance Data (FieldLabelStrings GhcRn)+deriving instance Data (FieldLabelStrings GhcTc) +deriving instance Data (HsRecUpdParent GhcPs)+deriving instance Data (HsRecUpdParent GhcRn)+deriving instance Data (HsRecUpdParent GhcTc)++deriving instance Data (LHsRecUpdFields GhcPs)+deriving instance Data (LHsRecUpdFields GhcRn)+deriving instance Data (LHsRecUpdFields GhcTc)++deriving instance Data (DotFieldOcc GhcPs)+deriving instance Data (DotFieldOcc GhcRn)+deriving instance Data (DotFieldOcc GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsPragE p)+deriving instance Data (HsPragE GhcPs)+deriving instance Data (HsPragE GhcRn)+deriving instance Data (HsPragE GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsExpr p) deriving instance Data (HsExpr GhcPs) deriving instance Data (HsExpr GhcRn)@@ -268,30 +335,46 @@ deriving instance Data (HsCmdTop GhcTc)  -- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)-deriving instance (Data body) => Data (MatchGroup GhcPs body)-deriving instance (Data body) => Data (MatchGroup GhcRn body)-deriving instance (Data body) => Data (MatchGroup GhcTc body)+deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (MatchGroup GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (MatchGroup GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (MatchGroup GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (Match      p body)-deriving instance (Data body) => Data (Match      GhcPs body)-deriving instance (Data body) => Data (Match      GhcRn body)-deriving instance (Data body) => Data (Match      GhcTc body)+deriving instance Data (Match      GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (Match      GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (Match      GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (Match      GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (Match      GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (Match      GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (GRHSs      p body)-deriving instance (Data body) => Data (GRHSs     GhcPs body)-deriving instance (Data body) => Data (GRHSs     GhcRn body)-deriving instance (Data body) => Data (GRHSs     GhcTc body)+deriving instance Data (GRHSs     GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (GRHSs     GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (GRHSs     GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (GRHSs     GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (GRHSs     GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (GRHSs     GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (GRHS       p body)-deriving instance (Data body) => Data (GRHS     GhcPs body)-deriving instance (Data body) => Data (GRHS     GhcRn body)-deriving instance (Data body) => Data (GRHS     GhcTc body)+deriving instance Data (GRHS     GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (GRHS     GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (GRHS     GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (GRHS     GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (GRHS     GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (GRHS     GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (StmtLR   p p body)-deriving instance (Data body) => Data (StmtLR   GhcPs GhcPs body)-deriving instance (Data body) => Data (StmtLR   GhcPs GhcRn body)-deriving instance (Data body) => Data (StmtLR   GhcRn GhcRn body)-deriving instance (Data body) => Data (StmtLR   GhcTc GhcTc body)+deriving instance Data (StmtLR   GhcPs GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (StmtLR   GhcPs GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (StmtLR   GhcRn GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (StmtLR   GhcTc GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (StmtLR   GhcPs GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (StmtLR   GhcPs GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (StmtLR   GhcRn GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (StmtLR   GhcTc GhcTc (LocatedA (HsCmd GhcTc)))  deriving instance Data RecStmtTc @@ -301,42 +384,72 @@ deriving instance Data (ParStmtBlock GhcRn GhcRn) deriving instance Data (ParStmtBlock GhcTc GhcTc) +-- deriving instance (DataIdLR p p) => Data (ApplicativeStmt p p)+deriving instance Data (ApplicativeStmt GhcPs GhcPs)+deriving instance Data (ApplicativeStmt GhcPs GhcRn)+deriving instance Data (ApplicativeStmt GhcPs GhcTc)+deriving instance Data (ApplicativeStmt GhcRn GhcPs)+deriving instance Data (ApplicativeStmt GhcRn GhcRn)+deriving instance Data (ApplicativeStmt GhcRn GhcTc)+deriving instance Data (ApplicativeStmt GhcTc GhcPs)+deriving instance Data (ApplicativeStmt GhcTc GhcRn)+deriving instance Data (ApplicativeStmt GhcTc GhcTc)+ -- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) deriving instance Data (ApplicativeArg GhcPs) deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplice p)-deriving instance Data (HsSplice GhcPs)-deriving instance Data (HsSplice GhcRn)-deriving instance Data (HsSplice GhcTc)+deriving instance Data HsArrowMatchContext --- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)-deriving instance Data (HsSplicedThing GhcPs)-deriving instance Data (HsSplicedThing GhcRn)-deriving instance Data (HsSplicedThing GhcTc)+deriving instance Data fn => Data (HsStmtContext fn)+deriving instance Data fn => Data (HsMatchContext fn) --- deriving instance (DataIdLR p p) => Data (HsBracket p)-deriving instance Data (HsBracket GhcPs)-deriving instance Data (HsBracket GhcRn)-deriving instance Data (HsBracket GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p)+deriving instance Data (HsUntypedSplice GhcPs)+deriving instance Data (HsUntypedSplice GhcRn)+deriving instance Data (HsUntypedSplice GhcTc) +deriving instance Data (HsTypedSplice GhcPs)+deriving instance Data (HsTypedSplice GhcRn)+deriving instance Data (HsTypedSplice GhcTc)++deriving instance Data HsImplicitLiftSplice+deriving instance Data HsUserSpliceExt+deriving instance Data HsQuasiQuoteExt++deriving instance Data a => Data (HsUntypedSpliceResult a)+deriving instance Data HsTypedSpliceResult++-- deriving instance (DataIdLR p p) => Data (HsQuote p)+deriving instance Data (HsQuote GhcPs)+deriving instance Data (HsQuote GhcRn)+deriving instance Data (HsQuote GhcTc)++deriving instance Data HsBracketTc+ -- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) deriving instance Data (ArithSeqInfo GhcPs) deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance                   Data RecordConTc-deriving instance                   Data CmdTopTc-deriving instance                   Data PendingRnSplice-deriving instance                   Data PendingTcSplice+deriving instance Data CmdTopTc+deriving instance Data PendingRnSplice+deriving instance Data PendingTcSplice+deriving instance Data SyntaxExprRn+deriving instance Data SyntaxExprTc +deriving instance Data XBindStmtRn+deriving instance Data XBindStmtTc+ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Lit ------------------------------------  -- deriving instance (DataId p) => Data (HsLit p) deriving instance Data (HsLit GhcPs) deriving instance Data (HsLit GhcRn)++deriving instance Data HsLitTc deriving instance Data (HsLit GhcTc)  -- deriving instance (DataIdLR p p) => Data (HsOverLit p)@@ -344,6 +457,9 @@ deriving instance Data (HsOverLit GhcRn) deriving instance Data (HsOverLit GhcTc) +deriving instance Data OverLitRn+deriving instance Data OverLitTc+ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Pat ------------------------------------ @@ -352,61 +468,112 @@ deriving instance Data (Pat GhcRn) deriving instance Data (Pat GhcTc) -deriving instance Data ListPatTc+deriving instance Data ConPatTc --- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)+deriving instance (Data a, Data b) => Data (HsFieldBind a b)+ deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) deriving instance (Data body) => Data (HsRecFields GhcTc body)  -- ------------------------------------------------------------------------ Data derivations from GHC.Hs.Types ----------------------------------+-- Data derivations from GHC.Hs.Type ---------------------------------- +-- deriving instance Data (HsBndrVis p)+deriving instance Data (HsBndrVis GhcPs)+deriving instance Data (HsBndrVis GhcRn)+deriving instance Data (HsBndrVis GhcTc)+ -- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) deriving instance Data (LHsQTyVars GhcPs) deriving instance Data (LHsQTyVars GhcRn) deriving instance Data (LHsQTyVars GhcTc) --- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)+-- deriving instance (Data flag, DataIdLR p p) => Data (HsOuterTyVarBndrs p)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcPs)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcRn)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsSigType p)+deriving instance Data (HsSigType GhcPs)+deriving instance Data (HsSigType GhcRn)+deriving instance Data (HsSigType GhcTc)+ -- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) +-- deriving instance (DataIdLR p p) => Data (HsPatSigType p)+deriving instance Data (HsPatSigType GhcPs)+deriving instance Data (HsPatSigType GhcRn)+deriving instance Data (HsPatSigType GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsTyPat p)+deriving instance Data (HsTyPat GhcPs)+deriving instance Data (HsTyPat GhcRn)+deriving instance Data (HsTyPat GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p)+deriving instance Data (HsForAllTelescope GhcPs)+deriving instance Data (HsForAllTelescope GhcRn)+deriving instance Data (HsForAllTelescope GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p)-deriving instance Data (HsTyVarBndr GhcPs)-deriving instance Data (HsTyVarBndr GhcRn)-deriving instance Data (HsTyVarBndr GhcTc)+deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs)+deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn)+deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) +-- deriving instance Data (HsBndrVar p)+deriving instance Data (HsBndrVar GhcPs)+deriving instance Data (HsBndrVar GhcRn)+deriving instance Data (HsBndrVar GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsBndrKind p)+deriving instance Data (HsBndrKind GhcPs)+deriving instance Data (HsBndrKind GhcRn)+deriving instance Data (HsBndrKind GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) -deriving instance Data (LHsTypeArg GhcPs)-deriving instance Data (LHsTypeArg GhcRn)-deriving instance Data (LHsTypeArg GhcTc)+deriving instance Data HsTypeGhcPsExt --- deriving instance (DataIdLR p p) => Data (ConDeclField p)-deriving instance Data (ConDeclField GhcPs)-deriving instance Data (ConDeclField GhcRn)-deriving instance Data (ConDeclField GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsTyLit p)+deriving instance Data (HsTyLit GhcPs)+deriving instance Data (HsTyLit GhcRn)+deriving instance Data (HsTyLit GhcTc) +-- deriving instance (Data mult, DataIdLR p p) => Data (HsMultAnnOf mult p)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcPs)) GhcPs)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcRn)+deriving instance Data (HsMultAnnOf (LocatedA (HsType GhcRn)) GhcTc)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcPs)) GhcPs)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn)+deriving instance Data (HsMultAnnOf (LocatedA (HsExpr GhcTc)) GhcTc)++-- deriving instance (Data a, Data b) => Data (HsArg p a b)+deriving instance (Data a, Data b) => Data (HsArg GhcPs a b)+deriving instance (Data a, Data b) => Data (HsArg GhcRn a b)+deriving instance (Data a, Data b) => Data (HsArg GhcTc a b)++-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p)+deriving instance Data (HsConDeclRecField GhcPs)+deriving instance Data (HsConDeclRecField GhcRn)+deriving instance Data (HsConDeclRecField GhcTc)++-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p)+deriving instance Data (HsConDeclField GhcPs)+deriving instance Data (HsConDeclField GhcRn)+deriving instance Data (HsConDeclField GhcTc)+ -- deriving instance (DataId p)     => Data (FieldOcc p) deriving instance Data (FieldOcc GhcPs) deriving instance Data (FieldOcc GhcRn) deriving instance Data (FieldOcc GhcTc) --- deriving instance DataId p       => Data (AmbiguousFieldOcc p)-deriving instance Data (AmbiguousFieldOcc GhcPs)-deriving instance Data (AmbiguousFieldOcc GhcRn)-deriving instance Data (AmbiguousFieldOcc GhcTc)-- -- deriving instance (DataId name) => Data (ImportDecl name) deriving instance Data (ImportDecl GhcPs) deriving instance Data (ImportDecl GhcRn)@@ -423,3 +590,21 @@ deriving instance Eq (IE GhcTc)  -- ---------------------------------------------------------------------++deriving instance Data HsThingRn+deriving instance Data XXExprGhcRn+deriving instance Data a => Data (WithUserRdr a)++-- ---------------------------------------------------------------------++deriving instance Data XXExprGhcTc+deriving instance Data XXPatGhcTc++-- ---------------------------------------------------------------------++deriving instance Data XViaStrategyPs++-- ---------------------------------------------------------------------++deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p))+---------------------------------------------------------------------
GHC/Hs/Lit.hs view
@@ -1,37 +1,42 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[HsLit]{Abstract syntax: source-language literals} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Hs.Lit where+-- | Source-language literals+module GHC.Hs.Lit+  ( module Language.Haskell.Syntax.Lit+  , module GHC.Hs.Lit+  ) where -#include "HsVersions.h"+import GHC.Prelude -import GhcPrelude+import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr )-import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit,-                    negateFractionalLit,SourceText(..),pprWithSourceText,-                    PprPrec(..), topPrec )-import Type-import Outputable-import FastString+import GHC.Data.FastString (unpackFS)+import GHC.Types.Basic (PprPrec(..), topPrec )+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )+import GHC.Types.SourceText+import GHC.Core.Type+import GHC.Utils.Misc (split)+import GHC.Utils.Outputable+import GHC.Utils.Panic (panic) import GHC.Hs.Extension--import Data.ByteString (ByteString)-import Data.Data hiding ( Fixity )+import Language.Haskell.Syntax.Expr ( HsExpr )+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Lit  {- ************************************************************************@@ -41,221 +46,206 @@ ************************************************************************ -} --- Note [Literal source text] in BasicTypes for SourceText fields in--- the following--- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following--- | Haskell Literal-data HsLit x-  = HsChar (XHsChar x) {- SourceText -} Char-      -- ^ Character-  | HsCharPrim (XHsCharPrim x) {- SourceText -} Char-      -- ^ Unboxed character-  | HsString (XHsString x) {- SourceText -} FastString-      -- ^ String-  | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString-      -- ^ Packed bytes-  | HsInt (XHsInt x)  IntegralLit-      -- ^ Genuinely an Int; arises from-      -- @TcGenDeriv@, and from TRANSLATION-  | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer-      -- ^ literal @Int#@-  | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer-      -- ^ literal @Word#@-  | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer-      -- ^ literal @Int64#@-  | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer-      -- ^ literal @Word64#@-  | HsInteger (XHsInteger x) {- SourceText -} Integer Type-      -- ^ Genuinely an integer; arises only-      -- from TRANSLATION (overloaded-      -- literals are done with HsOverLit)-  | HsRat (XHsRat x)  FractionalLit Type-      -- ^ Genuinely a rational; arises only from-      -- TRANSLATION (overloaded literals are-      -- done with HsOverLit)-  | HsFloatPrim (XHsFloatPrim x)   FractionalLit-      -- ^ Unboxed Float-  | HsDoublePrim (XHsDoublePrim x) FractionalLit-      -- ^ Unboxed Double--  | XLit (XXLit x)- type instance XHsChar       (GhcPass _) = SourceText type instance XHsCharPrim   (GhcPass _) = SourceText type instance XHsString     (GhcPass _) = SourceText+type instance XHsMultilineString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt        (GhcPass _) = NoExtField type instance XHsIntPrim    (GhcPass _) = SourceText type instance XHsWordPrim   (GhcPass _) = SourceText+type instance XHsInt8Prim   (GhcPass _) = SourceText+type instance XHsInt16Prim  (GhcPass _) = SourceText+type instance XHsInt32Prim  (GhcPass _) = SourceText type instance XHsInt64Prim  (GhcPass _) = SourceText+type instance XHsWord8Prim  (GhcPass _) = SourceText+type instance XHsWord16Prim (GhcPass _) = SourceText+type instance XHsWord32Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText-type instance XHsInteger    (GhcPass _) = SourceText-type instance XHsRat        (GhcPass _) = NoExtField type instance XHsFloatPrim  (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField-type instance XXLit         (GhcPass _) = NoExtCon -instance Eq (HsLit x) where-  (HsChar _ x1)       == (HsChar _ x2)       = x1==x2-  (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2-  (HsString _ x1)     == (HsString _ x2)     = x1==x2-  (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2-  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2-  (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2-  (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2-  (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2-  (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2-  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2-  (HsRat _ x1 _)      == (HsRat _ x2 _)      = x1==x2-  (HsFloatPrim _ x1)  == (HsFloatPrim _ x2)  = x1==x2-  (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2-  _                   == _                   = False+type instance XXLit         GhcPs = DataConCantHappen+type instance XXLit         GhcRn = DataConCantHappen+type instance XXLit         GhcTc = HsLitTc --- | Haskell Overloaded Literal-data HsOverLit p-  = OverLit {-      ol_ext :: (XOverLit p),-      ol_val :: OverLitVal,-      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]+data HsLitTc+  = HsInteger SourceText Integer Type+      -- ^ Genuinely an integer; arises only+      -- from TRANSLATION (overloaded+      -- literals are done with HsOverLit)+  | HsRat FractionalLit Type+      -- ^ Genuinely a rational; arises only from+      -- TRANSLATION (overloaded literals are+      -- done with HsOverLit)+instance Eq HsLitTc where+  (HsInteger _ x _) == (HsInteger _ y _) = x==y+  (HsRat x _)       == (HsRat y _)       = x==y+  _                 == _                 = False -  | XOverLit-      (XXOverLit p)+data OverLitRn+  = OverLitRn {+        ol_rebindable :: Bool,         -- Note [ol_rebindable]+        ol_from_fun   :: LIdP GhcRn    -- Note [Overloaded literal witnesses]+        }  data OverLitTc   = OverLitTc {-        ol_rebindable :: Bool, -- Note [ol_rebindable]+        ol_rebindable :: Bool,         -- Note [ol_rebindable]+        ol_witness    :: HsExpr GhcTc, -- Note [Overloaded literal witnesses]         ol_type :: Type }-  deriving Data +{-+Note [Overloaded literal witnesses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++During renaming, the coercion function needed for a given HsOverLit is+resolved according to the current scope and RebindableSyntax (see Note+[ol_rebindable]). The result of this resolution *before* type checking+is the coercion function such as 'fromInteger' or 'fromRational',+stored in the ol_from_fun field of OverLitRn.++*After* type checking, the ol_witness field of the OverLitTc contains+the witness of the literal as HsExpr, such as (fromInteger 3) or+lit_78. This witness should replace the literal. Reason: it allows+commoning up of the fromInteger calls, which wouldn't be possible if+the desugarer made the application.++The ol_type in OverLitTc records the type the overloaded literal is+found to have.+-}+ type instance XOverLit GhcPs = NoExtField-type instance XOverLit GhcRn = Bool            -- Note [ol_rebindable]+type instance XOverLit GhcRn = OverLitRn type instance XOverLit GhcTc = OverLitTc -type instance XXOverLit (GhcPass _) = NoExtCon---- Note [Literal source text] in BasicTypes for SourceText fields in--- the following--- | Overloaded Literal Value-data OverLitVal-  = HsIntegral   !IntegralLit            -- ^ Integer-looking literals;-  | HsFractional !FractionalLit          -- ^ Frac-looking literals-  | HsIsString   !SourceText !FastString -- ^ String-looking literals-  deriving Data+pprXOverLit :: GhcPass p -> XOverLit (GhcPass p) -> SDoc+pprXOverLit GhcPs noExt = ppr noExt+pprXOverLit GhcRn OverLitRn{ ol_from_fun = from_fun } = ppr from_fun+pprXOverLit GhcTc OverLitTc{ ol_witness = witness } = pprExpr witness -negateOverLitVal :: OverLitVal -> OverLitVal-negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)-negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)-negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"+type instance XXOverLit (GhcPass _) = DataConCantHappen  overLitType :: HsOverLit GhcTc -> Type-overLitType (OverLit (OverLitTc _ ty) _ _) = ty-overLitType (XOverLit nec) = noExtCon nec+overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty --- | Convert a literal from one index type to another, updating the annotations--- according to the relevant 'Convertable' instance-convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b-convertLit (HsChar a x)       = (HsChar (convert a) x)-convertLit (HsCharPrim a x)   = (HsCharPrim (convert a) x)-convertLit (HsString a x)     = (HsString (convert a) x)-convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x)-convertLit (HsInt a x)        = (HsInt (convert a) x)-convertLit (HsIntPrim a x)    = (HsIntPrim (convert a) x)-convertLit (HsWordPrim a x)   = (HsWordPrim (convert a) x)-convertLit (HsInt64Prim a x)  = (HsInt64Prim (convert a) x)-convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x)-convertLit (HsInteger a x b)  = (HsInteger (convert a) x b)-convertLit (HsRat a x b)      = (HsRat (convert a) x b)-convertLit (HsFloatPrim a x)  = (HsFloatPrim (convert a) x)-convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x)-convertLit (XLit a)           = (XLit (convert a))+-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal+-- @ol@ needs to be parenthesized under precedence @p@.+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv+  where+    go :: OverLitVal -> Bool+    go (HsIntegral x)   = p > topPrec && il_neg x+    go (HsFractional x) = p > topPrec && fl_neg x+    go (HsIsString {})  = False+hsOverLitNeedsParens _ (XOverLit { }) = False +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs+-- to be parenthesized under precedence @p@.+--+-- See Note [Printing of literals in Core] in GHC.Types.Literal+-- for the reasoning.+hsLitNeedsParens :: forall x. IsPass x => PprPrec -> HsLit (GhcPass x) -> Bool+hsLitNeedsParens p = go+  where+    go (HsChar {})        = False+    go (HsCharPrim {})    = False+    go (HsString {})      = False+    go (HsMultilineString {}) = False+    go (HsStringPrim {})  = False+    go (HsInt _ x)        = p > topPrec && il_neg x+    go (HsFloatPrim {})   = False+    go (HsDoublePrim {})  = False+    go (HsIntPrim {})     = False+    go (HsInt8Prim {})    = False+    go (HsInt16Prim {})   = False+    go (HsInt32Prim {})   = False+    go (HsInt64Prim {})   = False+    go (HsWordPrim {})    = False+    go (HsWord8Prim {})   = False+    go (HsWord16Prim {})  = False+    go (HsWord64Prim {})  = False+    go (HsWord32Prim {})  = False+    go (XLit x)           = case ghcPass @x of+      GhcTc -> case x of+         (HsInteger _ x _) -> p > topPrec && x < 0+         (HsRat  x _)      -> p > topPrec && fl_neg x+++-- | Convert a literal from one index type to another.+-- The constraint XXLit (GhcPass p)~DataConCantHappen means that once the+-- XLit constructor is inhabited, we can no longer go back to the case where+-- its not. In practice it just means you can't just convertLit to go from+-- (HsLit GhcTc) -> (HsLit GhcPs/GhcRn), while all other conversions are fine.+convertLit :: XXLit (GhcPass p)~DataConCantHappen => HsLit (GhcPass p) -> HsLit (GhcPass p')+convertLit (HsChar a x)       = HsChar a x+convertLit (HsCharPrim a x)   = HsCharPrim a x+convertLit (HsString a x)     = HsString a x+convertLit (HsMultilineString a x) = HsMultilineString a x+convertLit (HsStringPrim a x) = HsStringPrim a x+convertLit (HsInt a x)        = HsInt a x+convertLit (HsIntPrim a x)    = HsIntPrim a x+convertLit (HsWordPrim a x)   = HsWordPrim a x+convertLit (HsInt8Prim a x)   = HsInt8Prim a x+convertLit (HsInt16Prim a x)  = HsInt16Prim a x+convertLit (HsInt32Prim a x)  = HsInt32Prim a x+convertLit (HsInt64Prim a x)  = HsInt64Prim a x+convertLit (HsWord8Prim a x)  = HsWord8Prim a x+convertLit (HsWord16Prim a x) = HsWord16Prim a x+convertLit (HsWord32Prim a x) = HsWord32Prim a x+convertLit (HsWord64Prim a x) = HsWord64Prim a x+convertLit (HsFloatPrim a x)  = HsFloatPrim a x+convertLit (HsDoublePrim a x) = HsDoublePrim a x+ {- Note [ol_rebindable] ~~~~~~~~~~~~~~~~~~~~ The ol_rebindable field is True if this literal is actually using rebindable syntax.  Specifically: -  False iff ol_witness is the standard one-  True  iff ol_witness is non-standard+  False iff ol_from_fun / ol_witness is the standard one+  True  iff ol_from_fun / ol_witness is non-standard  Equivalently it's True if   a) RebindableSyntax is on   b) the witness for fromInteger/fromRational/fromString      that happens to be in scope isn't the standard one--Note [Overloaded literal witnesses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-*Before* type checking, the HsExpr in an HsOverLit is the-name of the coercion function, 'fromInteger' or 'fromRational'.-*After* type checking, it is a witness for the literal, such as-        (fromInteger 3) or lit_78-This witness should replace the literal.--This dual role is unusual, because we're replacing 'fromInteger' with-a call to fromInteger.  Reason: it allows commoning up of the fromInteger-calls, which wouldn't be possible if the desugarer made the application.--The PostTcType in each branch records the type the overload literal is-found to have. -} --- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module MatchLit)-instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where-  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2-  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2-  _ == _ = panic "Eq HsOverLit"--instance Eq OverLitVal where-  (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2-  (HsFractional f1)   == (HsFractional f2)   = f1 == f2-  (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2-  _                   == _                   = False--instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where-  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2-  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2-  compare _ _ = panic "Ord HsOverLit"--instance Ord OverLitVal where-  compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2-  compare (HsIntegral _)      (HsFractional _)    = LT-  compare (HsIntegral _)      (HsIsString _ _)    = LT-  compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2-  compare (HsFractional _)    (HsIntegral   _)    = GT-  compare (HsFractional _)    (HsIsString _ _)    = LT-  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `compare` s2-  compare (HsIsString _ _)    (HsIntegral   _)    = GT-  compare (HsIsString _ _)    (HsFractional _)    = GT- -- Instance specific to GhcPs, need the SourceText-instance Outputable (HsLit (GhcPass p)) where+instance IsPass p => Outputable (HsLit (GhcPass p)) where     ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)-    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)+    ppr (HsCharPrim st c)   = pprWithSourceText st (pprPrimChar c)     ppr (HsString st s)     = pprWithSourceText st (pprHsString s)+    ppr (HsMultilineString st s) =+      case st of+        NoSourceText -> pprHsString s+        SourceText src -> vcat $ map text $ split '\n' (unpackFS src)     ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)     ppr (HsInt _ i)       = pprWithSourceText (il_text i) (integer (il_value i))-    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)-    ppr (HsRat _ f _)       = ppr f     ppr (HsFloatPrim _ f)   = ppr f <> primFloatSuffix     ppr (HsDoublePrim _ d)  = ppr d <> primDoubleSuffix     ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)+    ppr (HsInt8Prim st i)   = pprWithSourceText st (pprPrimInt8 i)+    ppr (HsInt16Prim st i)  = pprWithSourceText st (pprPrimInt16 i)+    ppr (HsInt32Prim st i)  = pprWithSourceText st (pprPrimInt32 i)+    ppr (HsInt64Prim st i)  = pprWithSourceText st (pprPrimInt64 i)     ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)-    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)-    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)-    ppr (XLit x) = ppr x--pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc-pp_st_suffix NoSourceText         _ doc = doc-pp_st_suffix (SourceText st) suffix _   = text st <> suffix+    ppr (HsWord8Prim st w)  = pprWithSourceText st (pprPrimWord8 w)+    ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w)+    ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w)+    ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w)+    ppr (XLit x)            = case ghcPass @p of+      GhcTc -> case x of+         (HsInteger st i _) -> pprWithSourceText st (integer i)+         (HsRat  f _)       -> ppr f  -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p        => Outputable (HsOverLit (GhcPass p)) where-  ppr (OverLit {ol_val=val, ol_witness=witness})-        = ppr val <+> (whenPprDebug (parens (pprExpr witness)))-  ppr (XOverLit x) = ppr x+  ppr (OverLit {ol_val=val, ol_ext=ext})+        = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext)))  instance Outputable OverLitVal where   ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))@@ -268,49 +258,43 @@ -- mainly for too reasons: --  * We do not want to expose their internal representation --  * The warnings become too messy-pmPprHsLit :: HsLit (GhcPass x) -> SDoc+pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc pmPprHsLit (HsChar _ c)       = pprHsChar c pmPprHsLit (HsCharPrim _ c)   = pprHsChar c pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)+pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i)        = integer (il_value i) pmPprHsLit (HsIntPrim _ i)    = integer i pmPprHsLit (HsWordPrim _ w)   = integer w+pmPprHsLit (HsInt8Prim _ i)   = integer i+pmPprHsLit (HsInt16Prim _ i)  = integer i+pmPprHsLit (HsInt32Prim _ i)  = integer i pmPprHsLit (HsInt64Prim _ i)  = integer i+pmPprHsLit (HsWord8Prim _ w)  = integer w+pmPprHsLit (HsWord16Prim _ w) = integer w+pmPprHsLit (HsWord32Prim _ w) = integer w pmPprHsLit (HsWord64Prim _ w) = integer w-pmPprHsLit (HsInteger _ i _)  = integer i-pmPprHsLit (HsRat _ f _)      = ppr f pmPprHsLit (HsFloatPrim _ f)  = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d-pmPprHsLit (XLit x)           = ppr x+pmPprHsLit (XLit x)           = case ghcPass @p of+  GhcTc -> case x of+   (HsInteger _ i _)  -> integer i+   (HsRat f _)        -> ppr f --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs--- to be parenthesized under precedence @p@.-hsLitNeedsParens :: PprPrec -> HsLit x -> Bool-hsLitNeedsParens p = go-  where-    go (HsChar {})        = False-    go (HsCharPrim {})    = False-    go (HsString {})      = False-    go (HsStringPrim {})  = False-    go (HsInt _ x)        = p > topPrec && il_neg x-    go (HsIntPrim _ x)    = p > topPrec && x < 0-    go (HsWordPrim {})    = False-    go (HsInt64Prim _ x)  = p > topPrec && x < 0-    go (HsWord64Prim {})  = False-    go (HsInteger _ x _)  = p > topPrec && x < 0-    go (HsRat _ x _)      = p > topPrec && fl_neg x-    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x-    go (HsDoublePrim _ x) = p > topPrec && fl_neg x-    go (XLit _)           = False+negateOverLitVal :: OverLitVal -> OverLitVal+negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)+negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)+negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal--- @ol@ needs to be parenthesized under precedence @p@.-hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool-hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv-  where-    go :: OverLitVal -> Bool-    go (HsIntegral x)   = p > topPrec && il_neg x-    go (HsFractional x) = p > topPrec && fl_neg x-    go (HsIsString {})  = False-hsOverLitNeedsParens _ (XOverLit { }) = False+instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where+  compare (OverLit _ val1)  (OverLit _ val2) = val1 `compare` val2+  compare (XOverLit  val1)  (XOverLit  val2) = val1 `compare` val2+  compare _ _ = panic "Ord HsOverLit"++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where+  (OverLit _ val1) == (OverLit _ val2) = val1 == val2+  (XOverLit  val1) == (XOverLit  val2) = val1 == val2+  _ == _ = panic "Eq HsOverLit"
GHC/Hs/Pat.hs view
@@ -1,826 +1,1176 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[PatSyntax]{Abstract Haskell syntax---patterns}--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE FlexibleInstances #-}--module GHC.Hs.Pat (-        Pat(..), InPat, OutPat, LPat,-        ListPatTc(..),--        HsConPatDetails, hsConPatArgs,-        HsRecFields(..), HsRecField'(..), LHsRecField',-        HsRecField, LHsRecField,-        HsRecUpdField, LHsRecUpdField,-        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,-        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,--        mkPrefixConPat, mkCharLitPat, mkNilPat,--        looksLazyPatBind,-        isBangedLPat,-        patNeedsParens, parenthesizePat,-        isIrrefutableHsPat,--        collectEvVarsPat, collectEvVarsPats,--        pprParendLPat, pprConArgs-    ) where--import GhcPrelude--import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)---- friends:-import GHC.Hs.Binds-import GHC.Hs.Lit-import GHC.Hs.Extension-import GHC.Hs.Types-import TcEvidence-import BasicTypes--- others:-import PprCore          ( {- instance OutputableBndr TyVar -} )-import TysWiredIn-import Var-import RdrName ( RdrName )-import ConLike-import DataCon-import TyCon-import Outputable-import Type-import SrcLoc-import Bag -- collect ev vars from pats-import DynFlags( gopt, GeneralFlag(..) )-import Maybes--- libraries:-import Data.Data hiding (TyCon,Fixity)--type InPat p  = LPat p        -- No 'Out' constructors-type OutPat p = LPat p        -- No 'In' constructors--type LPat p = XRec p Pat---- | Pattern------ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'---- For details on above see note [Api annotations] in ApiAnnotation-data Pat p-  =     ------------ Simple patterns ----------------    WildPat     (XWildPat p)        -- ^ Wildcard Pattern-        -- The sole reason for a type on a WildPat is to-        -- support hsPatType :: Pat Id -> Type--       -- AZ:TODO above comment needs to be updated-  | VarPat      (XVarPat p)-                (Located (IdP p))  -- ^ Variable Pattern--                             -- See Note [Located RdrNames] in GHC.Hs.Expr-  | LazyPat     (XLazyPat p)-                (LPat p)                -- ^ Lazy Pattern-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'--    -- For details on above see note [Api annotations] in ApiAnnotation--  | AsPat       (XAsPat p)-                (Located (IdP p)) (LPat p)    -- ^ As pattern-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'--    -- For details on above see note [Api annotations] in ApiAnnotation--  | ParPat      (XParPat p)-                (LPat p)                -- ^ Parenthesised pattern-                                        -- See Note [Parens in HsSyn] in GHC.Hs.Expr-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,-    --                                    'ApiAnnotation.AnnClose' @')'@--    -- For details on above see note [Api annotations] in ApiAnnotation-  | BangPat     (XBangPat p)-                (LPat p)                -- ^ Bang pattern-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang'--    -- For details on above see note [Api annotations] in ApiAnnotation--        ------------ Lists, tuples, arrays ----------------  | ListPat     (XListPat p)-                [LPat p]-                   -- For OverloadedLists a Just (ty,fn) gives-                   -- overall type of the pattern, and the toList--- function to convert the scrutinee to a list value--    -- ^ Syntactic List-    ---    -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,-    --                                    'ApiAnnotation.AnnClose' @']'@--    -- For details on above see note [Api annotations] in ApiAnnotation--  | TuplePat    (XTuplePat p)-                  -- after typechecking, holds the types of the tuple components-                [LPat p]         -- Tuple sub-patterns-                Boxity           -- UnitPat is TuplePat []-        -- You might think that the post typechecking Type was redundant,-        -- because we can get the pattern type by getting the types of the-        -- sub-patterns.-        -- But it's essential-        --      data T a where-        --        T1 :: Int -> T Int-        --      f :: (T a, a) -> Int-        --      f (T1 x, z) = z-        -- When desugaring, we must generate-        --      f = /\a. \v::a.  case v of (t::T a, w::a) ->-        --                       case t of (T1 (x::Int)) ->-        -- Note the (w::a), NOT (w::Int), because we have not yet-        -- refined 'a' to Int.  So we must know that the second component-        -- of the tuple is of type 'a' not Int.  See selectMatchVar-        -- (June 14: I'm not sure this comment is right; the sub-patterns-        --           will be wrapped in CoPats, no?)-    -- ^ Tuple sub-patterns-    ---    -- - 'ApiAnnotation.AnnKeywordId' :-    --            'ApiAnnotation.AnnOpen' @'('@ or @'(#'@,-    --            'ApiAnnotation.AnnClose' @')'@ or  @'#)'@--  | SumPat      (XSumPat p)        -- GHC.Hs.PlaceHolder before typechecker, filled in-                                   -- afterwards with the types of the-                                   -- alternative-                (LPat p)           -- Sum sub-pattern-                ConTag             -- Alternative (one-based)-                Arity              -- Arity (INVARIANT: ≥ 2)-    -- ^ Anonymous sum pattern-    ---    -- - 'ApiAnnotation.AnnKeywordId' :-    --            'ApiAnnotation.AnnOpen' @'(#'@,-    --            'ApiAnnotation.AnnClose' @'#)'@--    -- For details on above see note [Api annotations] in ApiAnnotation--        ------------ Constructor patterns ----------------  | ConPatIn    (Located (IdP p))-                (HsConPatDetails p)-    -- ^ Constructor Pattern In--  | ConPatOut {-        pat_con     :: Located ConLike,-        pat_arg_tys :: [Type],          -- The universal arg types, 1-1 with the universal-                                        -- tyvars of the constructor/pattern synonym-                                        --   Use (conLikeResTy pat_con pat_arg_tys) to get-                                        --   the type of the pattern--        pat_tvs   :: [TyVar],           -- Existentially bound type variables-                                        -- in correctly-scoped order e.g. [k:*, x:k]-        pat_dicts :: [EvVar],           -- Ditto *coercion variables* and *dictionaries*-                                        -- One reason for putting coercion variable here, I think,-                                        --      is to ensure their kinds are zonked--        pat_binds :: TcEvBinds,         -- Bindings involving those dictionaries-        pat_args  :: HsConPatDetails p,-        pat_wrap  :: HsWrapper          -- Extra wrapper to pass to the matcher-                                        -- Only relevant for pattern-synonyms;-                                        --   ignored for data cons-    }-    -- ^ Constructor Pattern Out--        ------------ View patterns ----------------  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | ViewPat       (XViewPat p)     -- The overall type of the pattern-                                   -- (= the argument type of the view function)-                                   -- for hsPatType.-                  (LHsExpr p)-                  (LPat p)-    -- ^ View Pattern--        ------------ Pattern splices ----------------  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@-  --        'ApiAnnotation.AnnClose' @')'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | SplicePat       (XSplicePat p)-                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)--        ------------ Literal and n+k patterns ----------------  | LitPat          (XLitPat p)-                    (HsLit p)           -- ^ Literal Pattern-                                        -- Used for *non-overloaded* literal patterns:-                                        -- Int#, Char#, Int, Char, String, etc.--  | NPat                -- Natural Pattern-                        -- Used for all overloaded literals,-                        -- including overloaded strings with -XOverloadedStrings-                    (XNPat p)            -- Overall type of pattern. Might be-                                         -- different than the literal's type-                                         -- if (==) or negate changes the type-                    (Located (HsOverLit p))     -- ALWAYS positive-                    (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for-                                           -- negative patterns, Nothing-                                           -- otherwise-                    (SyntaxExpr p)       -- Equality checker, of type t->t->Bool--  -- ^ Natural Pattern-  ---  -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@--  -- For details on above see note [Api annotations] in ApiAnnotation-  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern-                    (Located (IdP p))        -- n+k pattern-                    (Located (HsOverLit p))  -- It'll always be an HsIntegral-                    (HsOverLit p)       -- See Note [NPlusK patterns] in TcPat-                     -- NB: This could be (PostTc ...), but that induced a-                     -- a new hs-boot file. Not worth it.--                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool-                    (SyntaxExpr p)   -- Name of '-' (see RnEnv.lookupSyntaxName)-  -- ^ n+k pattern--        ------------ Pattern type signatures ----------------  -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'--  -- For details on above see note [Api annotations] in ApiAnnotation-  | SigPat          (XSigPat p)             -- After typechecker: Type-                    (LPat p)                -- Pattern with a type signature-                    (LHsSigWcType (NoGhcTc p)) --  Signature can bind both-                                               --  kind and type vars--    -- ^ Pattern with a type signature--        ------------ Pattern coercions (translation only) ----------------  | CoPat       (XCoPat p)-                HsWrapper           -- Coercion Pattern-                                    -- If co :: t1 ~ t2, p :: t2,-                                    -- then (CoPat co p) :: t1-                (Pat p)             -- Why not LPat?  Ans: existing locn will do-                Type                -- Type of whole pattern, t1-        -- During desugaring a (CoPat co pat) turns into a cast with 'co' on-        -- the scrutinee, followed by a match on 'pat'-    -- ^ Coercion Pattern--  -- | Trees that Grow extension point for new constructors-  | XPat-      (XXPat p)---- -----------------------------------------------------------------------data ListPatTc-  = ListPatTc-      Type                             -- The type of the elements-      (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax--type instance XWildPat GhcPs = NoExtField-type instance XWildPat GhcRn = NoExtField-type instance XWildPat GhcTc = Type--type instance XVarPat  (GhcPass _) = NoExtField-type instance XLazyPat (GhcPass _) = NoExtField-type instance XAsPat   (GhcPass _) = NoExtField-type instance XParPat  (GhcPass _) = NoExtField-type instance XBangPat (GhcPass _) = NoExtField---- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap--- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for--- `SyntaxExpr`-type instance XListPat GhcPs = NoExtField-type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn)-type instance XListPat GhcTc = ListPatTc--type instance XTuplePat GhcPs = NoExtField-type instance XTuplePat GhcRn = NoExtField-type instance XTuplePat GhcTc = [Type]--type instance XSumPat GhcPs = NoExtField-type instance XSumPat GhcRn = NoExtField-type instance XSumPat GhcTc = [Type]--type instance XViewPat GhcPs = NoExtField-type instance XViewPat GhcRn = NoExtField-type instance XViewPat GhcTc = Type--type instance XSplicePat (GhcPass _) = NoExtField-type instance XLitPat    (GhcPass _) = NoExtField--type instance XNPat GhcPs = NoExtField-type instance XNPat GhcRn = NoExtField-type instance XNPat GhcTc = Type--type instance XNPlusKPat GhcPs = NoExtField-type instance XNPlusKPat GhcRn = NoExtField-type instance XNPlusKPat GhcTc = Type--type instance XSigPat GhcPs = NoExtField-type instance XSigPat GhcRn = NoExtField-type instance XSigPat GhcTc = Type--type instance XCoPat  (GhcPass _) = NoExtField--type instance XXPat   (GhcPass _) = NoExtCon---- -------------------------------------------------------------------------- | Haskell Constructor Pattern Details-type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))--hsConPatArgs :: HsConPatDetails p -> [LPat p]-hsConPatArgs (PrefixCon ps)   = ps-hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)-hsConPatArgs (InfixCon p1 p2) = [p1,p2]---- | Haskell Record Fields------ HsRecFields is used only for patterns and expressions (not data type--- declarations)-data HsRecFields p arg         -- A bunch of record fields-                                --      { x = 3, y = True }-        -- Used for both expressions and patterns-  = HsRecFields { rec_flds   :: [LHsRecField p arg],-                  rec_dotdot :: Maybe (Located Int) }  -- Note [DotDot fields]-  deriving (Functor, Foldable, Traversable)----- Note [DotDot fields]--- ~~~~~~~~~~~~~~~~~~~~--- The rec_dotdot field means this:---   Nothing => the normal case---   Just n  => the group uses ".." notation,------ In the latter case:------   *before* renamer: rec_flds are exactly the n user-written fields------   *after* renamer:  rec_flds includes *all* fields, with---                     the first 'n' being the user-written ones---                     and the remainder being 'filled in' implicitly---- | Located Haskell Record Field-type LHsRecField' p arg = Located (HsRecField' p arg)---- | Located Haskell Record Field-type LHsRecField  p arg = Located (HsRecField  p arg)---- | Located Haskell Record Update Field-type LHsRecUpdField p   = Located (HsRecUpdField p)---- | Haskell Record Field-type HsRecField    p arg = HsRecField' (FieldOcc p) arg---- | Haskell Record Update Field-type HsRecUpdField p     = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)---- | Haskell Record Field------ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual',------ For details on above see note [Api annotations] in ApiAnnotation-data HsRecField' id arg = HsRecField {-        hsRecFieldLbl :: Located id,-        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning-        hsRecPun      :: Bool           -- ^ Note [Punning]-  } deriving (Data, Functor, Foldable, Traversable)----- Note [Punning]--- ~~~~~~~~~~~~~~--- If you write T { x, y = v+1 }, the HsRecFields will be---      HsRecField x x True ...---      HsRecField y (v+1) False ...--- That is, for "punned" field x is expanded (in the renamer)--- to x=x; but with a punning flag so we can detect it later--- (e.g. when pretty printing)------ If the original field was qualified, we un-qualify it, thus---    T { A.x } means T { A.x = x }----- Note [HsRecField and HsRecUpdField]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- A HsRecField (used for record construction and pattern matching)--- contains an unambiguous occurrence of a field (i.e. a FieldOcc).--- We can't just store the Name, because thanks to--- DuplicateRecordFields this may not correspond to the label the user--- wrote.------ A HsRecUpdField (used for record update) contains a potentially--- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The--- renamer will fill in the selector function if it can, but if the--- selector is ambiguous the renamer will defer to the typechecker.--- After the typechecker, a unique selector will have been determined.------ The renamer produces an Unambiguous result if it can, rather than--- just doing the lookup in the typechecker, so that completely--- unambiguous updates can be represented by 'DsMeta.repUpdFields'.------ For example, suppose we have:------     data S = MkS { x :: Int }---     data T = MkT { x :: Int }------     f z = (z { x = 3 }) :: S------ The parsed HsRecUpdField corresponding to the record update will have:------     hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName------ After the renamer, this will become:------     hsRecFieldLbl = Ambiguous   "x" noExtField :: AmbiguousFieldOcc Name------ (note that the Unambiguous constructor is not type-correct here).--- The typechecker will determine the particular selector:------     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id------ See also Note [Disambiguating record fields] in TcExpr.--hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]-hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)---- Probably won't typecheck at once, things have changed :/-hsRecFieldsArgs :: HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)--hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)-hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl--hsRecFieldId :: HsRecField GhcTc arg -> Located Id-hsRecFieldId = hsRecFieldSel--hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl--hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id-hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc--hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl---{--************************************************************************-*                                                                      *-*              Printing patterns-*                                                                      *-************************************************************************--}--instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where-    ppr = pprPat--pprPatBndr :: OutputableBndr name => name -> SDoc-pprPatBndr var                  -- Print with type info if -dppr-debug is on-  = getPprStyle $ \ sty ->-    if debugStyle sty then-        parens (pprBndr LambdaBind var)         -- Could pass the site to pprPat-                                                -- but is it worth it?-    else-        pprPrefixOcc var--pprParendLPat :: (OutputableBndrId p)-              => PprPrec -> LPat (GhcPass p) -> SDoc-pprParendLPat p = pprParendPat p . unLoc--pprParendPat :: (OutputableBndrId p)-             => PprPrec -> Pat (GhcPass p) -> SDoc-pprParendPat p pat = sdocWithDynFlags $ \ dflags ->-                     if need_parens dflags pat-                     then parens (pprPat pat)-                     else  pprPat pat-  where-    need_parens dflags pat-      | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags-      | otherwise       = patNeedsParens p pat-      -- For a CoPat we need parens if we are going to show it, which-      -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)-      -- But otherwise the CoPat is discarded, so it-      -- is the pattern inside that matters.  Sigh.--pprPat :: (OutputableBndrId p) => Pat (GhcPass p) -> SDoc-pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)-pprPat (WildPat _)              = char '_'-pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat-pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat-pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',-                                        pprParendLPat appPrec pat]-pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]-pprPat (ParPat _ pat)           = parens (ppr pat)-pprPat (LitPat _ s)             = ppr s-pprPat (NPat _ l Nothing  _)    = ppr l-pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l-pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]-pprPat (SplicePat _ splice)     = pprSplice splice-pprPat (CoPat _ co pat _)       = pprHsWrapper co $ \parens-                                            -> if parens-                                                 then pprParendPat appPrec pat-                                                 else pprPat pat-pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty-pprPat (ListPat _ pats)         = brackets (interpp'SP pats)-pprPat (TuplePat _ pats bx)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Unit x`, not `(x)`-  | [pat] <- pats-  , Boxed <- bx-  = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]-  | otherwise-  = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)-pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)-pprPat (ConPatIn con details)   = pprUserCon (unLoc con) details-pprPat (ConPatOut { pat_con = con-                  , pat_tvs = tvs-                  , pat_dicts = dicts-                  , pat_binds = binds-                  , pat_args = details })-  = sdocWithDynFlags $ \dflags ->-       -- Tiresome; in TcBinds.tcRhs we print out a-       -- typechecked Pat in an error message,-       -- and we want to make sure it prints nicely-    if gopt Opt_PrintTypecheckerElaboration dflags then-        ppr con-          <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))-                         , ppr binds])-          <+> pprConArgs details-    else pprUserCon (unLoc con) details-pprPat (XPat n)                 = noExtCon n---pprUserCon :: (OutputableBndr con, OutputableBndrId p)-           => con -> HsConPatDetails (GhcPass p) -> SDoc-pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2-pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details--pprConArgs :: (OutputableBndrId p)-           => HsConPatDetails (GhcPass p) -> SDoc-pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)-pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1-                                  , pprParendLPat appPrec p2 ]-pprConArgs (RecCon rpats)   = ppr rpats--instance (Outputable arg)-      => Outputable (HsRecFields p arg) where-  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })-        = braces (fsep (punctuate comma (map ppr flds)))-  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })-        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))-        where-          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))--instance (Outputable p, Outputable arg)-      => Outputable (HsRecField' p arg) where-  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,-                    hsRecPun = pun })-    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)---{--************************************************************************-*                                                                      *-*              Building patterns-*                                                                      *-************************************************************************--}--mkPrefixConPat :: DataCon ->-                  [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p)--- Make a vanilla Prefix constructor pattern-mkPrefixConPat dc pats tys-  = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc)-                      , pat_tvs = []-                      , pat_dicts = []-                      , pat_binds = emptyTcEvBinds-                      , pat_args = PrefixCon pats-                      , pat_arg_tys = tys-                      , pat_wrap = idHsWrapper }--mkNilPat :: Type -> OutPat (GhcPass p)-mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]--mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p)-mkCharLitPat src c = mkPrefixConPat charDataCon-                          [noLoc $ LitPat noExtField (HsCharPrim src c)] []--{--************************************************************************-*                                                                      *-* Predicates for checking things about pattern-lists in EquationInfo   *-*                                                                      *-************************************************************************--\subsection[Pat-list-predicates]{Look for interesting things in patterns}--Unlike in the Wadler chapter, where patterns are either ``variables''-or ``constructors,'' here we distinguish between:-\begin{description}-\item[unfailable:]-Patterns that cannot fail to match: variables, wildcards, and lazy-patterns.--These are the irrefutable patterns; the two other categories-are refutable patterns.--\item[constructor:]-A non-literal constructor pattern (see next category).--\item[literal patterns:]-At least the numeric ones may be overloaded.-\end{description}--A pattern is in {\em exactly one} of the above three categories; `as'-patterns are treated specially, of course.--The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.--}--isBangedLPat :: LPat (GhcPass p) -> Bool-isBangedLPat = isBangedPat . unLoc--isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ p) = isBangedLPat p-isBangedPat (BangPat {}) = True-isBangedPat _            = False--looksLazyPatBind :: HsBind (GhcPass p) -> Bool--- Returns True of anything *except*---     a StrictHsBind (as above) or---     a VarPat--- In particular, returns True of a pattern binding with a compound pattern, like (I# x)--- Looks through AbsBinds-looksLazyPatBind (PatBind { pat_lhs = p })-  = looksLazyLPat p-looksLazyPatBind (AbsBinds { abs_binds = binds })-  = anyBag (looksLazyPatBind . unLoc) binds-looksLazyPatBind _-  = False--looksLazyLPat :: LPat (GhcPass p) -> Bool-looksLazyLPat = looksLazyPat . unLoc--looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ p)  = looksLazyLPat p-looksLazyPat (AsPat _ _ p) = looksLazyLPat p-looksLazyPat (BangPat {})  = False-looksLazyPat (VarPat {})   = False-looksLazyPat (WildPat {})  = False-looksLazyPat _             = True--isIrrefutableHsPat :: (OutputableBndrId p) => LPat (GhcPass p) -> Bool--- (isIrrefutableHsPat p) is true if matching against p cannot fail,--- in the sense of falling through to the next pattern.---      (NB: this is not quite the same as the (silly) defn---      in 3.17.2 of the Haskell 98 report.)------ WARNING: isIrrefutableHsPat returns False if it's in doubt.--- Specifically on a ConPatIn, which is what it sees for a--- (LPat Name) in the renamer, it doesn't know the size of the--- constructor family, so it returns False.  Result: only--- tuple patterns are considered irrefuable at the renamer stage.------ But if it returns True, the pattern is definitely irrefutable-isIrrefutableHsPat-  = goL-  where-    goL = go . unLoc--    go (WildPat {})        = True-    go (VarPat {})         = True-    go (LazyPat {})        = True-    go (BangPat _ pat)     = goL pat-    go (CoPat _ _ pat _)   = go  pat-    go (ParPat _ pat)      = goL pat-    go (AsPat _ _ pat)     = goL pat-    go (ViewPat _ _ pat)   = goL pat-    go (SigPat _ pat _)    = goL pat-    go (TuplePat _ pats _) = all goL pats-    go (SumPat {})         = False-                    -- See Note [Unboxed sum patterns aren't irrefutable]-    go (ListPat {})        = False--    go (ConPatIn {})       = False     -- Conservative-    go (ConPatOut-        { pat_con  = (dL->L _ (RealDataCon con))-        , pat_args = details })-                           =-      isJust (tyConSingleDataCon_maybe (dataConTyCon con))-      -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because-      -- the latter is false of existentials. See #4439-      && all goL (hsConPatArgs details)-    go (ConPatOut-        { pat_con = (dL->L _ (PatSynCon _pat)) })-                           = False -- Conservative-    go (ConPatOut{})       = panic "ConPatOut:Impossible Match" -- due to #15884-    go (LitPat {})         = False-    go (NPat {})           = False-    go (NPlusKPat {})      = False--    -- We conservatively assume that no TH splices are irrefutable-    -- since we cannot know until the splice is evaluated.-    go (SplicePat {})      = False--    go (XPat {})           = False--{- Note [Unboxed sum patterns aren't irrefutable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as-patterns. A simple example that demonstrates this is from #14228:--  pattern Just' x = (# x | #)-  pattern Nothing' = (# | () #)--  foo x = case x of-    Nothing' -> putStrLn "nothing"-    Just'    -> putStrLn "just"--In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,-as does not match an unboxed sum value of the same arity—namely, (# | y #)-(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the-minimum unboxed sum arity is 2.--Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'-case in foo to be unreachable, as GHC would mistakenly believe that Nothing'-is the only thing that could possibly be matched!--}---- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs--- parentheses under precedence @p@.-patNeedsParens :: PprPrec -> Pat p -> Bool-patNeedsParens p = go-  where-    go (NPlusKPat {})    = p > opPrec-    go (SplicePat {})    = False-    go (ConPatIn _ ds)   = conPatNeedsParens p ds-    go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp)-    go (SigPat {})       = p >= sigPrec-    go (ViewPat {})      = True-    go (CoPat _ _ p _)   = go p-    go (WildPat {})      = False-    go (VarPat {})       = False-    go (LazyPat {})      = False-    go (BangPat {})      = False-    go (ParPat {})       = False-    go (AsPat {})        = False-    go (TuplePat {})     = False-    go (SumPat {})       = False-    go (ListPat {})      = False-    go (LitPat _ l)      = hsLitNeedsParens p l-    go (NPat _ lol _ _)  = hsOverLitNeedsParens p (unLoc lol)-    go (XPat {})         = True -- conservative default---- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@--- needs parentheses under precedence @p@.-conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool-conPatNeedsParens p = go-  where-    go (PrefixCon args) = p >= appPrec && not (null args)-    go (InfixCon {})    = p >= opPrec-    go (RecCon {})      = False---- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and--- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.-parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)-parenthesizePat p lpat@(dL->L loc pat)-  | patNeedsParens p pat = cL loc (ParPat noExtField lpat)-  | otherwise            = lpat--{--% Collect all EvVars from all constructor patterns--}---- May need to add more cases-collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar-collectEvVarsPats = unionManyBags . map collectEvVarsPat--collectEvVarsLPat :: LPat GhcTc -> Bag EvVar-collectEvVarsLPat = collectEvVarsPat . unLoc--collectEvVarsPat :: Pat GhcTc -> Bag EvVar-collectEvVarsPat pat =-  case pat of-    LazyPat _ p      -> collectEvVarsLPat p-    AsPat _ _ p      -> collectEvVarsLPat p-    ParPat  _ p      -> collectEvVarsLPat p-    BangPat _ p      -> collectEvVarsLPat p-    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps-    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps-    SumPat _ p _ _   -> collectEvVarsLPat p-    ConPatOut {pat_dicts = dicts, pat_args  = args}-                     -> unionBags (listToBag dicts)-                                   $ unionManyBags-                                   $ map collectEvVarsLPat-                                   $ hsConPatArgs args-    SigPat  _ p _    -> collectEvVarsLPat p-    CoPat _ _ p _    -> collectEvVarsPat  p-    ConPatIn _  _    -> panic "foldMapPatBag: ConPatIn"-    _other_pat       -> emptyBag+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PatSyntax]{Abstract Haskell syntax---patterns}+-}++module GHC.Hs.Pat (+        Pat(..), LPat,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat,+        EpAnnSumPat(..),+        ConPatTc (..),+        ConLikeP,+        HsPatExpansion(..),+        XXPatGhcTc(..),++        HsConPatDetails, hsConPatArgs,+        HsRecFields(..), HsFieldBind(..), LHsFieldBind,+        HsRecField, LHsRecField,+        HsRecUpdField, LHsRecUpdField,+        RecFieldsDotDot(..),+        hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,++        mkPrefixConPat, mkCharLitPat, mkNilPat,++        isSimplePat, isPatSyn,+        looksLazyPatBind,+        isBangedLPat,+        gParPat, patNeedsParens, parenthesizePat,+        isIrrefutableHsPat,++        isBoringHsPat,++        collectEvVarsPat, collectEvVarsPats,++        pprParendLPat, pprConArgs,+        pprLPat+    ) where++import GHC.Prelude++import Language.Haskell.Syntax.Pat+import Language.Haskell.Syntax.Expr ( HsExpr )++import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprUntypedSplice, HsUntypedSpliceResult(..))++-- friends:+import GHC.Hs.Binds+import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import GHC.Parser.Annotation+import GHC.Hs.Extension+import GHC.Hs.Type+import GHC.Tc.Types.Evidence+import GHC.Types.Basic+import GHC.Types.SourceText+-- others:+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )+import GHC.Builtin.Types+import GHC.Types.Var+import GHC.Types.Name.Reader+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Utils.Outputable+import GHC.Core.Type+import GHC.Types.SrcLoc+import GHC.Data.Bag -- collect ev vars from pats+import GHC.Types.Name++import Data.Data+import qualified Data.List( map )++import qualified Data.List.NonEmpty as NE++type instance XWildPat GhcPs = NoExtField+type instance XWildPat GhcRn = NoExtField+type instance XWildPat GhcTc = Type++type instance XVarPat  (GhcPass _) = NoExtField++type instance XLazyPat GhcPs = EpToken "~"+type instance XLazyPat GhcRn = NoExtField+type instance XLazyPat GhcTc = NoExtField++type instance XAsPat   GhcPs = EpToken "@"+type instance XAsPat   GhcRn = NoExtField+type instance XAsPat   GhcTc = NoExtField++type instance XParPat  GhcPs = (EpToken "(", EpToken ")")+type instance XParPat  GhcRn = NoExtField+type instance XParPat  GhcTc = NoExtField++type instance XBangPat GhcPs = EpToken "!"+type instance XBangPat GhcRn = NoExtField+type instance XBangPat GhcTc = NoExtField++type instance XListPat GhcPs = AnnList ()+  -- After parsing, ListPat can refer to a built-in Haskell list pattern+  -- or an overloaded list pattern.+type instance XListPat GhcRn = NoExtField+  -- Built-in list patterns only.+  -- After renaming, overloaded list patterns are expanded to view patterns.+  -- See Note [Desugaring overloaded list patterns]+type instance XListPat GhcTc = Type+  -- List element type, for use in hsPatType.++type instance XTuplePat GhcPs = (EpaLocation, EpaLocation)+type instance XTuplePat GhcRn = NoExtField+type instance XTuplePat GhcTc = [Type]++type instance XOrPat GhcPs = NoExtField+type instance XOrPat GhcRn = NoExtField+type instance XOrPat GhcTc = Type++type instance XSumPat GhcPs = EpAnnSumPat+type instance XSumPat GhcRn = NoExtField+type instance XSumPat GhcTc = [Type]++type instance XConPat GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XConPat GhcRn = NoExtField+type instance XConPat GhcTc = ConPatTc++type instance XViewPat GhcPs = TokRarrow+type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)+  -- The @HsExpr GhcRn@ gives an inverse to the view function.+  -- This is used for overloaded lists in particular.+  -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn.++type instance XViewPat GhcTc = Type+  -- Overall type of the pattern+  -- (= the argument type of the view function), for hsPatType.++type instance XSplicePat GhcPs = NoExtField+type instance XSplicePat GhcRn = HsUntypedSpliceResult (Pat GhcRn) -- See Note [Lifecycle of a splice] in GHC.Hs.Expr+type instance XSplicePat GhcTc = DataConCantHappen++type instance XLitPat    (GhcPass _) = NoExtField++type instance XNPat GhcPs = EpToken "-"+type instance XNPat GhcRn = EpToken "-"+type instance XNPat GhcTc = Type++type instance XNPlusKPat GhcPs = EpToken "+"+type instance XNPlusKPat GhcRn = NoExtField+type instance XNPlusKPat GhcTc = Type++type instance XSigPat GhcPs = TokDcolon+type instance XSigPat GhcRn = NoExtField+type instance XSigPat GhcTc = Type++type instance XEmbTyPat GhcPs = EpToken "type"+type instance XEmbTyPat GhcRn = NoExtField+type instance XEmbTyPat GhcTc = Type++type instance XXPat GhcPs = DataConCantHappen+type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)+  -- Original pattern and its desugaring/expansion.+  -- See Note [Rebindable syntax and XXExprGhcRn].+type instance XXPat GhcTc = XXPatGhcTc+  -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn.+  -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position:+  -- see "XXExpr GhcTc" for the counterpart in expressions.++type instance ConLikeP GhcPs = RdrName          -- IdOccP GhcPs+type instance ConLikeP GhcRn = WithUserRdr Name -- IdOccP GhcRn+type instance ConLikeP GhcTc = ConLike++type instance XHsRecFields GhcPs = NoExtField+type instance XHsRecFields GhcRn = NoExtField+type instance XHsRecFields GhcTc = NoExtField++type instance XHsFieldBind _ = Maybe (EpToken "=")++-- The specificity of an invisible pattern from the parser is always+-- SpecifiedSpec. The specificity field supports code generated when deriving+-- newtype or via; see Note [Inferred invisible patterns].+type instance XInvisPat GhcPs = (EpToken "@", Specificity)+type instance XInvisPat GhcRn = Specificity+type instance XInvisPat GhcTc = Type+++{- Note [Invisible binders in functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC Proposal #448 (section 1.5 Type arguments in lambda patterns) introduces+binders for invisible type arguments (@a-binders) in function equations and+lambdas, e.g.++  1.  {-# LANGUAGE TypeAbstractions #-}+      id1 :: a -> a+      id1 @t x = x :: t     -- @t-binder on the LHS of a function equation++  2.  {-# LANGUAGE TypeAbstractions #-}+      ex :: (Int8, Int16)+      ex = higherRank (\ @a x -> maxBound @a - x )+                            -- @a-binder in a lambda pattern in an argument+                            -- to a higher-order function+      higherRank :: (forall a. (Num a, Bounded a) => a -> a) -> (Int8, Int16)+      higherRank f = (f 42, f 42)++In the AST, invisible patterns are represented as InvisPat constructor inside of Pat:+    data Pat p+      = ...+      | InvisPat (LHsType p)+      ...++Just like `BangPat`, the `Pat` data type allows `InvisPat` to appear in+nested positions. But this is often not allowed; e.g.++   f @a x = rhs    -- YES+   f (@a,x) = rhs  -- NO++   g = do { @a <- e1; e2 }         -- NO+   h x = case x of { @a -> rhs }   -- NO++Rather than excluding these things syntactically, we reject them in the renamer+(see `rn_pats_general`).  This actually gives a better error message than we+would get if they were rejected in the parser.++Each pattern is either visible (not prefixed with @) or invisible (prefixed with @):+    f :: forall a. forall b -> forall c. Int -> ...+    f @a b @c x  = ...++In this example, the arg-patterns are+    1. InvisPat @a     -- in the type sig: forall a.+    2. VarPat b        -- in the type sig: forall b ->+    3. InvisPat @c     -- in the type sig: forall c.+    4. VarPat x        -- in the type sig: Int ->++Invisible patterns are always type patterns, i.e. they are matched with+forall-bound type variables in the signature. Consequently, those variables (and+their binders) are erased during compilation, having no effect on program+execution at runtime.++Visible patterns, on the other hand, may be matched with ordinary function+arguments (Int ->) as well as required type arguments (forall b ->). This means+that a visible pattern may either be erased or retained, and we only find out in+the type checker, namely in tcMatchPats, where we match up all arg-patterns with+quantifiers from the type signature.++In other words, invisible patterns are always /erased/, while visible patterns+are sometimes /erased/ and sometimes /retained/.++The desugarer has no use for erased patterns, as the type checker generates+HsWrappers to bind the corresponding type variables. Erased patterns are simply+discarded inside tcMatchPats, where we know if visible pattern retained or erased.+-}++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnSumPat = EpAnnSumPat+      { sumPatParens      :: (EpaLocation, EpaLocation)+      , sumPatVbarsBefore :: [EpToken "|"]+      , sumPatVbarsAfter  :: [EpToken "|"]+      } deriving Data++instance NoAnn EpAnnSumPat where+  noAnn = EpAnnSumPat (noAnn, noAnn) [] []++-- ---------------------------------------------------------------------++-- | Extension constructor for Pat, added after typechecking.+data XXPatGhcTc+  = -- | Coercion Pattern (translation only)+    --+    -- During desugaring a (CoPat co pat) turns into a cast with 'co' on the+    -- scrutinee, followed by a match on 'pat'.+    CoPat+      { -- | Coercion Pattern+        -- If co :: t1 ~ t2, p :: t2,+        -- then (CoPat co p) :: t1+        co_cpt_wrap :: HsWrapper++      , -- | Why not LPat?  Ans: existing locn will do+        co_pat_inner :: Pat GhcTc++      , -- | Type of whole pattern, t1+        co_pat_ty :: Type+      }+  -- | Pattern expansion: original pattern, and desugared pattern,+  -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.+  -- See Note [Rebindable syntax and XXExprGhcRn].+  | ExpansionPat (Pat GhcRn) (Pat GhcTc)+++-- See Note [Rebindable syntax and XXExprGhcRn].+data HsPatExpansion a b+  = HsPatExpanded a b+  deriving Data++-- | This is the extension field for ConPat, added after typechecking+-- It adds quite a few extra fields, to support elaboration of pattern matching.+data ConPatTc+  = ConPatTc+    { -- | The universal arg types  1-1 with the universal+      -- tyvars of the constructor/pattern synonym+      -- Use (conLikeResTy pat_con cpt_arg_tys) to get+      -- the type of the pattern+      cpt_arg_tys :: [Type]++    , -- | Existentially bound type variables+      -- in correctly-scoped order e.g. [k:*  x:k]+      cpt_tvs   :: [TyVar]++    , -- | Ditto *coercion variables* and *dictionaries*+      -- One reason for putting coercion variable here  I think+      --      is to ensure their kinds are zonked+      cpt_dicts :: [EvVar]++    , -- | Bindings involving those dictionaries+      cpt_binds :: TcEvBinds++    , -- | Extra wrapper to pass to the matcher+      -- Only relevant for pattern-synonyms;+      --   ignored for data cons+      cpt_wrap  :: HsWrapper+    }+++hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p]+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds)++hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg]+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds)++hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p+hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS++hsRecFieldId :: HsRecField GhcTc arg -> Id+hsRecFieldId = hsRecFieldSel++{-+************************************************************************+*                                                                      *+*              Printing patterns+*                                                                      *+************************************************************************+-}++instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot)+      => Outputable (HsRecFields p arg) where+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })+        = braces (fsep (punctuate comma (map ppr flds)))+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) })+        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))+        where+          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))++instance (Outputable p, OutputableBndr p, Outputable arg)+      => Outputable (HsFieldBind p arg) where+  ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,+                     hfbPun = pun })+    = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)++instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where+    ppr = pprPat++-- See Note [Rebindable syntax and XXExprGhcRn].+instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where+  ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)++pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc+pprLPat (L _ e) = pprPat e++-- | Print with type info if -dppr-debug is on+pprPatBndr :: OutputableBndr name => name -> SDoc+pprPatBndr var+  = getPprDebug $ \case+      True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat+                                              -- but is it worth it?+      False -> pprPrefixOcc var++pprParendLPat :: (OutputableBndrId p)+              => PprPrec -> LPat (GhcPass p) -> SDoc+pprParendLPat p = pprParendPat p . unLoc++pprParendPat :: forall p. OutputableBndrId p+             => PprPrec+             -> Pat (GhcPass p)+             -> SDoc+pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \ print_tc_elab ->+    if need_parens print_tc_elab pat+    then parens (pprPat pat)+    else pprPat pat+  where+    need_parens print_tc_elab pat+      | GhcTc <- ghcPass @p+      , XPat (CoPat {}) <- pat+      = print_tc_elab++      | otherwise+      = patNeedsParens p pat+      -- For a CoPat we need parens if we are going to show it, which+      -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)+      -- But otherwise the CoPat is discarded, so it+      -- is the pattern inside that matters.  Sigh.++pprPat :: forall p. (OutputableBndrId p) => Pat (GhcPass p) -> SDoc+pprPat (VarPat _ lvar)          = pprPatBndr (unLoc lvar)+pprPat (WildPat _)              = char '_'+pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat+pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat+pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',+                                        pprParendLPat appPrec pat]+pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]+pprPat (ParPat _ pat)           = parens (ppr pat)+pprPat (LitPat _ s)             = ppr s+pprPat (NPat _ l Nothing  _)    = ppr l+pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l+pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr_n, char '+', ppr k]+  where ppr_n = case ghcPass @p of+                  GhcPs -> ppr n+                  GhcRn -> ppr n+                  GhcTc -> ppr n+pprPat (SplicePat ext splice)   =+    case ghcPass @p of+      GhcPs -> pprUntypedSplice True Nothing splice+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) splice+      GhcRn | HsUntypedSpliceTop _ p  <- ext -> ppr p+      GhcTc -> dataConCantHappen ext+pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty+pprPat (ListPat _ pats)         = brackets (interpp'SP pats)+pprPat (OrPat _ pats)           = pprWithSemis ppr (NE.toList pats)+pprPat (TuplePat _ pats bx)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `MkSolo x`, not `(x)`+  | [pat] <- pats+  , Boxed <- bx+  = hcat [text (mkTupleStr Boxed dataName 1), pprParendLPat appPrec pat]+  | otherwise+  = tupleParens (boxityTupleSort bx) (pprWithCommas ppr pats)+pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity)+pprPat (ConPat { pat_con = con+               , pat_args = details+               , pat_con_ext = ext+               }+       )+  = case ghcPass @p of+      GhcPs -> pprUserCon (unLoc con) details+      GhcRn -> pprUserCon (unLoc con) details+      GhcTc -> sdocOption sdocPrintTypecheckerElaboration $ \case+        False -> pprUserCon (unLoc con) details+        True  ->+          -- Tiresome; in 'GHC.Tc.Gen.Bind.tcRhs' we print out a typechecked Pat in an+          -- error message, and we want to make sure it prints nicely+          ppr con+            <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))+                           , ppr binds ])+            <+> pprConArgs details+        where ConPatTc { cpt_tvs = tvs+                       , cpt_dicts = dicts+                       , cpt_binds = binds+                       } = ext+pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp+pprPat (InvisPat x tp) = char '@' <> delimit (ppr tp)+  where+    delimit+      | inferred     = braces+      | needs_parens = parens+      | otherwise    = id+    inferred = case ghcPass @p of+      GhcPs -> snd x == InferredSpec+      GhcRn -> x == InferredSpec+      GhcTc -> False+    needs_parens = hsTypeNeedsParens appPrec $ unLoc $ hstp_body tp++pprPat (XPat ext) = case ghcPass @p of+  GhcRn -> case ext of+    HsPatExpanded orig _ -> pprPat orig+  GhcTc -> case ext of+    CoPat co pat _ ->+      pprHsWrapper co $ \parens ->+        if parens+        then pprParendPat appPrec pat+        else pprPat pat+    ExpansionPat orig _ -> pprPat orig++pprUserCon :: (OutputableBndr con, OutputableBndrId p,+                     Outputable (Anno (IdGhcP p)))+           => con -> HsConPatDetails (GhcPass p) -> SDoc+pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2+pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details++pprConArgs :: (OutputableBndrId p,+                     Outputable (Anno (IdGhcP p)))+           => HsConPatDetails (GhcPass p) -> SDoc+pprConArgs (PrefixCon pats)    = fsep (map (pprParendLPat appPrec) pats)+pprConArgs (InfixCon p1 p2)    = sep [ pprParendLPat appPrec p1+                                     , pprParendLPat appPrec p2 ]+pprConArgs (RecCon rpats)      = ppr rpats++{-+************************************************************************+*                                                                      *+*              Building patterns+*                                                                      *+************************************************************************+-}++mkPrefixConPat :: DataCon ->+                  [LPat GhcTc] -> [Type] -> LPat GhcTc+-- Make a vanilla Prefix constructor pattern+mkPrefixConPat dc pats tys+  = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)+                    , pat_args = PrefixCon pats+                    , pat_con_ext = ConPatTc+                      { cpt_tvs = []+                      , cpt_dicts = []+                      , cpt_binds = emptyTcEvBinds+                      , cpt_arg_tys = tys+                      , cpt_wrap = idHsWrapper+                      }+                    }++mkNilPat :: Type -> LPat GhcTc+mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]++mkCharLitPat :: SourceText -> Char -> LPat GhcTc+mkCharLitPat src c = mkPrefixConPat charDataCon+                          [noLocA $ LitPat noExtField (HsCharPrim src c)] []++{-+************************************************************************+*                                                                      *+* Predicates for checking things about pattern-lists in EquationInfo   *+*                                                                      *+************************************************************************++\subsection[Pat-list-predicates]{Look for interesting things in patterns}++Unlike in the Wadler chapter, where patterns are either ``variables''+or ``constructors,'' here we distinguish between:+\begin{description}+\item[unfailable:]+Patterns that cannot fail to match: variables, wildcards, and lazy+patterns.++These are the irrefutable patterns; the two other categories+are refutable patterns.++\item[constructor:]+A non-literal constructor pattern (see next category).++\item[literal patterns:]+At least the numeric ones may be overloaded.+\end{description}++A pattern is in {\em exactly one} of the above three categories; `as'+patterns are treated specially, of course.++The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.+-}++isBangedLPat :: LPat (GhcPass p) -> Bool+isBangedLPat = isBangedPat . unLoc++isBangedPat :: Pat (GhcPass p) -> Bool+isBangedPat (ParPat _ p) = isBangedLPat p+isBangedPat (BangPat {}) = True+isBangedPat _            = False++looksLazyPatBind :: HsBind GhcTc -> Bool+-- Returns True of anything *except*+--     a StrictHsBind (as above) or+--     a VarPat+-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)+-- Looks through AbsBinds+looksLazyPatBind (PatBind { pat_lhs = p })+  = looksLazyLPat p+looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))+  = any (looksLazyPatBind . unLoc) binds+looksLazyPatBind _+  = False++looksLazyLPat :: LPat (GhcPass p) -> Bool+looksLazyLPat = looksLazyPat . unLoc++looksLazyPat :: Pat (GhcPass p) -> Bool+looksLazyPat (ParPat _ p)  = looksLazyLPat p+looksLazyPat (AsPat _ _ p) = looksLazyLPat p+looksLazyPat (BangPat {})  = False+looksLazyPat (VarPat {})   = False+looksLazyPat (WildPat {})  = False+looksLazyPat _             = True++{-+Note [-XStrict and irrefutability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -XStrict is enabled the rules for irrefutability are slightly modified.+Specifically, the pattern in a program like++    do ~(Just hi) <- expr++cannot be considered irrefutable. The ~ here merely disables the bang that+-XStrict would usually apply, rendering the program equivalent to the following+without -XStrict++    do Just hi <- expr++To achieve make this pattern irrefutable with -XStrict the user would rather+need to write++    do ~(~(Just hi)) <- expr++Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat+takes care to check for two the irrefutability of the inner pattern when it+encounters a LazyPat and -XStrict is enabled.++See also Note [decideBangHood] in GHC.HsToCore.Utils.+-}++-- | @isIrrefutableHsPat p@ is true if matching against @p@ cannot fail+-- in the sense of falling through to the next pattern.+--      (NB: this is not quite the same as the (silly) defn+--      in 3.17.2 of the Haskell 98 report.)+--+-- If isIrrefutableHsPat returns 'True', the pattern is definitely irrefutable.+--+-- However, isIrrefutableHsPat returns 'False' if it's in doubt. It's a+-- best effort guess with the information we have available:+--+--  - we sometimes call 'isIrrefutableHsPat' from the renamer, in which case+--    we don't have type information to hand. This means we can't properly+--    handle GADTs, nor the result TyCon of COMPLETE pragmas.+--  - even when calling 'isIrrefutableHsPat' in the typechecker, we don't keep+--    track of any long distance information like the pattern-match checker does.+isIrrefutableHsPat+  :: forall p+  .  IsPass p+  => Bool                           -- ^ Are we in a @-XStrict@ context?+                                    -- See Note [-XStrict and irrefutability]+  -> (ConLikeP (GhcPass p) -> Bool) -- ^ How to check whether the 'ConLike' in a+                                    -- 'ConPat' pattern is irrefutable+  -> LPat (GhcPass p)               -- ^ The (located) pattern to check+  -> Bool                           -- Is it irrefutable?+isIrrefutableHsPat is_strict irref_conLike pat = go (unLoc pat)+  where+    goL (L _ p) = go p++    go :: Pat (GhcPass p) -> Bool+    go (WildPat {})        = True+    go (VarPat {})         = True+    go (LazyPat _ p')+      | is_strict+      = isIrrefutableHsPat False irref_conLike p'+      | otherwise          = True+    go (BangPat _ pat)     = goL pat+    go (ParPat _ pat)      = goL pat+    go (AsPat _ _ pat)     = goL pat+    go (ViewPat _ _ pat)   = goL pat+    go (SigPat _ pat _)    = goL pat+    go (TuplePat _ pats _) = all goL pats+    go (OrPat _ pats)      = any goL pats -- This is simplistic; see Note [Irrefutable or-patterns]+    go (SumPat {})         = False -- See Note [Unboxed sum patterns aren't irrefutable]+    go (ListPat {})        = False++    -- See Note [Irrefutability of ConPat]+    go (ConPat { pat_con = L _ con, pat_args = details })+                           =  irref_conLike con+                           && all goL (hsConPatArgs details)+    go (LitPat {})         = False+    go (NPat {})           = False+    go (NPlusKPat {})      = False++    -- We conservatively assume that no TH splices are irrefutable+    -- since we cannot know until the splice is evaluated.+    go (SplicePat {})      = False++    -- The behavior of this case is unimportant, as GHC will throw an error shortly+    -- after reaching this case for other reasons (see TcRnIllegalTypePattern).+    go (EmbTyPat {})       = True+    go (InvisPat {})       = True++    go (XPat ext)          = case ghcPass @p of+      GhcRn -> case ext of+        HsPatExpanded _ pat -> go pat+      GhcTc -> case ext of+        CoPat _ pat _ -> go pat+        ExpansionPat _ pat -> go pat++-- | Is the pattern any of combination of:+--+-- - (pat)+-- - pat :: Type+-- - ~pat+-- - !pat+-- - x (variable)+isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x))+isSimplePat p = case unLoc p of+  ParPat _ x -> isSimplePat x+  SigPat _ x _ -> isSimplePat x+  LazyPat _ x -> isSimplePat x+  BangPat _ x -> isSimplePat x+  VarPat _ x -> Just (unLoc x)+  _ -> Nothing++-- | Is this pattern boring from the perspective of pattern-match checking,+-- i.e. introduces no new pieces of long-distance information+-- which could influence pattern-match checking?+--+-- See Note [Boring patterns].+isBoringHsPat :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool+-- NB: it's always safe to return 'False' in this function; that just means+-- performing potentially-redundant pattern-match checking.+isBoringHsPat = goL+  where+    goL :: forall p. OutputableBndrId p => LPat (GhcPass p) -> Bool+    goL = go . unLoc++    go :: forall p. OutputableBndrId p => Pat (GhcPass p) -> Bool+    go = \case+      WildPat {} -> True+      VarPat  {} -> True+      LazyPat {} -> True+      BangPat _ pat     -> goL pat+      ParPat _ pat      -> goL pat+      AsPat {} -> False -- the pattern x@y links x and y together,+                        -- which is a nontrivial piece of information+      ViewPat _ _ pat   -> goL pat+      SigPat _ pat _    -> goL pat+      TuplePat _ pats _ -> all goL pats+      SumPat  _ pat _ _ -> goL pat+      ListPat _ pats    -> all goL pats+      ConPat { pat_con = con, pat_args = details }+        -> case ghcPass @p of+            GhcPs -> False -- conservative+            GhcRn -> False -- conservative+            GhcTc+              | isVanillaConLike (unLoc con)+              -> all goL (hsConPatArgs details)+              | otherwise+              -- A pattern match on a GADT constructor can introduce+              -- type-level information (for example, T18572).+              -> False+      OrPat _ pats  -> all goL pats+      LitPat {}     -> True+      NPat {}       -> True+      NPlusKPat {}  -> True+      SplicePat {}  -> False+      EmbTyPat {}   -> True+      InvisPat {}   -> True+      XPat ext ->+        case ghcPass @p of+         GhcRn -> case ext of+           HsPatExpanded _ pat -> go pat+         GhcTc -> case ext of+           CoPat _ pat _      -> go pat+           ExpansionPat _ pat -> go pat++isPatSyn :: LPat GhcTc -> Bool+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True+isPatSyn _ = False++{- Note [Irrefutability of ConPat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A constructor pattern `ConPat { pat_con, pat_args }` is irrefutable under two+conditions:++  Irref-ConLike: the constructor, pat_con, is itself irrefutable.+  Irref-args   : all of the argument patterns, pat_args, are irrefutable.++The (Irref-ConLike) condition can be stated as follows:++  Irref-DataCon: a DataCon is irrefutable iff it is the only constructor of its+                 parent type constructor.+  Irref-PatSyn:  a PatSyn is irrefutable iff there is a COMPLETE pragma+                 containing this PatSyn as its sole member.++To understand this, let's consider some simple examples:++  data A = MkA Int Bool+  data BC = B Int | C++  pattern P :: Maybe Int -> BC+  pattern P mb_i <- ( ( \ case { B i -> Just i; C -> Nothing } ) -> mb_i )+  {-# COMPLETE P #-}++In this case:++  - the pattern 'A p1 p2' (for patterns 'p1 :: Int', 'p2 :: Bool') is irrefutable+    precisely when both 'p1' and 'p2' are irrefutable (this is the same as+    irrefutability of tuple patterns);+  - neither of the patterns 'B p' (for any pattern 'p :: Int') or 'C' are irrefutable,+    because the parent type constructor 'BC' contains more than one data constructor,+  - the pattern 'P q', for a pattern 'q :: Maybe Int', is irrefutable precisely+    when 'q' is irrefutable, due to the COMPLETE pragma on 'P'.++Wrinkle [Irrefutability and COMPLETE pragma result TyCons]++  There is one subtlety in the Irref-PatSyn condition: COMPLETE pragmas may+  optionally specify a result TyCon, as explained in Note [Implementation of COMPLETE pragmas]+  in GHC.HsToCore.Pmc.Solver.++  So, for a COMPLETE pragma with a result TyCon, we would need to compute+  'completeMatchAppliesAtType' to ensure that the COMPLETE pragma is indeed+  applicable. Doing so is not so straightforward in 'isIrrefutableHsPat', for+  a couple of reasons:++    1. 'isIrrefutableHsPat' is called from within the renamer, which means+       we don't have the appropriate 'Type' to hand,+    2. Even when 'isIrrefutableHsPat' is called from within the typechecker,+       computing 'completeMatchAppliesAtType' for a 'ConPat' which might be+       nested deep inside the top-level call, such as++          ( ( _ , P (x :: Int) ) :: ( Int, Int )++        would require keeping track of types as we recur in 'isIrrefutableHsPat',+        which would be much more involved and require duplicating code from+        the pattern match checker (it performs this check using the notion+        of "match variables", which we don't have in the typechecker).++Note [Irrefutable or-patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When is an or-pattern ( p_1 ; ... ; p_n ) irrefutable? It certainly suffices+that individual pattern p_i is irrefutable, but it isn't necessary.++For example, with the datatype definition++  data ABC = A | B | C++the or-pattern ( B ; C ; A ) is irrefutable. Similarly, one can take into+account COMPLETE pragmas, e.g. (P ; R ; Q) is irrefutable in the presence of+{-# COMPLETE P, Q, R #-}. This would extend Note [Irrefutability of ConPat] to+the case of disjunctions of constructor patterns.++For now, the function 'isIrrefutableHsPat' does not take into account these+additional complications, and considers an or-pattern irrefutable precisely when+any of the summands are irrefutable. This pessimistic behaviour is OK: the contract+of 'isIrrefutableHsPat' is that it can only return 'True' for definitely irrefutable+patterns, but may conservatively return 'False' in other cases.++The justification for this design choice is as follows:++  1. Producing the correct answer in all cases would be rather difficult,+     for example for a complex pattern such as ( P ; !( R ; S ; ( Q :: Ty ) ) ).+  2. Irrefutable or-patterns aren't particularly common or useful, given that+     (currently) or-patterns aren't allowed to bind variables.++Note [Unboxed sum patterns aren't irrefutable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as+patterns. A simple example that demonstrates this is from #14228:++  pattern Just' x = (# x | #)+  pattern Nothing' = (# | () #)++  foo x = case x of+    Nothing' -> putStrLn "nothing"+    Just'    -> putStrLn "just"++In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable,+as does not match an unboxed sum value of the same arity—namely, (# | y #)+(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the+minimum unboxed sum arity is 2.++Failing to mark unboxed sum patterns as non-irrefutable would cause the Just'+case in foo to be unreachable, as GHC would mistakenly believe that Nothing'+is the only thing that could possibly be matched!++Note [Boring patterns]+~~~~~~~~~~~~~~~~~~~~~~+A pattern is called boring when no new information is gained upon successfully+matching on the pattern.++Some examples of boring patterns:++  - x, for a variable x. We learn nothing about x upon matching this pattern.+  - Just y. This pattern can fail, but if it matches, we don't learn anything+    about y.++Some examples of non-boring patterns:++  - x@(Just y). A match on this pattern introduces the fact that x is headed+    by the constructor Just, which means that a subsequent pattern match such as++      case x of { Just z -> ... }++    should not be marked as incomplete.+  - a@b. Matching on this pattern introduces a relation between 'a' and 'b',+    which means that we shouldn't emit any warnings in code of the form++      case a of+        True -> case b of { True -> .. } -- no warning here!+        False -> ...+  - GADT patterns. For example, with the GADT++      data G i where { MkGInt :: G Int }++    a match on the pattern 'MkGInt' introduces type-level information:++      foo :: G i -> i+      foo MkGInt = 3++    Here we learn that i ~ Int after matching on 'MkGInt', so this pattern+    is not boring.++When a pattern is boring, and we are only interested in additional long-distance+information (not whether the pattern itself is fallible), we can skip pattern-match+checking entirely. Doing this saves about 10% allocations in test T11195.++This happens when we are checking pattern-matches in do-notation, for example:++  do { x@(Just y) <- z+     ; ...+     ; return $ case x of { Just w -> ... } }++Here we *do not* want to emit a pattern-match warning on the first line for the+incomplete pattern-match, as incompleteness inside do-notation is handled+using MonadFail. However, we still want to propagate the fact that x is headed+by the 'Just' constructor, to avoid a pattern-match warning on the last line.++Note [Implementation of OrPatterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes the implementation of the extension -XOrPatterns.++* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0522-or-patterns.rst+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/522 and others++Parser+------+We parse an or-pattern `pat_1; ...; pat_k` into `OrPat [pat_1, ..., pat_k]`,+where `OrPat` is a constructor of `Pat` in Language.Haskell.Syntax.Pat.+We occasionally refer to any of the `pat_k` as "pattern alternatives" below.+The changes to the parser are as outlined in Section 8.1 of the proposal.+The main productions are++  orpats -> exp | exp ';' orpats+  aexp2 -> '(' orpats ')'+  pat -> orpats++Renamer and typechecker+-----------------------+The typing rule for or-patterns in terms of pattern types is++                   Γ0, Σ0 ⊢ pat_i : τ ⤳ Γ0,Σi,Ψi+            --------------------------------------------+            Γ0, Σ0 ⊢ ( pat_1; ...; pat_n ) : τ ⤳ Γ0,Σ0,∅++(See the proposal for what a pattern type `Γ, Σ ⊢ pat : τ ⤳ Γ,Σ,Ψ` is.)+The main points++  * None of the patterns may bind any variables, hence the same Γ0 in both input+    and output.+  * Any Given constraints bound by the pattern are discarded: the rule discards+    the Σi returned by each pattern.+  * Similarly any existentials Ψi bound by the pattern are discarded.++In GHC.Rename.Pat.rnPatAndThen, we reject visible term and type binders (i.e.+concerning Γ0).++Regarding the Givens Σi and existenials Ψi (i.e. invisible type binders)+introduced by the pattern alternatives `pat_i`, we discard them in+GHC.Tc.Gen.Pats.tc_pat in a manner similar to LazyPats;+see Note [Hopping the LIE in lazy patterns].++Why is it useful to allow Σi and Ψi only to discard them immediately after?+Consider++  data T a where MkT :: forall a x. Num a => x -> T a+  foo :: T a -> a+  foo (MkT{}; MkT{}) = 3++We do want to allow matching on MkT{} in or-patterns, despite them invisibly+binding an existential type variable `x` and a new Given constraint `Num a`.+Clearly, `x` must be dead in the RHS of foo, because there is no field binder+that brings it to life, so no harm done.+But we must be careful not to solve the `Num a` Wanted constraint in the RHS of+foo with the Given constraint from the pattern alternatives, hence we are+Hopping the LIE.++Desugarer+---------+The desugaring of or-patterns is complicated by the fact that we have to avoid+exponential code blowup. Consider+  f (LT; GT) (EQ; GT) = rhs1+  f _        _        = rhs2+The naïve desugaring of or-patterns would explode every or-pattern, thus+  f LT EQ = rhs1+  f LT GT = rhs1+  f GT EQ = rhs1+  f GT GT = rhs1+  f _  _  = rhs2+which leads to an exponential number of copies of `rhs1`.+Our current strategy, implemented in GHC.HsToCore.Match.tidy1, is to+desugar to LambdaCase and ViewPatterns,+  f ((\case LT -> True; GT -> True; _ -> False) -> True)+    ((\case EQ -> True; GT -> True; _ -> False) -> True)+    = rhs1+  f _ _ = rhs2+The existing code for ViewPatterns makes sure that we do not duplicate `rhs1`+and the Simplifier will take care to turn this into efficient code.++Pattern-match checker+---------------------+The changes to the pattern-match checker are described in detail in Section 4.9+of the 2024 revision of the "Lower Your Guards" paper.+What follows is a brief summary of that change.++The pattern-match checker desugars patterns as well, into syntactic variants of+*guard trees* such as `PmMatch`, describing a single Match `f ps | grhss`.+It used to be that each such guard trees nicely captured the effects of pattern+matching `ps` in a conjunctive list of `PmGrd`s, each of which refines+the set of Nablas that reach the RHS of the clause.+`PmGrd` is the heart of the Lower Your Guards approach: it is compositional,+simple, and *non-recursive*, unlike or-patterns!+Conjunction is implemented with the `...Pmc.Check.leftToRight` combinator.+But to desugar or-patterns, we need to compose with `Pmc.Check.topToBottom`+to model first match semantics!+This was previously impossible in the pattern fragment, and indeed is+incompatible with the simple "list of `PmGrd`s" desugaring of patterns.++So our solution is to generalise "sequence of `PmGrd`" into a series-parallel+graph `GrdDag`, a special kind of DAG, where "series" corresponds to+left-to-right sequence and "parallel" corresponds to top-to-bottom or-pattern+alternatives. Example++  f (LT; GT) True (EQ; GT) = rhs++desugars to++   /- LT <- x -\             /- EQ <- z -\+  .             . True <- y .             .-> rhs+   \- GT <- x ./             \- GT <- z -/++Branching is GdAlt and models first-match semantics of or-patterns, and+sequencing is GdSeq.++We must take care of exponential explosion of Covered sets for long matches like+  g (LT; GT) (LT; GT) ... True = 1+Fortunately, we can build on our existing throttling mechanism;+see Note [Countering exponential blowup] in GHC.HsToCore.Pmc.Check.+-}+++-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs+-- parentheses under precedence @p@.+patNeedsParens :: forall p. IsPass p => PprPrec -> Pat (GhcPass p) -> Bool+patNeedsParens p = go @p+  where+    -- Remark: go needs to be polymorphic, as we call it recursively+    -- at a different GhcPass (see the case for GhcTc XPat below).+    go :: forall q. IsPass q => Pat (GhcPass q) -> Bool+    go (NPlusKPat {})    = p > opPrec+    go (OrPat {})        = p > topPrec+    go (SplicePat {})    = False+    go (ConPat { pat_args = ds })+                         = conPatNeedsParens p ds+    go (SigPat {})       = p >= sigPrec+    go (ViewPat {})      = True+    go (EmbTyPat {})     = True+    go (InvisPat{})      = False+    go (XPat ext)        = case ghcPass @q of+      GhcRn -> case ext of+        HsPatExpanded orig _ -> go orig+      GhcTc -> case ext of+        CoPat _ inner _ -> go inner+        ExpansionPat orig _ -> go orig+          --                   ^^^^^^^+          -- NB: recursive call of go at a different GhcPass.+    go (WildPat {})      = False+    go (VarPat {})       = False+    go (LazyPat {})      = False+    go (BangPat {})      = False+    go (ParPat {})       = False+    go (AsPat {})        = False+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (TuplePat _ [_] Boxed)+                         = p >= appPrec+    go (TuplePat{})      = False+    go (SumPat {})       = False+    go (ListPat {})      = False+    go (LitPat _ l)      = hsLitNeedsParens p l+    go (NPat _ lol _ _)  = hsOverLitNeedsParens p (unLoc lol)++-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@+-- needs parentheses under precedence @p@.+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool+conPatNeedsParens p = go+  where+    go (PrefixCon args) = p >= appPrec && not (null args)+    go (InfixCon {})    = p >= opPrec -- type args should be empty in this case+    go (RecCon {})      = False+++-- | Parenthesize a pattern without token information+gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)+gParPat pat = ParPat x pat+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and+-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.+parenthesizePat :: IsPass p+                => PprPrec+                -> LPat (GhcPass p)+                -> LPat (GhcPass p)+parenthesizePat p lpat@(L loc pat)+  | patNeedsParens p pat = L loc (gParPat lpat)+  | otherwise            = lpat+++{-+% Collect all EvVars from all constructor patterns+-}++-- May need to add more cases+collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar+collectEvVarsPats = unionManyBags . map collectEvVarsPat++collectEvVarsLPat :: LPat GhcTc -> Bag EvVar+collectEvVarsLPat = collectEvVarsPat . unLoc++collectEvVarsPat :: Pat GhcTc -> Bag EvVar+collectEvVarsPat pat =+  case pat of+    LazyPat _ p      -> collectEvVarsLPat p+    AsPat _ _ p      -> collectEvVarsLPat p+    ParPat  _ p      -> collectEvVarsLPat p+    BangPat _ p      -> collectEvVarsLPat p+    ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps+    TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps+    OrPat _ ps       -> unionManyBags $ map collectEvVarsLPat (NE.toList ps)+    SumPat _ p _ _   -> collectEvVarsLPat p+    ConPat+      { pat_args  = args+      , pat_con_ext = ConPatTc+        { cpt_dicts = dicts+        }+      }+                     -> unionBags (listToBag dicts)+                                   $ unionManyBags+                                   $ map collectEvVarsLPat+                                   $ hsConPatArgs args+    SigPat  _ p _    -> collectEvVarsLPat p+    XPat ext -> case ext of+      CoPat _ p _      -> collectEvVarsPat p+      ExpansionPat _ p -> collectEvVarsPat p+    _other_pat       -> emptyBag++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO+type instance Anno ConLike = SrcSpanAnnN+type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA+type instance Anno RecFieldsDotDot = EpaLocation
GHC/Hs/Pat.hs-boot view
@@ -1,19 +1,17 @@-{-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ module GHC.Hs.Pat where -import Outputable-import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )+import GHC.Utils.Outputable+import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) -type role Pat nominal-data Pat (i :: *)-type LPat i = XRec i Pat+import Language.Haskell.Syntax.Pat -instance OutputableBndrId p => Outputable (Pat (GhcPass p))+instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))++pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
− GHC/Hs/PlaceHolder.hs 
@@ -1,70 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE StandaloneDeriving #-}--module GHC.Hs.PlaceHolder where--import Name-import NameSet-import RdrName-import Var----{--%************************************************************************-%*                                                                      *-\subsection{Annotating the syntax}-%*                                                                      *-%************************************************************************--}---- NB: These are intentionally open, allowing API consumers (like Haddock)--- to declare new instances--placeHolderNamesTc :: NameSet-placeHolderNamesTc = emptyNameSet--{--TODO:AZ: remove this, and check if we still need all the UndecidableInstances--Note [Pass sensitive types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the same AST types are re-used through parsing,renaming and type-checking there are naturally some places in the AST that do not have-any meaningful value prior to the pass they are assigned a value.--Historically these have been filled in with place holder values of the form--  panic "error message"--This has meant the AST is difficult to traverse using standard generic-programming techniques. The problem is addressed by introducing-pass-specific data types, implemented as a pair of open type families,-one for PostTc and one for PostRn. These are then explicitly populated-with a PlaceHolder value when they do not yet have meaning.--In terms of actual usage, we have the following--  PostTc id Kind-  PostTc id Type--  PostRn id Fixity-  PostRn id NameSet--TcId and Var are synonyms for Id--Unfortunately the type checker termination checking conditions fail for the-DataId constraint type based on this, so even though it is safe the-UndecidableInstances pragma is required where this is used.--}----- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext',--- for printing messages related to a 'Match'-type family NameOrRdrName id where-  NameOrRdrName Id      = Name-  NameOrRdrName Name    = Name-  NameOrRdrName RdrName = RdrName
+ GHC/Hs/Specificity.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Hs.Specificity where++import Prelude+import Control.DeepSeq (NFData(..))++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Language.Haskell.Syntax.Specificity++{- *********************************************************************+*                                                                      *+*                   ForAllTyFlag+*                                                                      *+********************************************************************* -}++instance Outputable ForAllTyFlag where+  ppr Required  = text "[req]"+  ppr Specified = text "[spec]"+  ppr Inferred  = text "[infrd]"++instance Binary Specificity where+  put_ bh SpecifiedSpec = putByte bh 0+  put_ bh InferredSpec  = putByte bh 1++  get bh = do+    h <- getByte bh+    case h of+      0 -> return SpecifiedSpec+      _ -> return InferredSpec++instance Binary ForAllTyFlag where+  put_ bh Required  = putByte bh 0+  put_ bh Specified = putByte bh 1+  put_ bh Inferred  = putByte bh 2++  get bh = do+    h <- getByte bh+    case h of+      0 -> return Required+      1 -> return Specified+      _ -> return Inferred++instance NFData Specificity where+  rnf SpecifiedSpec = ()+  rnf InferredSpec = ()+instance NFData ForAllTyFlag where+  rnf (Invisible spec) = rnf spec+  rnf Required = ()+
+ GHC/Hs/Stats.hs view
@@ -0,0 +1,187 @@+{-# 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.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 (SpecSigE {})   = (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 = dd :: HsDataDefn GhcPs })+        | HsDataDefn { dd_cons = cs, dd_derivs = derivs} <- dd+        = ( 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 $ 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 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)
+ GHC/Hs/Syn/Type.hs view
@@ -0,0 +1,213 @@+-- | 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 (OrPat ty _)                  = 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 (EmbTyPat ty _)               = typeKind ty+hsPatType (InvisPat ty _)               = typeKind ty+hsPatType (XPat ext) =+  case ext of+    CoPat _ _ ty       -> ty+    ExpansionPat _ pat -> hsPatType pat+hsPatType (SplicePat v _)               = dataConCantHappen v++hsLitType :: forall p. IsPass p => HsLit (GhcPass p) -> Type+hsLitType (HsChar _ _)       = charTy+hsLitType (HsCharPrim _ _)   = charPrimTy+hsLitType (HsString _ _)     = stringTy+hsLitType (HsMultilineString _ _) = stringTy+hsLitType (HsStringPrim _ _) = addrPrimTy+hsLitType (HsInt _ _)        = intTy+hsLitType (HsIntPrim _ _)    = intPrimTy+hsLitType (HsWordPrim _ _)   = wordPrimTy+hsLitType (HsInt8Prim _ _)   = int8PrimTy+hsLitType (HsInt16Prim _ _)  = int16PrimTy+hsLitType (HsInt32Prim _ _)  = int32PrimTy+hsLitType (HsInt64Prim _ _)  = int64PrimTy+hsLitType (HsWord8Prim _ _)  = word8PrimTy+hsLitType (HsWord16Prim _ _) = word16PrimTy+hsLitType (HsWord32Prim _ _) = word32PrimTy+hsLitType (HsWord64Prim _ _) = word64PrimTy+hsLitType (HsFloatPrim _ _)  = floatPrimTy+hsLitType (HsDoublePrim _ _) = doublePrimTy+hsLitType (XLit x)           = case ghcPass @p of+      GhcTc -> case x of+         (HsInteger _ _ ty) -> ty+         (HsRat  _ ty)      -> ty+++-- | 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 (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 (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 (HsEmbTy x _) = dataConCantHappen x+hsExprType (HsHole (_, (HER _ ty _))) = ty+hsExprType (HsQual x _ _) = dataConCantHappen x+hsExprType (HsForAll x _ _) = dataConCantHappen x+hsExprType (HsFunArr x _ _ _) = dataConCantHappen x+hsExprType (XExpr (WrapExpr wrap e)) = hsWrapperType wrap $ hsExprType e+hsExprType (XExpr (ExpandedThingTc _ e))  = hsExprType e+hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con+hsExprType (XExpr (HsTick _ e)) = lhsExprType e+hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e+hsExprType (XExpr (HsRecSelTc (FieldOcc _ id))) = idType (unLoc id)++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++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"
+ GHC/Hs/Type.hs view
@@ -0,0 +1,1653 @@++{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                       -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++GHC.Hs.Type: Abstract syntax: user-defined types+-}++module GHC.Hs.Type (+        Mult,+        HsMultAnn, HsMultAnnOf(..),+        multAnnToHsType, expandHsMultAnnOf,+        EpLinear(..), EpArrowOrColon(..),+        pprHsArrow, pprHsMultAnn,++        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+        HsTypeGhcPsExt(..),+        HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,+        HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),+        HsBndrKind(..),+        HsBndrVar(..),+        HsBndrVis(..), isHsBndrInvisible,+        LHsQTyVars(..),+        HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,+        HsWildCardBndrs(..),+        HsPatSigType(..), HsPSRn(..),+        HsTyPat(..), HsTyPatRn(..),+        HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn,+        HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTupleSort(..),+        HsContext, LHsContext, fromMaybeContext,+        HsTyLit(..),+        HsIPName(..), hsIPNameFS,+        HsArg(..), numVisibleArgs, pprHsArgsApp,+        LHsTypeArg, lhsTypeArgSrcSpan,+        OutputableBndrFlag,++        HsSrcBang(..), HsImplBang(..),+        SrcStrictness(..), SrcUnpackedness(..),++        HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields,++        HsConDetails(..),+        HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult,+        hsPlainTypeField, mkConDeclField,+        FieldOcc(..), LFieldOcc, mkFieldOcc,+        fieldOccRdrName, fieldOccLRdrName,++        OpName(..),++        mkAnonWildCardTy, pprAnonWildCard,++        hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,+        mkHsOuterImplicit, mkHsOuterExplicit,+        mkHsImplicitSigType, mkHsExplicitSigType,+        mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat,+        mkEmptyWildCardBndrs,+        mkHsForAllVisTele, mkHsForAllInvisTele,+        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,+        isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded,+        hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,+        hsTyVarLName, hsTyVarName,+        hsAllLTyVarNames, hsLTyVarLocNames,+        hsLTyVarName, hsLTyVarNames,+        hsForAllTelescopeBndrs,+        hsForAllTelescopeNames,+        hsLTyVarLocName, hsExplicitLTyVarNames,+        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,+        splitLHsPatSynTy,+        splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,+        splitLHsSigmaTyInvis, splitLHsGadtTy,+        splitHsFunType, hsTyGetAppHead_maybe,+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,+        ignoreParens, hsSigWcType, hsPatSigType,+        hsTyKindSig,+        setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag,++        -- Printing+        pprHsType, pprHsForAll, pprHsForAllTelescope,+        pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,+        pprLHsContext,+        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext+    ) where++import GHC.Prelude++import Language.Haskell.Syntax.Type++import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) )++import Language.Haskell.Syntax.Extension+import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)+                        , HsSrcBang(..), HsImplBang(..)+                        )+import GHC.Hs.Extension+import GHC.Parser.Annotation++import GHC.Types.Fixity ( LexicalFixity(..) )+import GHC.Types.SourceText+import GHC.Types.Name+import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr )+import GHC.Types.Var ( VarBndr, visArgTypeLike )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Builtin.Names ( negateName )+import GHC.Builtin.Types( oneDataConName, mkTupleStr )+import GHC.Core.Ppr ( pprOccWithTick)+import GHC.Core.Type+import GHC.Core.Multiplicity( pprArrowWithMultiplicity )+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Misc (count)++import Data.Maybe+import Data.Data (Data)++import qualified Data.Semigroup as S+import GHC.Data.Bag++{-+************************************************************************+*                                                                      *+\subsection{Data types}+*                                                                      *+************************************************************************+-}++fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt++type instance XHsForAllVis   (GhcPass _) = EpAnn (TokForall, TokRarrow)+                                           -- Location of 'forall' and '->'+type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".")+                                           -- Location of 'forall' and '.'++type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen++type EpAnnForallVis   = EpAnn (TokForall, TokRarrow)+type EpAnnForallInvis = EpAnn (TokForall, EpToken ".")++type HsQTvsRn = [Name]  -- Implicit variables+  -- For example, in   data T (a :: k1 -> k2) = ...+  -- the 'a' is explicit while 'k1', 'k2' are implicit++type instance XHsQTvs GhcPs = NoExtField+type instance XHsQTvs GhcRn = HsQTvsRn+type instance XHsQTvs GhcTc = HsQTvsRn++type instance XXLHsQTyVars  (GhcPass _) = DataConCantHappen++mkHsForAllVisTele ::EpAnnForallVis ->+  [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllVisTele an vis_bndrs =+  HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }++mkHsForAllInvisTele :: EpAnnForallInvis+  -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllInvisTele an invis_bndrs =+  HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }++mkHsQTvs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> LHsQTyVars GhcPs+mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }++emptyLHsQTvs :: LHsQTyVars GhcRn+emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }++------------------------------------------------+--            HsOuterTyVarBndrs++type instance XHsOuterImplicit GhcPs = NoExtField+type instance XHsOuterImplicit GhcRn = [Name]+type instance XHsOuterImplicit GhcTc = [TyVar]++type instance XHsOuterExplicit GhcPs _    = EpAnnForallInvis+type instance XHsOuterExplicit GhcRn _    = NoExtField+type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag]++type instance XXHsOuterTyVarBndrs (GhcPass _) = DataConCantHappen++type instance XHsWC              GhcPs b = NoExtField+type instance XHsWC              GhcRn b = [Name]+type instance XHsWC              GhcTc b = [Name]++type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen++type instance XHsPS GhcPs = EpAnnCO+type instance XHsPS GhcRn = HsPSRn+type instance XHsPS GhcTc = HsPSRn++type instance XHsTP GhcPs = NoExtField+type instance XHsTP GhcRn = HsTyPatRn+type instance XHsTP GhcTc = DataConCantHappen++-- | The extension field for 'HsPatSigType', which is only used in the+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.+data HsPSRn = HsPSRn+  { hsps_nwcs    :: [Name] -- ^ Wildcard names+  , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  }+  deriving Data++-- HsTyPatRn is the extension field for `HsTyPat`, after renaming+-- E.g. pattern K @(Maybe (_x, a, b::Proxy k)+-- In the type pattern @(Maybe ...):+--    '_x' is a named wildcard+--    'a'  is explicitly bound+--    'k'  is implicitly bound+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat+data HsTyPatRn = HsTPRn+  { hstp_nwcs    :: [Name] -- ^ Wildcard names+  , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names+  }+  deriving Data++-- | A variant of HsTyPatRn that uses Bags for efficient concatenation.+-- See Note [Implicit and explicit type variable binders]  in GHC.Rename.Pat+data HsTyPatRnBuilder =+  HsTPRnB {+    hstpb_nwcs :: Bag Name,+    hstpb_imp_tvs :: Bag Name,+    hstpb_exp_tvs :: Bag Name+  }++tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder+tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name}++tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder+tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} =+  mempty {+    hstpb_nwcs = listToBag hsps_nwcs,+    hstpb_imp_tvs = listToBag hsps_imp_tvs+  }++instance Semigroup HsTyPatRnBuilder where+  HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =+    HsTPRnB+      (nwcs1    `unionBags` nwcs2)+      (imp_tvs1 `unionBags` imp_tvs2)+      (exptvs1  `unionBags` exptvs2)++instance Monoid HsTyPatRnBuilder where+  mempty = HsTPRnB emptyBag emptyBag emptyBag++buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn+buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =+  HsTPRn {+    hstp_nwcs =    bagToList hstpb_nwcs,+    hstp_imp_tvs = bagToList hstpb_imp_tvs,+    hstp_exp_tvs = bagToList hstpb_exp_tvs+  }++builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder+builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} =+  HsTPRnB {+    hstpb_nwcs =    listToBag hstp_nwcs,+    hstpb_imp_tvs = listToBag hstp_imp_tvs,+    hstpb_exp_tvs = listToBag hstp_exp_tvs+  }++type instance XXHsPatSigType (GhcPass _) = DataConCantHappen+type instance XXHsTyPat      (GhcPass _) = DataConCantHappen++type instance XHsSig (GhcPass _) = NoExtField+type instance XXHsSigType (GhcPass _) = DataConCantHappen+++hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p)+hsPatSigType (HsPS { hsps_body = ty }) = ty++hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p)+hsSigWcType = sig_body . unLoc . hswc_body++dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p)+-- Drop the wildcard part of a LHsSigWcType+dropWildCards sig_ty = hswc_body sig_ty++hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]+hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs+hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs})       = hsLTyVarNames bndrs++hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)+                     -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]+hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs+hsOuterExplicitBndrs (HsOuterImplicit{})                  = []++mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs+mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}++mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs]+                  -> HsOuterTyVarBndrs flag GhcPs+mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an+                                             , hso_bndrs     = bndrs }++mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs+mkHsImplicitSigType body =+  HsSig { sig_ext   = noExtField+        , sig_bndrs = mkHsOuterImplicit, sig_body = body }++mkHsExplicitSigType :: EpAnnForallInvis+                    -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs+                    -> HsSigType GhcPs+mkHsExplicitSigType an bndrs body =+  HsSig { sig_ext = noExtField+        , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body }++mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing+mkHsWildCardBndrs x = HsWC { hswc_body = x+                           , hswc_ext  = noExtField }++mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs+mkHsPatSigType ann x = HsPS { hsps_ext  = ann+                            , hsps_body = x }++mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs+mkHsTyPat x = HsTP { hstp_ext  = noExtField+                   , hstp_body = x }++mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing+mkEmptyWildCardBndrs x = HsWC { hswc_body = x+                              , hswc_ext  = [] }++--------------------------------------------------++type instance XTyVarBndr    (GhcPass _) = AnnTyVarBndr+type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen++type instance XBndrKind   (GhcPass p) = NoExtField+type instance XBndrNoKind (GhcPass p) = NoExtField+type instance XXBndrKind  (GhcPass p) = DataConCantHappen++type instance XBndrVar (GhcPass p) = NoExtField++type instance XBndrWildCard GhcPs = EpToken "_"+type instance XBndrWildCard GhcRn = NoExtField+type instance XBndrWildCard GhcTc = NoExtField++type instance XXBndrVar (GhcPass p) = DataConCantHappen++data AnnTyVarBndr+  = AnnTyVarBndr {+    atv_opens  :: [EpaLocation], -- all "(" or all "{"+    atv_closes :: [EpaLocation], -- all ")" or all "}"+    atv_tv     :: EpToken "'",+    atv_dcolon :: TokDcolon+  } deriving Data++instance NoAnn AnnTyVarBndr where+  noAnn = AnnTyVarBndr noAnn noAnn noAnn noAnn++-- | Return the attached flag+hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag+hsTyVarBndrFlag = tvb_flag+-- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen+-- so the equation is exhaustive: extension construction can't happen++-- | Set the attached flag+setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)+  -> HsTyVarBndr flag (GhcPass pass)+setHsTyVarBndrFlag fl tvb = tvb { tvb_flag = fl }++-- | Update the attached flag+updateHsTyVarBndrFlag+  :: (flag -> flag')+  -> HsTyVarBndr flag  (GhcPass pass)+  -> HsTyVarBndr flag' (GhcPass pass)+updateHsTyVarBndrFlag f tvb = tvb { tvb_flag = f (tvb_flag tvb) }++-- | Get the variable of the type variable binder+hsBndrVar :: HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)+hsBndrVar = tvb_var++-- | Get the kind of the type variable binder+hsBndrKind :: HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass)+hsBndrKind = tvb_kind++-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?+hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool+hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit++type instance XBndrRequired (GhcPass _) = NoExtField++type instance XBndrInvisible GhcPs = EpToken "@"+type instance XBndrInvisible GhcRn = NoExtField+type instance XBndrInvisible GhcTc = NoExtField++type instance XXBndrVis (GhcPass _) = DataConCantHappen++{- Note [Wildcard binders in disallowed contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In contexts where a type variable binder is expected (HsTyVarBndr), we usually+allow both named binders and wildcards, e.g.++  type Const1 a b = a     -- ok+  type Const2 a _ = a     -- ok, too++This applies to LHSs of data, newtype, type, class, type family and data family+declarations. However, we choose to reject wildcards in forall telescopes and+type family result variables (the latter being part of TypeFamilyDependencies):++  type family Fd a = _    -- disallowed  (WildcardBndrInTyFamResultVar)+  fn :: forall _. Int     -- disallowed  (WildcardBndrInForallTelescope)++This restriction is placed solely because such binders have not been proposed+and there is no known use case for them. If we see user demand for wildcard+binders in these contexts, adding support for them would be as easy as dropping+the checks that reject them. The rest of the compiler can handle all wildcard+binders regardless of context by generating a fresh name (see `tcHsBndrVarName`+in GHC.Tc.Gen.HsType and `repHsBndrVar` in GHC.HsToCore.Quote).++That is, in type declarations we have:++  type F _  = ...  -- equivalent to ...+  type F _a = ...  -- where _a is fresh++and the same principle could be applied to foralls:++  fn :: forall _.  Int   -- equivalent to ...+  fn :: forall _a. Int   -- where _a is fresh++except the `forall _.` example is rejected by checkForAllTelescopeWildcardBndrs.+-}++type instance XForAllTy        (GhcPass _) = NoExtField+type instance XQualTy          (GhcPass _) = NoExtField+type instance XTyVar           (GhcPass _) = EpToken "'"+type instance XAppTy           (GhcPass _) = NoExtField+type instance XFunTy           (GhcPass _) = NoExtField+type instance XListTy          (GhcPass _) = AnnParen+type instance XTupleTy         (GhcPass _) = AnnParen+type instance XSumTy           (GhcPass _) = AnnParen+type instance XOpTy            (GhcPass _) = NoExtField+type instance XParTy           (GhcPass _) = (EpToken "(", EpToken ")")+type instance XIParamTy        (GhcPass _) = TokDcolon+type instance XStarTy          (GhcPass _) = NoExtField+type instance XKindSig         (GhcPass _) = TokDcolon++type instance XAppKindTy       GhcPs = EpToken "@"+type instance XAppKindTy       GhcRn = NoExtField+type instance XAppKindTy       GhcTc = NoExtField++type instance XSpliceTy        GhcPs = NoExtField+type instance XSpliceTy        GhcRn = HsUntypedSpliceResult (LHsType GhcRn)+type instance XSpliceTy        GhcTc = Kind++type instance XDocTy           (GhcPass _) = NoExtField+type instance XConDeclField    (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)+type instance XXConDeclRecField   (GhcPass _) = DataConCantHappen++type instance XExplicitListTy  GhcPs = (EpToken "'", EpToken "[", EpToken "]")+type instance XExplicitListTy  GhcRn = NoExtField+type instance XExplicitListTy  GhcTc = Kind++type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")")+type instance XExplicitTupleTy GhcRn = NoExtField+type instance XExplicitTupleTy GhcTc = [Kind]++type instance XTyLit           (GhcPass _) = NoExtField++type instance XWildCardTy      GhcPs = EpToken "_"+type instance XWildCardTy      GhcRn = NoExtField+type instance XWildCardTy      GhcTc = NoExtField++type instance XXType           GhcPs = HsTypeGhcPsExt+type instance XXType           GhcRn = HsCoreTy+type instance XXType           GhcTc = DataConCantHappen++type instance XNumTy         (GhcPass _) = SourceText+type instance XStrTy         (GhcPass _) = SourceText+type instance XCharTy        (GhcPass _) = SourceText+type instance XXTyLit        (GhcPass _) = DataConCantHappen++type HsCoreTy = Type++-- Extension of HsType during parsing.+-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension+data HsTypeGhcPsExt+  = HsCoreTy    HsCoreTy+    -- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+    -- For more details on how this works, see:+    --+    -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+    --+    -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"++  | HsBangTy    (EpaLocation, EpToken "#-}", EpaLocation)+                HsSrcBang+                (LHsType GhcPs)+    -- See Note [Parsing data type declarations]++  | HsRecTy     (AnnList ())+                [LHsConDeclRecField GhcPs]+    -- See Note [Parsing data type declarations]++{- Note [Parsing data type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When parsing it is not always clear if we're parsing a constructor field type+or not. So during parsing we extend the type syntax to support bang annotations+and record braces. We do this through the extension constructor of (HsType GhcPs),+namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`.+Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors+are not needed; instead the data is stored in `HsConDeclField`. It is an error+if it turns out the extensions were used outside of a constructor field type.+-}++data EpArrowOrColon+  = EpArrow !TokRarrow+  | EpColon !TokDcolon+  | EpPatBind+  deriving Data++data EpLinear+  = EpPct1 !(EpToken "%1") !EpArrowOrColon+  | EpLolly !(EpToken "⊸")+  deriving Data++instance NoAnn EpLinear where+  noAnn = EpPct1 noAnn (EpArrow noAnn)++type instance XUnannotated  _ GhcPs = EpArrowOrColon+type instance XUnannotated  _ GhcRn = NoExtField+type instance XUnannotated  _ GhcTc = Mult++type instance XLinearAnn    _ GhcPs = EpLinear+type instance XLinearAnn    _ GhcRn = NoExtField+type instance XLinearAnn    _ GhcTc = Mult++type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon)+type instance XExplicitMult _ GhcRn = NoExtField+type instance XExplicitMult _ GhcTc = Mult++type instance XXMultAnnOf   _ (GhcPass _) = DataConCantHappen++multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn)+multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted . fmap noUserRdr)++-- | Convert an multiplicity annotation into its corresponding multiplicity.+-- If no annotation was written, `Nothing` is returned.+-- In this polymorphic function, `t` can be `HsType` or `HsExpr`+expandHsMultAnnOf :: (LocatedN Name -> t GhcRn)+                  -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn+                  -> Maybe (LocatedA (t GhcRn))+expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing+expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName)))+expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p++instance+      (Outputable mult, OutputableBndrId pass) =>+      Outputable (HsMultAnnOf mult (GhcPass pass)) where+  ppr arr = parens (pprHsArrow arr)++-- See #18846+pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc+pprHsArrow (HsUnannotated _)    = pprArrowWithMultiplicity visArgTypeLike (Left False)+pprHsArrow (HsLinearAnn _)      = pprArrowWithMultiplicity visArgTypeLike (Left True)+pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))++-- Used to print, for instance, let bindings:+--   let %1 x = …+-- and record field declarations:+--   { x %1 :: … }+pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc+pprHsMultAnn (HsUnannotated _) = empty+pprHsMultAnn (HsLinearAnn _) = text "%1"+pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p++type instance XConDeclRecField  (GhcPass _) = NoExtField+type instance XXConDeclRecField (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (HsConDeclRecField (GhcPass p)) where+  ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing })+    where+      ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc+      ppr_names [n] = pprPrefixOcc n+      ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))++      ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc+      ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc++---------------------+hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]+-- Get the lexically-scoped type variables of an LHsSigWcType:+--  - the explicitly-given forall'd type variables;+--    see Note [Lexically scoped type variables]+--  - the named wildcards; see Note [Scoping of named wildcards]+-- because they scope in the same way+hsWcScopedTvs sig_wc_ty+  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty }  <- sig_wc_ty+  , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty+  = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++hsScopedTvs :: LHsSigType GhcRn -> [Name]+-- Same as hsWcScopedTvs, but for a LHsSigType+hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs}))+  = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++hsScopedKvs :: LHsKind GhcRn -> [Name]+-- Same as hsScopedTvs, but for a LHsKind+hsScopedKvs  (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }})+  = hsLTyVarNames bndrs+    -- See Note [hsScopedTvs and visible foralls]+hsScopedKvs _ = []++---------------------+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p))+hsTyVarLName tvb =+  case hsBndrVar tvb of+    HsBndrVar      _ n -> Just n+    HsBndrWildCard _   -> Nothing++hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))+hsTyVarName = fmap unLoc . hsTyVarLName++hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))+hsLTyVarName = hsTyVarName . unLoc++hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]+hsLTyVarNames = mapMaybe hsLTyVarName++hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)]+hsForAllTelescopeBndrs (HsForAllVis   _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs+hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs++hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]+hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs+hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs++hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]+-- Explicit variables only+hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs)++hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]+-- All variables+hsAllLTyVarNames (HsQTvs { hsq_ext = kvs+                         , hsq_explicit = tvs })+  = kvs ++ hsLTyVarNames tvs++hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))+hsLTyVarLocName (L _ a) = hsTyVarLName a++hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN+                 => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]+hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs)++-- | Get the kind signature of a type, ignoring parentheses:+--+--   hsTyKindSig   `Maybe                    `   =   Nothing+--   hsTyKindSig   `Maybe ::   Type -> Type  `   =   Just  `Type -> Type`+--   hsTyKindSig   `Maybe :: ((Type -> Type))`   =   Just  `Type -> Type`+--+-- This is used to extract the result kind of type synonyms with a CUSK:+--+--  type S = (F :: res_kind)+--                 ^^^^^^^^+--+hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))+hsTyKindSig lty =+  case unLoc lty of+    HsParTy _ lty'    -> hsTyKindSig lty'+    HsKindSig _ _ k   -> Just k+    _                 -> Nothing++---------------------+ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty+ignoreParens ty                   = ty++{-+************************************************************************+*                                                                      *+                Building types+*                                                                      *+************************************************************************+-}++mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs+mkAnonWildCardTy tok = HsWildCardTy tok++mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+         => PromotionFlag+         -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p))+         -> LHsType (GhcPass p) -> HsType (GhcPass p)+mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2++mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2)++mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]+           -> LHsType (GhcPass p)+mkHsAppTys = foldl' mkHsAppTy++mkHsAppKindTy :: XAppKindTy (GhcPass p)+              -> LHsType (GhcPass p) -> LHsType (GhcPass p)+              -> LHsType (GhcPass p)+mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)++{-+************************************************************************+*                                                                      *+                Decomposing HsTypes+*                                                                      *+************************************************************************+-}++---------------------------------+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)+-- Breaks up any parens in the result type:+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)+-- It returns API Annotations for any parens removed+splitHsFunType ::+     LHsType GhcPs+  -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and+                                  -- comments discarded+     , [HsConDeclField GhcPs], LHsType GhcPs)+splitHsFunType ty = go ty+  where+    go (L l (HsParTy (op,cp) ty))+      = let+          ((ops, cps), cs, args, res) = splitHsFunType ty+          cs' = cs S.<> epAnnComments l+        in ((ops++[op], cps ++ [cp]), cs', args, res)++    go (L ll (HsFunTy _ mult x y))+      | (anns, csy, args, res) <- splitHsFunType y+      = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res)++    go other = (noAnn, emptyComments, [], other)++-- | Retrieve the name of the \"head\" of a nested type application.+-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more+-- thorough. The purpose of this function is to examine instance heads, so it+-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).+hsTyGetAppHead_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+                     => LHsType (GhcPass p)+                     -> Maybe (LocatedN (IdOccP (GhcPass p)))+hsTyGetAppHead_maybe = go+  where+    go (L _ (HsTyVar _ _ ln))    = Just ln+    go (L _ (HsAppTy _ l _))     = go l+    go (L _ (HsAppKindTy _ t _)) = go t+    go (L _ (HsOpTy _ _ _ ln _)) = Just ln+    go (L _ (HsParTy _ t))       = go t+    go (L _ (HsKindSig _ t _))   = go t+    go _                         = Nothing++------------------------------------------------------------++type instance XValArg (GhcPass _) = NoExtField++type instance XTypeArg GhcPs = EpToken "@"+type instance XTypeArg GhcRn = NoExtField+type instance XTypeArg GhcTc = NoExtField++type instance XArgPar (GhcPass _) = SrcSpan++type instance XXArg (GhcPass _) = DataConCantHappen++-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.+lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan+lhsTypeArgSrcSpan arg = case arg of+  HsValArg  _  tm -> getLocA tm+  HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty+  HsArgPar  sp    -> sp++--------------------------------++numVisibleArgs :: [HsArg p tm ty] -> Arity+numVisibleArgs = count is_vis+  where is_vis (HsValArg _ _) = True+        is_vis _              = False++--------------------------------++-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix+-- or infix. Examples:+--+-- @+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int]                        = T \@Bool Int+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int]              = (T \@Bool) Int+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double]                    = Char ++ Double+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering+-- @+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)+             => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc+pprHsArgsApp thing fixity (argl:argr:args)+  | Infix <- fixity+  = let pp_op_app = hsep [ ppr_single_hs_arg argl+                         , pprInfixOcc thing+                         , ppr_single_hs_arg argr ] in+    case args of+      [] -> pp_op_app+      _  -> ppr_hs_args_prefix_app (parens pp_op_app) args++pprHsArgsApp thing _fixity args+  = ppr_hs_args_prefix_app (pprPrefixOcc thing) args++-- | Pretty-print a prefix identifier to a list of 'HsArg's.+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)+                        => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc+ppr_hs_args_prefix_app acc []         = acc+ppr_hs_args_prefix_app acc (arg:args) =+  case arg of+    HsValArg{}  -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+    HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+    HsArgPar{}  -> ppr_hs_args_prefix_app (parens acc) args++-- | Pretty-print an 'HsArg' in isolation.+ppr_single_hs_arg :: (Outputable tm, Outputable ty)+                  => HsArg (GhcPass p) tm ty -> SDoc+ppr_single_hs_arg (HsValArg _ tm)  = ppr tm+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty+-- GHC shouldn't be constructing ASTs such that this case is ever reached.+-- Still, it's possible some wily user might construct their own AST that+-- allows this to be reachable, so don't fail here.+ppr_single_hs_arg (HsArgPar{})     = empty++-- | This instance is meant for debug-printing purposes. If you wish to+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.+instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where+  ppr (HsValArg _ tm)   = text "HsValArg"  <+> ppr tm+  ppr (HsTypeArg _ ty)  = text "HsTypeArg" <+> ppr ty+  ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp++--------------------------------++-- | Decompose a pattern synonym type signature into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsPatSynTy ::+     LHsSigType (GhcPass p)+  -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals+     , Maybe (LHsContext (GhcPass p))                       -- required constraints+     , [LHsTyVarBndr Specificity (GhcPass p)]               -- existentials+     , Maybe (LHsContext (GhcPass p))                       -- provided constraints+     , LHsType (GhcPass p))                                 -- body type+splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)+  where+    -- split_sig_ty ::+    --      LHsSigType (GhcPass p)+    --   -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p))+    split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) =+      case outer_bndrs of+        -- NB: Use ignoreParens here in order to be consistent with the use of+        -- splitLHsForAllTyInvis below, which also looks through parentheses.+        HsOuterImplicit{}                      -> ([], ignoreParens body)+        HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)++    (univs, ty1) = split_sig_ty ty+    (reqs,  ty2) = splitLHsQualTy ty1+    (exis,  ty3) = splitLHsForAllTyInvis ty2+    (provs, ty4) = splitLHsQualTy ty3++-- | Decompose a sigma type (of the form @forall <tvs>. context => body@)+-- into its constituent parts.+-- Only splits type variable binders that were+-- quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsSigmaTyInvis :: LHsType (GhcPass p)+                     -> ([LHsTyVarBndr Specificity (GhcPass p)]+                        , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))+splitLHsSigmaTyInvis ty+  | (tvs,  ty1) <- splitLHsForAllTyInvis ty+  , (ctxt, ty2) <- splitLHsQualTy ty1+  = (tvs, ctxt, ty2)++-- | Decompose a GADT type into its constituent parts.+-- Returns @(outer_bndrs, mb_ctxt, body)@, where:+--+-- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost+--   type variable binders. Otherwise, they are 'HsOuterImplicit'.+--+-- * @mb_ctxt@ is @Just@ the context, if it is provided.+--   Otherwise, it is @Nothing@.+--+-- * @body@ is the body of the type after the optional @forall@s and context.+--+-- This function is careful not to look through parentheses.+-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@+-- "GHC.Hs.Decls" for why this is important.+splitLHsGadtTy ::+     LHsSigType GhcPs+  -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs)+splitLHsGadtTy (L _ sig_ty)+  | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty+  , (inner_bndrs, phi_ty)   <- split_inner_bndrs sigma_ty+  , (mb_ctxt, rho_ty)       <- splitLHsQualTy_KP phi_ty+  = case rho_ty of+      L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs)+        -- Bad! Record GADTs are not allowed to have inner_bndrs,+        -- undo the split to get a proper error message later+        -> (outer_bndrs, [], Nothing, sigma_ty)+      _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty)+  where+    split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)+    split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =+      (outer_bndrs, body_ty)++    split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs)+    split_inner_bndrs (L _ HsForAllTy { hst_tele = tele+                                      , hst_body = body })+      = let ~(teles, t) = split_inner_bndrs body+        in (tele:teles, t)+    split_inner_bndrs t = ([], t)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+-- Unlike 'splitLHsSigmaTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis ::+  LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)]+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis ty+  | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)+  = (fromMaybe [] mb_tvbs, body)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Unlike 'splitLHsForAllTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis_KP ::+  LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)])+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis_KP lty@(L _ ty) =+  case ty of+    HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs }+               , hst_body = body }+      -> (Just tvs, body)+    _ -> (Nothing, lty)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(context => <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsQualTy :: LHsType (GhcPass pass)+               -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy ty+  | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)+  = (mb_ctxt, body)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Unlike 'splitLHsQualTy', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))+                       = (Just ctxt, body)+splitLHsQualTy_KP body = (Nothing, body)++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into its constituent parts.+-- Note that the @[Name]@s returned correspond to either:+--+-- * The implicitly bound type variables (if the type lacks an outermost+--   @forall@), or+--+-- * The explicitly bound type variables (if the type has an outermost+--   @forall@).+--+-- This function is careful not to look through parentheses.+-- See @Note [No nested foralls or contexts in instance types]@+-- for why this is important.+splitLHsInstDeclTy :: LHsSigType GhcRn+                   -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)+splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =+  (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)+  where+    (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@.+getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)+getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))+  | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty+  = body_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@ and+-- retrieve the underlying class type constructor (if it exists).+getLHsInstDeclClass_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+                          => LHsSigType (GhcPass p)+                          -> Maybe (LocatedN (IdOccP (GhcPass p)))+-- Works on (LHsSigType GhcPs)+getLHsInstDeclClass_maybe inst_ty+  = do { let head_ty = getLHsInstDeclHead inst_ty+       ; hsTyGetAppHead_maybe head_ty+       }++{-+Note [No nested foralls or contexts in instance types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type at the top of an instance declaration is one of the few places in GHC+where nested `forall`s or contexts are not permitted, even with RankNTypes+enabled. For example, the following will be rejected:++  instance forall a. forall b. Show (Either a b) where ...+  instance Eq a => Eq b => Show (Either a b) where ...+  instance (forall a. Show (Maybe a)) where ...+  instance (Eq a => Show (Maybe a)) where ...++This restriction is partly motivated by an unusual quirk of instance+declarations. Namely, if ScopedTypeVariables is enabled, then the type+variables from the top of an instance will scope over the bodies of the+instance methods, /even if the type variables are implicitly quantified/.+For example, GHC will accept the following:++  instance Monoid a => Monoid (Identity a) where+    mempty = Identity (mempty @a)++Moreover, the type in the top of an instance declaration must obey the+forall-or-nothing rule (see Note [forall-or-nothing rule]).+If instance types allowed nested `forall`s, this could+result in some strange interactions. For example, consider the following:++  class C a where+    m :: Proxy a+  instance (forall a. C (Either a b)) where+    m = Proxy @(Either a b)++Somewhat surprisingly, old versions of GHC would accept the instance above.+Even though the `forall` only quantifies `a`, the outermost parentheses mean+that the `forall` is nested, and per the forall-or-nothing rule, this means+that implicit quantification would occur. Therefore, the `a` is explicitly+bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would+bring /both/ sorts of type variables into scope over the body of `m`.+How utterly confusing!++To avoid this sort of confusion, we simply disallow nested `forall`s in+instance types, which makes things like the instance above become illegal.+For the sake of consistency, we also disallow nested contexts, even though they+don't have the same strange interaction with ScopedTypeVariables.++Just as we forbid nested `forall`s and contexts in normal instance+declarations, we also forbid them in SPECIALISE instance pragmas (#18455).+Unlike normal instance declarations, ScopedTypeVariables don't have any impact+on SPECIALISE instance pragmas, but we use the same validity checks for+SPECIALISE instance pragmas anyway to be consistent.++-----+-- Wrinkle: Derived instances+-----++`deriving` clauses and standalone `deriving` declarations also permit bringing+type variables into scope, either through explicit or implicit quantification.+Unlike in the tops of instance declarations, however, one does not need to+enable ScopedTypeVariables for this to take effect.++Just as GHC forbids nested `forall`s in the top of instance declarations, it+also forbids them in types involved with `deriving`:++1. In the `via` types in DerivingVia. For example, this is rejected:++     deriving via (forall x. V x) instance C (S x)++   Just like the types in instance declarations, `via` types can also bring+   both implicitly and explicitly bound type variables into scope. As a result,+   we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing+   behavior like in the example below:++     deriving via (forall x. T x y) instance W x y (Foo a b)+     -- Both x and y are brought into scope???+2. In the classes in `deriving` clauses. For example, this is rejected:++     data T = MkT deriving (C1, (forall x. C2 x y))++   This is because the generated instance would look like:++     instance forall x y. C2 x y T where ...++   So really, the same concerns as instance declarations apply here as well.+-}++{-+************************************************************************+*                                                                      *+                FieldOcc+*                                                                      *+************************************************************************++Note [Ambiguous FieldOcc in record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a "record field update" (`some_record{ field = expr }`), the field+occurrence may be ambiguous if there are multiple record types with that same+field label in scope. Instead of failing, we may attempt to do type-directed+disambiguation: if we typecheck the record field update, we can disambiguate+the `field` based on the record and field type.++In practice, this means an identifier of a field occurrence+(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field+ambiguity makes it impossible to construct a `Name` for the field.++Since type-directed disambiguation is a GHC property rather than a property of+the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`,+but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName+in the name. Very bad, yes, but since type-directed disambiguation is on the way+out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366),+we consider this acceptable for now.++see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation]++NB: FieldOcc preserves the RdrName throughout its lifecycle for+exact printing purposes.+-}++type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field+type instance XCFieldOcc GhcRn = RdrName+type instance XCFieldOcc GhcTc = RdrName++type instance XXFieldOcc (GhcPass p) = DataConCantHappen++--------------------------------------------------------------------------------++mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs+mkFieldOcc rdr = FieldOcc noExtField rdr++fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName+fieldOccRdrName fo = case ghcPass @p of+  GhcPs -> unLoc $ foLabel fo+  GhcRn -> foExt fo+  GhcTc -> foExt fo++-- ToDo SPJ: remove+--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p)+--fieldOccExt (FieldOcc { foExt = ext }) = ext++fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName+fieldOccLRdrName fo = case ghcPass @p of+  GhcPs -> foLabel fo+  GhcRn -> case fo of+    FieldOcc rdr sel ->+      let (L l _) = sel+       in L l rdr+  GhcTc ->+    let (L l _) = foLabel fo+     in L l (foExt fo)+++{-+************************************************************************+*                                                                      *+                OpName+*                                                                      *+************************************************************************+-}++-- | Name of an operator in an operator application or section+data OpName = NormalOp (WithUserRdr Name) -- ^ A normal identifier+            | NegateOp                    -- ^ Prefix negation+            | UnboundOp RdrName           -- ^ 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++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p => Outputable (HsBndrVar (GhcPass p)) where+  ppr (HsBndrVar _ name) = ppr name+  ppr (HsBndrWildCard _) = char '_'++class OutputableBndrFlag flag p where+  pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc++instance OutputableBndrFlag () p where+  pprTyVarBndr (HsTvb _ _ bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = parens_if_kind bkind d++instance OutputableBndrFlag Specificity p where+  pprTyVarBndr (HsTvb _ spec bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            InferredSpec  -> braces d+            SpecifiedSpec -> parens_if_kind bkind d++instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where+  pprTyVarBndr (HsTvb _ bvis bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case bvis of+            HsBndrRequired  _ -> parens_if_kind bkind d+            HsBndrInvisible _ -> char '@' <> parens_if_kind bkind d++instance OutputableBndrFlag ForAllTyFlag p where+  pprTyVarBndr (HsTvb _ spec bvar bkind) =+      text "forall" <+> decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            Inferred  -> braces d <> dot+            Specified -> parens_if_kind bkind d <> dot+            Required  -> parens_if_kind bkind d <+> text "->"++ppr_hs_tvb :: OutputableBndrId p => HsBndrVar (GhcPass p) -> HsBndrKind (GhcPass p) -> SDoc+ppr_hs_tvb bvar (HsBndrNoKind _) = ppr bvar+ppr_hs_tvb bvar (HsBndrKind _ k) = hsep [ppr bvar, dcolon, ppr k]++parens_if_kind :: HsBndrKind (GhcPass p) -> SDoc -> SDoc+parens_if_kind (HsBndrNoKind _) d = d+parens_if_kind (HsBndrKind _ _) d = parens d++instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where+    ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =+      pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body++instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where+    ppr ty = pprHsType ty++instance OutputableBndrId p+       => Outputable (LHsQTyVars (GhcPass p)) where+    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs++instance (OutputableBndrFlag flag p,+          OutputableBndrFlag flag (NoGhcTcPass p),+          OutputableBndrId p)+       => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where+    ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) =+      text "HsOuterImplicit:" <+> case ghcPass @p of+        GhcPs -> ppr imp_tvs+        GhcRn -> ppr imp_tvs+        GhcTc -> ppr imp_tvs+    ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =+      text "HsOuterExplicit:" <+> ppr exp_tvs++instance OutputableBndrId p+       => Outputable (HsForAllTelescope (GhcPass p)) where+    ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =+      text "HsForAllVis:" <+> ppr bndrs+    ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =+      text "HsForAllInvis:" <+> ppr bndrs++instance (OutputableBndrId p, OutputableBndrFlag flag p)+       => Outputable (HsTyVarBndr flag (GhcPass p)) where+    ppr = pprTyVarBndr++instance Outputable thing+       => Outputable (HsWildCardBndrs (GhcPass p) thing) where+    ppr (HsWC { hswc_body = ty }) = ppr ty++instance (OutputableBndrId p)+       => Outputable (HsPatSigType (GhcPass p)) where+    ppr (HsPS { hsps_body = ty }) = ppr ty+++instance (OutputableBndrId p)+       => Outputable (HsTyPat (GhcPass p)) where+    ppr (HsTP { hstp_body = ty }) = ppr ty+++instance (OutputableBndrId p)+       => Outputable (HsTyLit (GhcPass p)) where+    ppr = ppr_tylit++instance Outputable HsIPName where+    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters++instance OutputableBndr HsIPName where+    pprBndr _ n   = ppr n         -- Simple for now+    pprInfixOcc  n = ppr n+    pprPrefixOcc n = ppr n++instance (Outputable arg, Outputable rec)+         => Outputable (HsConDetails arg rec) where+  ppr (PrefixCon args) = text "PrefixCon:" <+> ppr args+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]++pprHsConDeclFieldWith :: (OutputableBndrId p)+                      => (HsMultAnn (GhcPass p) -> SDoc -> SDoc)+                      -> HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) =+  pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty))++pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d)++hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs+hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn))++mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs+mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds }+mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing+mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing++instance Outputable (XRecGhc (IdGhcP p)) =>+       Outputable (FieldOcc (GhcPass p)) where+  ppr = ppr . foLabel++instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where+  pprInfixOcc  = pprInfixOcc . unXRec @(GhcPass pass) . foLabel+  pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel++instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where+  pprInfixOcc  = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc++ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))++pprAnonWildCard :: SDoc+pprAnonWildCard = char '_'++-- | Prints the explicit @forall@ in a type family equation if one is written.+-- If there is no explicit @forall@, nothing is printed.+pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p+                           => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =+  forAllLit <+> interppSP qtvs <> dot++-- | Prints the outermost @forall@ in a type signature if one is written.+-- If there is no outermost @forall@, nothing is printed.+pprHsOuterSigTyVarBndrs :: OutputableBndrId p+                        => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =+  pprHsForAllTelescope (mkHsForAllInvisTele noAnn bndrs)++-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@+-- only when @-dppr-debug@ is enabled.+pprHsForAll :: forall p. OutputableBndrId p+            => HsForAllTelescope (GhcPass p)+            -> Maybe (LHsContext (GhcPass p)) -> SDoc+pprHsForAll tele cxt+  = pprHsForAllTelescope tele <+> pprLHsContext cxt++pprHsForAllTelescope :: forall p. OutputableBndrId p+                     => HsForAllTelescope (GhcPass p)+                     -> SDoc+pprHsForAllTelescope tele =+  case tele of+      HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs+      HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs+  where+    pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)+              => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc+    pp_forall separator qtvs+      | null qtvs = whenPprDebug (forAllLit <> separator)+  -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <>+  -- below needs to be <+>. But it means 94 other test results need to+  -- be updated to match.+      | otherwise = forAllLit <+> interppSP qtvs <> separator++pprLHsContext :: (OutputableBndrId p)+              => Maybe (LHsContext (GhcPass p)) -> SDoc+pprLHsContext Nothing = empty+pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt++-- For use in a HsQualTy, which always gets printed if it exists.+pprLHsContextAlways :: (OutputableBndrId p)+                    => LHsContext (GhcPass p) -> SDoc+pprLHsContextAlways (L _ ctxt)+  = case ctxt of+      []       -> parens empty             <+> darrow+      [L _ ty] -> ppr_mono_ty ty           <+> darrow+      _        -> parens (interpp'SP ctxt) <+> darrow++pprHsConDeclRecFields :: forall p. OutputableBndrId p+                 => [LHsConDeclRecField (GhcPass p)] -> SDoc+pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields)))++-- Printing works more-or-less as for Types++pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+pprHsType ty = ppr_mono_ty ty++ppr_mono_lty :: OutputableBndrId p+             => LHsType (GhcPass p) -> SDoc+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)++ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })+  = sep [pprHsForAll tele Nothing, ppr_mono_lty ty]++ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })+  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]++ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name+ppr_mono_ty (HsFunTy _ mult ty1 ty2)    = ppr_fun_ty mult ty1 ty2+ppr_mono_ty (HsTupleTy _ con tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `Solo x`, not `(x)`+  | [ty] <- tys+  , BoxedTuple <- std_con+  = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty]+  | otherwise+  = tupleParens std_con (pprWithCommas ppr tys)+  where std_con = case con of+                    HsUnboxedTuple -> UnboxedTuple+                    _              -> BoxedTuple+ppr_mono_ty (HsSumTy _ tys)+  = tupleParens UnboxedTuple (pprWithBars ppr tys)+ppr_mono_ty (HsKindSig _ ty kind)+  = ppr_mono_lty ty <+> dcolon <+> ppr kind+ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)+ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)+ppr_mono_ty (HsSpliceTy ext s)    =+    case ghcPass @p of+      GhcPs -> pprUntypedSplice True Nothing s+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s+      GhcRn | HsUntypedSpliceTop _ t  <- ext -> ppr t+      GhcTc -> pprUntypedSplice True Nothing s+ppr_mono_ty (HsExplicitListTy _ prom tys)+  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)+  | otherwise       = brackets (interpp'SP tys)+ppr_mono_ty (HsExplicitTupleTy _ prom tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `'MkSolo x`, not `'(x)`+  | [ty] <- tys+  = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]+  | otherwise+  = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys)+ppr_mono_ty (HsTyLit _ t)       = ppr t+ppr_mono_ty (HsWildCardTy {})   = char '_'++ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')++ppr_mono_ty (HsAppTy _ fun_ty arg_ty)+  = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]+ppr_mono_ty (HsAppKindTy _ ty k)+  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k+ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)+  = sep [ ppr_mono_lty ty1+        , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ]+ppr_mono_ty (HsParTy _ ty)+  = parens (ppr_mono_lty ty)+  -- Put the parens in where the user did+  -- But we still use the precedence stuff to add parens because+  --    toHsType doesn't put in any HsParTys, so we may still need them++ppr_mono_ty (HsDocTy _ ty doc)+  = pprWithDoc doc $ ppr_mono_lty ty++ppr_mono_ty (XHsType t) = case ghcPass @p of+  GhcPs -> case t of+    HsCoreTy ty     -> ppr ty+    HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty+    HsRecTy _ flds  -> pprHsConDeclRecFields flds+  GhcRn -> ppr t++--------------------------+ppr_fun_ty :: (OutputableBndrId p)+           => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc+ppr_fun_ty mult ty1 ty2+  = let p1 = ppr_mono_lty ty1+        p2 = ppr_mono_lty ty2+        arr = pprHsArrow mult+    in+    sep [p1, arr <+> p2]++quote_tuple :: PromotionFlag -> SDoc -> SDoc+quote_tuple IsPromoted  doc = quote doc+quote_tuple NotPromoted doc = doc++--------------------------+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses+-- under precedence @p@.+hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool+hsTypeNeedsParens p = go_hs_ty+  where+    go_hs_ty (HsForAllTy{})           = p >= funPrec+    go_hs_ty (HsQualTy{})             = p >= funPrec+    go_hs_ty (HsTyVar{})              = False+    go_hs_ty (HsFunTy{})              = p >= funPrec+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsTupleTy _ con [_])+      = case con of+          HsBoxedOrConstraintTuple   -> p >= appPrec+          HsUnboxedTuple             -> False+    go_hs_ty (HsTupleTy{})            = False+    go_hs_ty (HsSumTy{})              = False+    go_hs_ty (HsKindSig{})            = p >= sigPrec+    go_hs_ty (HsListTy{})             = False+    go_hs_ty (HsIParamTy{})           = p > topPrec+    go_hs_ty (HsSpliceTy{})           = False+    go_hs_ty (HsExplicitListTy{})     = False+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsExplicitTupleTy _ _ [_])+                                      = p >= appPrec+    go_hs_ty (HsExplicitTupleTy{})    = False+    go_hs_ty (HsTyLit{})              = False+    go_hs_ty (HsWildCardTy{})         = False+    go_hs_ty (HsStarTy{})             = p >= starPrec+    go_hs_ty (HsAppTy{})              = p >= appPrec+    go_hs_ty (HsAppKindTy{})          = p >= appPrec+    go_hs_ty (HsOpTy{})               = p >= opPrec+    go_hs_ty (HsParTy{})              = False+    go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t+    go_hs_ty (XHsType t)             = case ghcPass @p of+      GhcPs -> case t of+        HsCoreTy ty -> go_core_ty ty+        HsBangTy{}  -> p > topPrec+        HsRecTy{}   -> False+      GhcRn -> go_core_ty t++    go_core_ty (TyVarTy{})    = False+    go_core_ty (AppTy{})      = p >= appPrec+    go_core_ty (TyConApp _ args)+      | null args             = False+      | otherwise             = p >= appPrec+    go_core_ty (ForAllTy{})   = p >= funPrec+    go_core_ty (FunTy{})      = p >= funPrec+    go_core_ty (LitTy{})      = False+    go_core_ty (CastTy t _)   = go_core_ty t+    go_core_ty (CoercionTy{}) = False++maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc+-- See Note [Printing promoted type constructors]+-- in GHC.Iface.Type.  This code implements the same+-- logic for printing HsType+maybeAddSpace tys doc+  | (ty : _) <- tys+  , lhsTypeHasLeadingPromotionQuote ty = space <> doc+  | otherwise                          = doc++lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool+lhsTypeHasLeadingPromotionQuote ty+  = goL ty+  where+    goL (L _ ty) = go ty++    go (HsForAllTy{})        = False+    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})+      | (L _ (c:_)) <- ctxt = goL c+      | otherwise            = goL body+    go (HsTyVar _ p _)       = isPromoted p+    go (HsFunTy _ _ arg _)   = goL arg+    go (HsListTy{})          = False+    go (HsTupleTy{})         = False+    go (HsSumTy{})           = False+    go (HsOpTy _ _ t1 _ _)   = goL t1+    go (HsKindSig _ t _)     = goL t+    go (HsIParamTy{})        = False+    go (HsSpliceTy{})        = False+    go (HsExplicitListTy _ p _) = isPromoted p+    go (HsExplicitTupleTy{}) = True+    go (HsTyLit{})           = False+    go (HsWildCardTy{})      = False+    go (HsStarTy{})          = False+    go (HsAppTy _ t _)       = goL t+    go (HsAppKindTy _ t _)   = goL t+    go (HsParTy{})           = False+    go (HsDocTy _ t _)       = goL t+    go (XHsType{})           = False++-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is+-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply+-- returns @ty@.+parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)+parenthesizeHsType p lty@(L loc ty)+  | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)+  | otherwise              = lty++-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint+-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@+-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply+-- returns @ctxt@ unchanged.+parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)+parenthesizeHsContext p lctxt@(L loc ctxt) =+  case ctxt of+    [c] -> L loc [parenthesizeHsType p c]+    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of+                 -- being tuples.+{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC+type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA+  -- Explicit pass Anno instances needed because of the NoGhcTc field+type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA++type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA+type instance Anno HsIPName = EpAnnCO+type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA++type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
− GHC/Hs/Types.hs 
@@ -1,1739 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---GHC.Hs.Types: Abstract syntax: user-defined types--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]-                                      -- in module GHC.Hs.PlaceHolder-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Hs.Types (-        HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,-        HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..),-        LHsQTyVars(..),-        HsImplicitBndrs(..),-        HsWildCardBndrs(..),-        LHsSigType, LHsSigWcType, LHsWcType,-        HsTupleSort(..),-        HsContext, LHsContext, noLHsContext,-        HsTyLit(..),-        HsIPName(..), hsIPNameFS,-        HsArg(..), numVisibleArgs,-        LHsTypeArg,--        LBangType, BangType,-        HsSrcBang(..), HsImplBang(..),-        SrcStrictness(..), SrcUnpackedness(..),-        getBangType, getBangStrictness,--        ConDeclField(..), LConDeclField, pprConDeclFields,--        HsConDetails(..),--        FieldOcc(..), LFieldOcc, mkFieldOcc,-        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,-        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,-        unambiguousFieldOcc, ambiguousFieldOcc,--        mkAnonWildCardTy, pprAnonWildCard,--        mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody,-        mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,-        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs,-        isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,-        hsScopedTvs, hsWcScopedTvs, dropWildCards,-        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,-        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,-        splitLHsPatSynTy,-        splitLHsForAllTyInvis, splitLHsQualTy, splitLHsSigmaTyInvis,-        splitHsFunType, hsTyGetAppHead_maybe,-        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,-        ignoreParens, hsSigType, hsSigWcType,-        hsLTyVarBndrToType, hsLTyVarBndrsToTypes,-        hsTyKindSig,-        hsConDetailsArgs,--        -- Printing-        pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,-        pprLHsContext,-        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext-    ) where--#include "HsVersions.h"--import GhcPrelude--import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice )--import GHC.Hs.Extension--import Id ( Id )-import Name( Name, NamedThing(getName) )-import RdrName ( RdrName )-import DataCon( HsSrcBang(..), HsImplBang(..),-                SrcStrictness(..), SrcUnpackedness(..) )-import TysPrim( funTyConName )-import TysWiredIn( mkTupleStr )-import Type-import GHC.Hs.Doc-import BasicTypes-import SrcLoc-import Outputable-import FastString-import Maybes( isJust )-import Util ( count, debugIsOn )--import Data.Data hiding ( Fixity, Prefix, Infix )--{--************************************************************************-*                                                                      *-\subsection{Bang annotations}-*                                                                      *-************************************************************************--}---- | Located Bang Type-type LBangType pass = Located (BangType pass)---- | Bang Type------ In the parser, strictness and packedness annotations bind more tightly--- than docstrings. This means that when consuming a 'BangType' (and looking--- for 'HsBangTy') we must be ready to peer behind a potential layer of--- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.-type BangType pass  = HsType pass       -- Bangs are in the HsType data type--getBangType :: LHsType a -> LHsType a-getBangType                 (L _ (HsBangTy _ _ lty))       = lty-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =-  addCLoc lty lds (HsDocTy x lty lds)-getBangType lty                                            = lty--getBangStrictness :: LHsType a -> HsSrcBang-getBangStrictness                 (L _ (HsBangTy _ s _))     = s-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s-getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)--{--************************************************************************-*                                                                      *-\subsection{Data types}-*                                                                      *-************************************************************************--This is the syntax for types as seen in type signatures.--Note [HsBSig binder lists]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a binder (or pattern) decorated with a type or kind,-   \ (x :: a -> a). blah-   forall (a :: k -> *) (b :: k). blah-Then we use a LHsBndrSig on the binder, so that the-renamer can decorate it with the variables bound-by the pattern ('a' in the first example, 'k' in the second),-assuming that neither of them is in scope already-See also Note [Kind and type-variable binders] in RnTypes--Note [HsType binders]-~~~~~~~~~~~~~~~~~~~~~-The system for recording type and kind-variable binders in HsTypes-is a bit complicated.  Here's how it works.--* In a HsType,-     HsForAllTy   represents an /explicit, user-written/ 'forall'-                   e.g.   forall a b.   {...} or-                          forall a b -> {...}-     HsQualTy     represents an /explicit, user-written/ context-                   e.g.   (Eq a, Show a) => ...-                  The context can be empty if that's what the user wrote-  These constructors represent what the user wrote, no more-  and no less.--* The ForallVisFlag field of HsForAllTy represents whether a forall is-  invisible (e.g., forall a b. {...}, with a dot) or visible-  (e.g., forall a b -> {...}, with an arrow).--* HsTyVarBndr describes a quantified type variable written by the-  user.  For example-     f :: forall a (b :: *).  blah-  here 'a' and '(b::*)' are each a HsTyVarBndr.  A HsForAllTy has-  a list of LHsTyVarBndrs.--* HsImplicitBndrs is a wrapper that gives the implicitly-quantified-  kind and type variables of the wrapped thing.  It is filled in by-  the renamer. For example, if the user writes-     f :: a -> a-  the HsImplicitBinders binds the 'a' (not a HsForAllTy!).-  NB: this implicit quantification is purely lexical: we bind any-      type or kind variables that are not in scope. The type checker-      may subsequently quantify over further kind variables.--* HsWildCardBndrs is a wrapper that binds the wildcard variables-  of the wrapped thing.  It is filled in by the renamer-     f :: _a -> _-  The enclosing HsWildCardBndrs binds the wildcards _a and _.--* The explicit presence of these wrappers specifies, in the HsSyn,-  exactly where implicit quantification is allowed, and where-  wildcards are allowed.--* LHsQTyVars is used in data/class declarations, where the user gives-  explicit *type* variable bindings, but we need to implicitly bind-  *kind* variables.  For example-      class C (a :: k -> *) where ...-  The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars--Note [The wildcard story for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Types can have wildcards in them, to support partial type signatures,-like       f :: Int -> (_ , _a) -> _a--A wildcard in a type can be--  * An anonymous wildcard,-        written '_'-    In HsType this is represented by HsWildCardTy.-    The renamer leaves it untouched, and it is later given fresh meta tyvars in-    the typechecker.--  * A named wildcard,-        written '_a', '_foo', etc-    In HsType this is represented by (HsTyVar "_a")-    i.e. a perfectly ordinary type variable that happens-         to start with an underscore--Note carefully:--* When NamedWildCards is off, type variables that start with an-  underscore really /are/ ordinary type variables.  And indeed, even-  when NamedWildCards is on you can bind _a explicitly as an ordinary-  type variable:-        data T _a _b = MkT _b _a-  Or even:-        f :: forall _a. _a -> _b-  Here _a is an ordinary forall'd binder, but (With NamedWildCards)-  _b is a named wildcard.  (See the comments in #10982)--* Named wildcards are bound by the HsWildCardBndrs construct, which wraps-  types that are allowed to have wildcards. Unnamed wildcards however are left-  unchanged until typechecking, where we give them fresh wild tyavrs and-  determine whether or not to emit hole constraints on each wildcard-  (we don't if it's a visible type/kind argument or a type family pattern).-  See related notes Note [Wildcards in visible kind application]-  and Note [Wildcards in visible type application] in TcHsType.hs--* After type checking is done, we report what types the wildcards-  got unified with.--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 a *stable topological sort* on the variables.-By "stable", we mean that any two variables who do not depend on each other-preserve their existing left-to-right ordering.--Implicitly bound variables are collected by the extract- family of functions-(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes.-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.--}---- | Located Haskell Context-type LHsContext pass = Located (HsContext pass)-      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit'-      -- For details on above see note [Api annotations] in ApiAnnotation--noLHsContext :: LHsContext pass--- Use this when there is no context in the original program--- It would really be more kosher to use a Maybe, to distinguish---     class () => C a where ...--- from---     class C a where ...-noLHsContext = noLoc []---- | Haskell Context-type HsContext pass = [LHsType pass]---- | Located Haskell Type-type LHsType pass = Located (HsType pass)-      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when-      --   in a list--      -- For details on above see note [Api annotations] in ApiAnnotation---- | Haskell Kind-type HsKind pass = HsType pass---- | Located Haskell Kind-type LHsKind pass = Located (HsKind pass)-      -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'--      -- For details on above see note [Api annotations] in ApiAnnotation-------------------------------------------------------             LHsQTyVars---  The explicitly-quantified binders in a data/type declaration---- | Located Haskell Type Variable Binder-type LHsTyVarBndr pass = Located (HsTyVarBndr pass)-                         -- See Note [HsType binders]---- | Located Haskell Quantified Type Variables-data LHsQTyVars pass   -- See Note [HsType binders]-  = HsQTvs { hsq_ext :: XHsQTvs pass--           , hsq_explicit :: [LHsTyVarBndr pass]-                -- Explicit variables, written by the user-                -- See Note [HsForAllTy tyvar binders]-    }-  | XLHsQTyVars (XXLHsQTyVars pass)--type HsQTvsRn = [Name]  -- Implicit variables-  -- For example, in   data T (a :: k1 -> k2) = ...-  -- the 'a' is explicit while 'k1', 'k2' are implicit--type instance XHsQTvs GhcPs = NoExtField-type instance XHsQTvs GhcRn = HsQTvsRn-type instance XHsQTvs GhcTc = HsQTvsRn--type instance XXLHsQTyVars  (GhcPass _) = NoExtCon--mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs-mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }--hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass]-hsQTvExplicit = hsq_explicit--emptyLHsQTvs :: LHsQTyVars GhcRn-emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }--isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool-isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp })-  = null imp && null exp-isEmptyLHsQTvs _ = False-----------------------------------------------------            HsImplicitBndrs--- Used to quantify the implicit binders of a type---    * Implicit binders of a type signature (LHsSigType/LHsSigWcType)---    * Patterns in a type/data family instance (HsTyPats)---- | Haskell Implicit Binders-data HsImplicitBndrs pass thing   -- See Note [HsType binders]-  = HsIB { hsib_ext  :: XHsIB pass thing -- after renamer: [Name]-                                         -- Implicitly-bound kind & type vars-                                         -- Order is important; see-                                         -- Note [Ordering of implicit variables]-                                         -- in RnTypes--         , hsib_body :: thing            -- Main payload (type or list of types)-    }-  | XHsImplicitBndrs (XXHsImplicitBndrs pass thing)--type instance XHsIB              GhcPs _ = NoExtField-type instance XHsIB              GhcRn _ = [Name]-type instance XHsIB              GhcTc _ = [Name]--type instance XXHsImplicitBndrs  (GhcPass _) _ = NoExtCon---- | Haskell Wildcard Binders-data HsWildCardBndrs pass thing-    -- See Note [HsType binders]-    -- See Note [The wildcard story for types]-  = HsWC { hswc_ext :: XHsWC pass thing-                -- after the renamer-                -- Wild cards, only named-                -- See Note [Wildcards in visible kind application]--         , hswc_body :: thing-                -- Main payload (type or list of types)-                -- If there is an extra-constraints wildcard,-                -- it's still there in the hsc_body.-    }-  | XHsWildCardBndrs (XXHsWildCardBndrs pass thing)--type instance XHsWC              GhcPs b = NoExtField-type instance XHsWC              GhcRn b = [Name]-type instance XHsWC              GhcTc b = [Name]--type instance XXHsWildCardBndrs  (GhcPass _) b = NoExtCon---- | Located Haskell Signature Type-type LHsSigType   pass = HsImplicitBndrs pass (LHsType pass)    -- Implicit only---- | Located Haskell Wildcard Type-type LHsWcType    pass = HsWildCardBndrs pass (LHsType pass)    -- Wildcard only---- | Located Haskell Signature Wildcard Type-type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both---- See Note [Representing type signatures]--hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing-hsImplicitBody (HsIB { hsib_body = body }) = body-hsImplicitBody (XHsImplicitBndrs nec) = noExtCon nec--hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)-hsSigType = hsImplicitBody--hsSigWcType :: LHsSigWcType pass -> LHsType pass-hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)--dropWildCards :: LHsSigWcType pass -> LHsSigType pass--- Drop the wildcard part of a LHsSigWcType-dropWildCards sig_ty = hswc_body sig_ty--{- Note [Representing type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsSigType is used to represent an explicit user type signature-such as   f :: a -> a-     or   g (x :: a -> a) = x--A HsSigType is just a HsImplicitBndrs wrapping a LHsType.- * The HsImplicitBndrs binds the /implicitly/ quantified tyvars- * The LHsType binds the /explicitly/ quantified tyvars--E.g. For a signature like-   f :: forall (a::k). blah-we get-   HsIB { hsib_vars = [k]-        , hsib_body = HsForAllTy { hst_bndrs = [(a::*)]-                                 , hst_body = blah }-The implicit kind variable 'k' is bound by the HsIB;-the explicitly forall'd tyvar 'a' is bound by the HsForAllTy--}--mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing-mkHsImplicitBndrs x = HsIB { hsib_ext  = noExtField-                           , hsib_body = x }--mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing-mkHsWildCardBndrs x = HsWC { hswc_body = x-                           , hswc_ext  = noExtField }---- Add empty binders.  This is a bit suspicious; what if--- the wrapped thing had free type variables?-mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing-mkEmptyImplicitBndrs x = HsIB { hsib_ext = []-                              , hsib_body = x }--mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing-mkEmptyWildCardBndrs x = HsWC { hswc_body = x-                              , hswc_ext  = [] }-------------------------------------------------------- | These names are used early on to store the names of implicit--- parameters.  They completely disappear after type-checking.-newtype HsIPName = HsIPName FastString-  deriving( Eq, Data )--hsIPNameFS :: HsIPName -> FastString-hsIPNameFS (HsIPName n) = n--instance Outputable HsIPName where-    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters--instance OutputableBndr HsIPName where-    pprBndr _ n   = ppr n         -- Simple for now-    pprInfixOcc  n = ppr n-    pprPrefixOcc n = ppr n-------------------------------------------------------- | Haskell Type Variable Binder-data HsTyVarBndr pass-  = UserTyVar        -- no explicit kinding-         (XUserTyVar pass)-         (Located (IdP pass))-        -- See Note [Located RdrNames] in GHC.Hs.Expr-  | KindedTyVar-         (XKindedTyVar pass)-         (Located (IdP pass))-         (LHsKind pass)  -- The user-supplied kind signature-        -- ^-        --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',-        --          'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose'--        -- For details on above see note [Api annotations] in ApiAnnotation--  | XTyVarBndr-      (XXTyVarBndr pass)--type instance XUserTyVar    (GhcPass _) = NoExtField-type instance XKindedTyVar  (GhcPass _) = NoExtField--type instance XXTyVarBndr   (GhcPass _) = NoExtCon---- | Does this 'HsTyVarBndr' come with an explicit kind annotation?-isHsKindedTyVar :: HsTyVarBndr pass -> Bool-isHsKindedTyVar (UserTyVar {})   = False-isHsKindedTyVar (KindedTyVar {}) = True-isHsKindedTyVar (XTyVarBndr {})  = False---- | Do all type variables in this 'LHsQTyVars' come with kind annotations?-hsTvbAllKinded :: LHsQTyVars pass -> Bool-hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit--instance NamedThing (HsTyVarBndr GhcRn) where-  getName (UserTyVar _ v) = unLoc v-  getName (KindedTyVar _ v _) = unLoc v-  getName (XTyVarBndr nec) = noExtCon nec---- | Haskell Type-data HsType pass-  = HsForAllTy   -- See Note [HsType binders]-      { hst_xforall :: XForAllTy pass-      , hst_fvf     :: ForallVisFlag -- Is this `forall a -> {...}` or-                                     --         `forall a. {...}`?-      , hst_bndrs   :: [LHsTyVarBndr pass]-                                       -- Explicit, user-supplied 'forall a b c'-      , hst_body    :: LHsType pass      -- body type-      }-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall',-      --         'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'-      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsQualTy   -- See Note [HsType binders]-      { hst_xqual :: XQualTy pass-      , hst_ctxt  :: LHsContext pass       -- Context C => blah-      , hst_body  :: LHsType pass }--  | HsTyVar  (XTyVar pass)-              PromotionFlag    -- Whether explicitly promoted,-                               -- for the pretty printer-             (Located (IdP pass))-                  -- Type variable, type constructor, or data constructor-                  -- see Note [Promotions (HsTyVar)]-                  -- See Note [Located RdrNames] in GHC.Hs.Expr-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsAppTy             (XAppTy pass)-                        (LHsType pass)-                        (LHsType pass)-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsAppKindTy         (XAppKindTy pass) -- type level type app-                        (LHsType pass)-                        (LHsKind pass)--  | HsFunTy             (XFunTy pass)-                        (LHsType pass)   -- function type-                        (LHsType pass)-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow',--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsListTy            (XListTy pass)-                        (LHsType pass)  -- Element type-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@,-      --         'ApiAnnotation.AnnClose' @']'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsTupleTy           (XTupleTy pass)-                        HsTupleSort-                        [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@,-    --         'ApiAnnotation.AnnClose' @')' or '#)'@--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsSumTy             (XSumTy pass)-                        [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@,-    --         'ApiAnnotation.AnnClose' '#)'@--    -- For details on above see note [Api annotations] in ApiAnnotation--  | HsOpTy              (XOpTy pass)-                        (LHsType pass) (Located (IdP pass)) (LHsType pass)-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsParTy             (XParTy pass)-                        (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr-        -- Parenthesis preserved for the precedence re-arrangement in RnTypes-        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,-      --         'ApiAnnotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsIParamTy          (XIParamTy pass)-                        (Located HsIPName) -- (?x :: ty)-                        (LHsType pass)   -- Implicit parameters as they occur in-                                         -- contexts-      -- ^-      -- > (?x :: ty)-      ---      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsStarTy            (XStarTy pass)-                        Bool             -- Is this the Unicode variant?-                                         -- Note [HsStarTy]-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--  | HsKindSig           (XKindSig pass)-                        (LHsType pass)  -- (ty :: kind)-                        (LHsKind pass)  -- A type with a kind signature-      -- ^-      -- > (ty :: kind)-      ---      -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@,-      --         'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsSpliceTy          (XSpliceTy pass)-                        (HsSplice pass)   -- Includes quasi-quotes-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@,-      --         'ApiAnnotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsDocTy             (XDocTy pass)-                        (LHsType pass) LHsDocString -- A documented type-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsBangTy    (XBangTy pass)-                HsSrcBang (LHsType pass)   -- Bang-style type annotations-      -- ^ - 'ApiAnnotation.AnnKeywordId' :-      --         'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,-      --         'ApiAnnotation.AnnClose' @'#-}'@-      --         'ApiAnnotation.AnnBang' @\'!\'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsRecTy     (XRecTy pass)-                [LConDeclField pass]    -- Only in data type declarations-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@,-      --         'ApiAnnotation.AnnClose' @'}'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*-  --                                -- Core Type through HsSyn.-  --     -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsExplicitListTy       -- A promoted explicit list-        (XExplicitListTy pass)-        PromotionFlag      -- whether explcitly promoted, for pretty printer-        [LHsType pass]-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@,-      --         'ApiAnnotation.AnnClose' @']'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsExplicitTupleTy      -- A promoted explicit tuple-        (XExplicitTupleTy pass)-        [LHsType pass]-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@,-      --         'ApiAnnotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  | HsWildCardTy (XWildCardTy pass)  -- A type wildcard-      -- See Note [The wildcard story for types]-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in ApiAnnotation--  -- For adding new constructors via Trees that Grow-  | XHsType-      (XXType pass)--data NewHsTypeX-  = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*-                   -- Core Type through HsSyn.-    deriving Data-      -- ^ - 'ApiAnnotation.AnnKeywordId' : None--instance Outputable NewHsTypeX where-  ppr (NHsCoreTy ty) = ppr ty--type instance XForAllTy        (GhcPass _) = NoExtField-type instance XQualTy          (GhcPass _) = NoExtField-type instance XTyVar           (GhcPass _) = NoExtField-type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = NoExtField-type instance XListTy          (GhcPass _) = NoExtField-type instance XTupleTy         (GhcPass _) = NoExtField-type instance XSumTy           (GhcPass _) = NoExtField-type instance XOpTy            (GhcPass _) = NoExtField-type instance XParTy           (GhcPass _) = NoExtField-type instance XIParamTy        (GhcPass _) = NoExtField-type instance XStarTy          (GhcPass _) = NoExtField-type instance XKindSig         (GhcPass _) = NoExtField--type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives--type instance XSpliceTy        GhcPs = NoExtField-type instance XSpliceTy        GhcRn = NoExtField-type instance XSpliceTy        GhcTc = Kind--type instance XDocTy           (GhcPass _) = NoExtField-type instance XBangTy          (GhcPass _) = NoExtField-type instance XRecTy           (GhcPass _) = NoExtField--type instance XExplicitListTy  GhcPs = NoExtField-type instance XExplicitListTy  GhcRn = NoExtField-type instance XExplicitListTy  GhcTc = Kind--type instance XExplicitTupleTy GhcPs = NoExtField-type instance XExplicitTupleTy GhcRn = NoExtField-type instance XExplicitTupleTy GhcTc = [Kind]--type instance XTyLit           (GhcPass _) = NoExtField--type instance XWildCardTy      (GhcPass _) = NoExtField--type instance XXType         (GhcPass _) = NewHsTypeX----- Note [Literal source text] in BasicTypes for SourceText fields in--- the following--- | Haskell Type Literal-data HsTyLit-  = HsNumTy SourceText Integer-  | HsStrTy SourceText FastString-    deriving Data---{--Note [HsForAllTy tyvar binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After parsing:-  * Implicit => empty-    Explicit => the variables the user wrote--After renaming-  * Implicit => the *type* variables free in the type-    Explicit => the variables the user wrote (renamed)--Qualified currently behaves exactly as Implicit,-but it is deprecated to use it for implicit quantification.-In this case, GHC 7.10 gives a warning; see-Note [Context quantification] in RnTypes, and #4426.-In GHC 8.0, Qualified will no longer bind variables-and this will become an error.--The kind variables bound in the hsq_implicit field come both-  a) from the kind signatures on the kind vars (eg k1)-  b) from the scope of the forall (eg k2)-Example:   f :: forall (a::k1) b. T a (b::k2)---Note [Unit tuples]-~~~~~~~~~~~~~~~~~~-Consider the type-    type instance F Int = ()-We want to parse that "()"-    as HsTupleTy HsBoxedOrConstraintTuple [],-NOT as HsTyVar unitTyCon--Why? Because F might have kind (* -> Constraint), so we when parsing we-don't know if that tuple is going to be a constraint tuple or an ordinary-unit tuple.  The HsTupleSort flag is specifically designed to deal with-that, but it has to work for unit tuples too.--Note [Promotions (HsTyVar)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsTyVar: A name in a type or kind.-  Here are the allowed namespaces for the name.-    In a type:-      Var: not allowed-      Data: promoted data constructor-      Tv: type variable-      TcCls before renamer: type constructor, class constructor, or promoted data constructor-      TcCls after renamer: type constructor or class constructor-    In a kind:-      Var, Data: not allowed-      Tv: kind variable-      TcCls: kind constructor or promoted type constructor--  The 'Promoted' field in an HsTyVar captures whether the type was promoted in-  the source code by prefixing an apostrophe.--Note [HsStarTy]-~~~~~~~~~~~~~~~-When the StarIsType extension is enabled, we want to treat '*' and its Unicode-variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser-would mean that when we pretty-print it back, we don't know whether the user-wrote '*' or 'Type', and lose the parse/ppr roundtrip property.--As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')-and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).-When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not-involved.---Note [Promoted lists and tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Notice the difference between-   HsListTy    HsExplicitListTy-   HsTupleTy   HsExplicitListTupleTy--E.g.    f :: [Int]                      HsListTy--        g3  :: T '[]                   All these use-        g2  :: T '[True]                  HsExplicitListTy-        g1  :: T '[True,False]-        g1a :: T [True,False]             (can omit ' where unambiguous)--  kind of T :: [Bool] -> *        This kind uses HsListTy!--E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair-        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by-                                           a type-level pair of booleans-        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy--Note [Distinguishing tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Apart from promotion, tuples can have one of three different kinds:--        x :: (Int, Bool)                -- Regular boxed tuples-        f :: Int# -> (# Int#, Int# #)   -- Unboxed tuples-        g :: (Eq a, Ord a) => a         -- Constraint tuples--For convenience, internally we use a single constructor for all of these,-namely HsTupleTy, but keep track of the tuple kind (in the first argument to-HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,-because of the #. However, with -XConstraintKinds we can only distinguish-between constraint and boxed tuples during type checking, in general. Hence the-four constructors of HsTupleSort:--        HsUnboxedTuple                  -> Produced by the parser-        HsBoxedTuple                    -> Certainly a boxed tuple-        HsConstraintTuple               -> Certainly a constraint tuple-        HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint-                                        tuple. Produced by the parser only,-                                        disappears after type checking--}---- | Haskell Tuple Sort-data HsTupleSort = HsUnboxedTuple-                 | HsBoxedTuple-                 | HsConstraintTuple-                 | HsBoxedOrConstraintTuple-                 deriving Data---- | Located Constructor Declaration Field-type LConDeclField pass = Located (ConDeclField pass)-      -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when-      --   in a list--      -- For details on above see note [Api annotations] in ApiAnnotation---- | Constructor Declaration Field-data ConDeclField pass  -- Record fields have Haddoc docs on them-  = ConDeclField { cd_fld_ext  :: XConDeclField pass,-                   cd_fld_names :: [LFieldOcc pass],-                                   -- ^ See Note [ConDeclField passs]-                   cd_fld_type :: LBangType pass,-                   cd_fld_doc  :: Maybe LHsDocString }-      -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'--      -- For details on above see note [Api annotations] in ApiAnnotation-  | XConDeclField (XXConDeclField pass)--type instance XConDeclField  (GhcPass _) = NoExtField-type instance XXConDeclField (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (ConDeclField (GhcPass p)) where-  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty-  ppr (XConDeclField x) = ppr x---- HsConDetails is used for patterns/expressions *and* for data type--- declarations--- | Haskell Constructor Details-data HsConDetails arg rec-  = PrefixCon [arg]             -- C p1 p2 p3-  | RecCon    rec               -- C { x = p1, y = p2 }-  | InfixCon  arg arg           -- p1 `C` p2-  deriving Data--instance (Outputable arg, Outputable rec)-         => Outputable (HsConDetails arg rec) where-  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args-  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec-  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]--hsConDetailsArgs ::-     HsConDetails (LHsType a) (Located [LConDeclField a])-  -> [LHsType a]-hsConDetailsArgs details = case details of-  InfixCon a b -> [a,b]-  PrefixCon xs -> xs-  RecCon r -> map (cd_fld_type . unLoc) (unLoc r)--{--Note [ConDeclField passs]-~~~~~~~~~~~~~~~~~~~~~~~~~--A ConDeclField contains a list of field occurrences: these always-include the field label as the user wrote it.  After the renamer, it-will additionally contain the identity of the selector function in the-second component.--Due to DuplicateRecordFields, the OccName of the selector function-may have been mangled, which is why we keep the original field label-separately.  For example, when DuplicateRecordFields is enabled--    data T = MkT { x :: Int }--gives--    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.--}---------------------------- A valid type must have a for-all at the top of the type, or of the fn arg--- types------------------------hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]--- Get the lexically-scoped type variables of a HsSigType---  - the explicitly-given forall'd type variables---  - the named wildcars; see Note [Scoping of named wildcards]--- because they scope in the same way-hsWcScopedTvs sig_ty-  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 }  <- sig_ty-  , HsIB { hsib_ext = vars-         , hsib_body = sig_ty2 } <- sig_ty1-  = case sig_ty2 of-      L _ (HsForAllTy { hst_fvf = vis_flag-                      , hst_bndrs = tvs }) ->-        ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag]-        vars ++ nwcs ++ hsLTyVarNames tvs-      _                                    -> nwcs-hsWcScopedTvs (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec-hsWcScopedTvs (XHsWildCardBndrs nec) = noExtCon nec--hsScopedTvs :: LHsSigType GhcRn -> [Name]--- Same as hsWcScopedTvs, but for a LHsSigType-hsScopedTvs sig_ty-  | HsIB { hsib_ext = vars-         , hsib_body = sig_ty2 } <- sig_ty-  , L _ (HsForAllTy { hst_fvf = vis_flag-                    , hst_bndrs = tvs }) <- sig_ty2-  = ASSERT( vis_flag == ForallInvis ) -- See Note [hsScopedTvs vis_flag]-    vars ++ hsLTyVarNames tvs-  | otherwise-  = []--{- Note [Scoping of named wildcards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: _a -> _a-  f x = let g :: _a -> _a-            g = ...-        in ...--Currently, for better or worse, the "_a" variables are all the same. So-although there is no explicit forall, the "_a" scopes over the definition.-I don't know if this is a good idea, but there it is.--}--{- Note [hsScopedTvs vis_flag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--XScopedTypeVariables can be defined in terms of a desugaring to--XTypeAbstractions (GHC Proposal #50):--    fn :: forall a b c. tau(a,b,c)            fn :: forall a b c. tau(a,b,c)-    fn = defn(a,b,c)                   ==>    fn @x @y @z = defn(x,y,z)--That is, for every type variable of the leading 'forall' in the type signature,-we add an invisible binder at term level.--This model does not extend to visible forall, as discussed here:--* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412-* https://github.com/ghc-proposals/ghc-proposals/pull/238--The conclusion of these discussions can be summarized as follows:--  > Assuming support for visible 'forall' in terms, consider this example:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn = \a b -> ...-  >-  > The user has written their own binders 'a' and 'b' to stand for 'x' and-  > 'y', and we definitely should not desugar this into:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn x y = \a b -> ...         -- bad!--At the moment, GHC does not support visible 'forall' in terms, so we simply cement-our assumptions with an assert:--    hsScopedTvs (HsForAllTy { hst_fvf = vis_flag, ... }) =-      ASSERT( vis_flag == ForallInvis )-      ...--In the future, this assert can be safely turned into a pattern match to support-visible forall in terms:--    hsScopedTvs (HsForAllTy { hst_fvf = ForallInvis, ... }) = ...--}------------------------hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p)-hsTyVarName (UserTyVar _ (L _ n))     = n-hsTyVarName (KindedTyVar _ (L _ n) _) = n-hsTyVarName (XTyVarBndr nec) = noExtCon nec--hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p)-hsLTyVarName = hsTyVarName . unLoc--hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)]-hsLTyVarNames = map hsLTyVarName--hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]--- Explicit variables only-hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)--hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]--- All variables-hsAllLTyVarNames (HsQTvs { hsq_ext = kvs-                         , hsq_explicit = tvs })-  = kvs ++ hsLTyVarNames tvs-hsAllLTyVarNames (XLHsQTyVars nec) = noExtCon nec--hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p))-hsLTyVarLocName = onHasSrcSpan hsTyVarName--hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]-hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)---- | Convert a LHsTyVarBndr to an equivalent LHsType.-hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p)-hsLTyVarBndrToType = onHasSrcSpan cvt-  where cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n-        cvt (KindedTyVar _ (L name_loc n) kind)-          = HsKindSig noExtField-                   (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind-        cvt (XTyVarBndr nec) = noExtCon nec---- | Convert a LHsTyVarBndrs to a list of types.--- Works on *type* variable only, no kind vars.-hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)]-hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs-hsLTyVarBndrsToTypes (XLHsQTyVars nec) = noExtCon nec---- | Get the kind signature of a type, ignoring parentheses:------   hsTyKindSig   `Maybe                    `   =   Nothing---   hsTyKindSig   `Maybe ::   Type -> Type  `   =   Just  `Type -> Type`---   hsTyKindSig   `Maybe :: ((Type -> Type))`   =   Just  `Type -> Type`------ This is used to extract the result kind of type synonyms with a CUSK:------  type S = (F :: res_kind)---                 ^^^^^^^^----hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass)-hsTyKindSig lty =-  case unLoc lty of-    HsParTy _ lty'    -> hsTyKindSig lty'-    HsKindSig _ _ k   -> Just k-    _                 -> Nothing------------------------ignoreParens :: LHsType pass -> LHsType pass-ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty-ignoreParens ty                   = ty--isLHsForAllTy :: LHsType p -> Bool-isLHsForAllTy (L _ (HsForAllTy {})) = True-isLHsForAllTy _                     = False--{--************************************************************************-*                                                                      *-                Building types-*                                                                      *-************************************************************************--}--mkAnonWildCardTy :: HsType GhcPs-mkAnonWildCardTy = HsWildCardTy noExtField--mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))-         -> LHsType (GhcPass p) -> HsType (GhcPass p)-mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2--mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-mkHsAppTy t1 t2-  = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))--mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]-           -> LHsType (GhcPass p)-mkHsAppTys = foldl' mkHsAppTy--mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-              -> LHsType (GhcPass p)-mkHsAppKindTy ext ty k-  = addCLoc ty k (HsAppKindTy ext ty k)--{--************************************************************************-*                                                                      *-                Decomposing HsTypes-*                                                                      *-************************************************************************--}-------------------------------------- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)--- Breaks up any parens in the result type:---      splitHsFunType (a -> (b -> c)) = ([a,b], c)--- Also deals with (->) t1 t2; that is why it only works on LHsType Name---   (see #9096)-splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn)-splitHsFunType (L _ (HsParTy _ ty))-  = splitHsFunType ty--splitHsFunType (L _ (HsFunTy _ x y))-  | (args, res) <- splitHsFunType y-  = (x:args, res)-{- This is not so correct, because it won't work with visible kind app, in case-  someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing-  ConDeclGADT abstract syntax -}-splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2))-  = go t1 [t2]-  where  -- Look for (->) t1 t2, possibly with parenthesisation-    go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName-                                 , [t1,t2] <- tys-                                 , (args, res) <- splitHsFunType t2-                                 = (t1:args, res)-    go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys)-    go (L _ (HsParTy _ ty))    tys = go ty tys-    go _                       _   = ([], orig_ty)  -- Failure to match--splitHsFunType other = ([], other)---- retrieve the name of the "head" of a nested type application--- somewhat like splitHsAppTys, but a little more thorough--- used to examine the result of a GADT-like datacon, so it doesn't handle--- *all* cases (like lists, tuples, (~), etc.)-hsTyGetAppHead_maybe :: LHsType (GhcPass p)-                     -> Maybe (Located (IdP (GhcPass p)))-hsTyGetAppHead_maybe = go-  where-    go (L _ (HsTyVar _ _ ln))          = Just ln-    go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _))       = go t-    go (L _ (HsOpTy _ _ (L loc n) _))  = Just (L loc n)-    go (L _ (HsParTy _ t))             = go t-    go (L _ (HsKindSig _ t _))         = go t-    go _                               = Nothing----------------------------------------------------------------- Arguments in an expression/type after splitting-data HsArg tm ty-  = HsValArg tm   -- Argument is an ordinary expression     (f arg)-  | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)-                         -- SrcSpan is location of the `@`-  | HsArgPar SrcSpan -- See Note [HsArgPar]--numVisibleArgs :: [HsArg tm ty] -> Arity-numVisibleArgs = count is_vis-  where is_vis (HsValArg _) = True-        is_vis _            = False---- type level equivalent-type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)--instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where-  ppr (HsValArg tm)    = ppr tm-  ppr (HsTypeArg _ ty) = char '@' <> ppr ty-  ppr (HsArgPar sp)    = text "HsArgPar"  <+> ppr sp-{--Note [HsArgPar]-A HsArgPar indicates that everything to the left of this in the argument list is-enclosed in parentheses together with the function itself. It is necessary so-that we can recreate the parenthesis structure in the original source after-typechecking the arguments.--The SrcSpan is the span of the original HsPar--((f arg1) arg2 arg3) results in an input argument list of-[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]---}-------------------------------------- | Decompose a pattern synonym type signature into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsPatSynTy :: LHsType pass-                 -> ( [LHsTyVarBndr pass]    -- universals-                    , LHsContext pass        -- required constraints-                    , [LHsTyVarBndr pass]    -- existentials-                    , LHsContext pass        -- provided constraints-                    , LHsType pass)          -- body type-splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)-  where-    (univs, ty1) = splitLHsForAllTyInvis ty-    (reqs,  ty2) = splitLHsQualTy ty1-    (exis,  ty3) = splitLHsForAllTyInvis ty2-    (provs, ty4) = splitLHsQualTy ty3---- | Decompose a sigma type (of the form @forall <tvs>. context => body@)--- into its constituent parts. Note that only /invisible/ @forall@s--- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s--- (i.e., @forall a ->@, with an arrow) are left untouched.------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsSigmaTyInvis :: LHsType pass-                     -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass)-splitLHsSigmaTyInvis ty-  | (tvs,  ty1) <- splitLHsForAllTyInvis ty-  , (ctxt, ty2) <- splitLHsQualTy ty1-  = (tvs, ctxt, ty2)---- | Decompose a type of the form @forall <tvs>. body@ into its constituent--- parts. Note that only /invisible/ @forall@s--- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s--- (i.e., @forall a ->@, with an arrow) are left untouched.------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass)-splitLHsForAllTyInvis lty@(L _ ty) =-  case ty of-    HsParTy _ ty' -> splitLHsForAllTyInvis ty'-    HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' }-      |  fvf' == ForallInvis-      -> (tvs', body')-    _ -> ([], lty)---- | Decompose a type of the form @context => body@ into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(context => <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)-splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty-splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt,     body)-splitLHsQualTy body              = (noLHsContext, body)---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(forall <tvs>. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsInstDeclTy :: LHsSigType GhcRn-                   -> ([Name], LHsContext GhcRn, LHsType GhcRn)--- Split up an instance decl type, returning the pieces-splitLHsInstDeclTy (HsIB { hsib_ext = itkvs-                         , hsib_body = inst_ty })-  | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty-  = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty)-         -- Return implicitly bound type and kind vars-         -- For an instance decl, all of them are in scope-splitLHsInstDeclTy (XHsImplicitBndrs nec) = noExtCon nec--getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)-getLHsInstDeclHead inst_ty-  | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty)-  = body_ty--getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)-                          -> Maybe (Located (IdP (GhcPass p)))--- Works on (HsSigType RdrName)-getLHsInstDeclClass_maybe inst_ty-  = do { let head_ty = getLHsInstDeclHead inst_ty-       ; cls <- hsTyGetAppHead_maybe head_ty-       ; return cls }--{--************************************************************************-*                                                                      *-                FieldOcc-*                                                                      *-************************************************************************--}---- | Located Field Occurrence-type LFieldOcc pass = Located (FieldOcc pass)---- | Field Occurrence------ Represents an *occurrence* of an unambiguous field.  We store--- both the 'RdrName' the user originally wrote, and after the--- renamer, the selector function.-data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass-                              , rdrNameFieldOcc :: Located RdrName-                                 -- ^ See Note [Located RdrNames] in GHC.Hs.Expr-                              }--  | XFieldOcc-      (XXFieldOcc pass)-deriving instance Eq  (XCFieldOcc (GhcPass p)) => Eq  (FieldOcc (GhcPass p))-deriving instance Ord (XCFieldOcc (GhcPass p)) => Ord (FieldOcc (GhcPass p))--type instance XCFieldOcc GhcPs = NoExtField-type instance XCFieldOcc GhcRn = Name-type instance XCFieldOcc GhcTc = Id--type instance XXFieldOcc (GhcPass _) = NoExtCon--instance Outputable (FieldOcc pass) where-  ppr = ppr . rdrNameFieldOcc--mkFieldOcc :: Located RdrName -> FieldOcc GhcPs-mkFieldOcc rdr = FieldOcc noExtField rdr----- | Ambiguous Field Occurrence------ Represents an *occurrence* of a field that is potentially--- ambiguous after the renamer, with the ambiguity resolved by the--- typechecker.  We always store the 'RdrName' that the user--- originally wrote, and store the selector function after the renamer--- (for unambiguous occurrences) or the typechecker (for ambiguous--- occurrences).------ See Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat and--- Note [Disambiguating record fields] in TcExpr.--- See Note [Located RdrNames] in GHC.Hs.Expr-data AmbiguousFieldOcc pass-  = Unambiguous (XUnambiguous pass) (Located RdrName)-  | Ambiguous   (XAmbiguous pass)   (Located RdrName)-  | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass)--type instance XUnambiguous GhcPs = NoExtField-type instance XUnambiguous GhcRn = Name-type instance XUnambiguous GhcTc = Id--type instance XAmbiguous GhcPs = NoExtField-type instance XAmbiguous GhcRn = NoExtField-type instance XAmbiguous GhcTc = Id--type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon--instance Outputable (AmbiguousFieldOcc (GhcPass p)) where-  ppr = ppr . rdrNameAmbiguousFieldOcc--instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where-  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc-  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc--mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr--rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc nec)-  = noExtCon nec--selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel-selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel-selectorAmbiguousFieldOcc (XAmbiguousFieldOcc nec)-  = noExtCon nec--unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel-unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel-unambiguousFieldOcc (XAmbiguousFieldOcc nec) = noExtCon nec--ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr-ambiguousFieldOcc (XFieldOcc nec) = noExtCon nec--{--************************************************************************-*                                                                      *-\subsection{Pretty printing}-*                                                                      *-************************************************************************--}--instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where-    ppr ty = pprHsType ty--instance Outputable HsTyLit where-    ppr = ppr_tylit--instance OutputableBndrId p-       => Outputable (LHsQTyVars (GhcPass p)) where-    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs-    ppr (XLHsQTyVars x) = ppr x--instance OutputableBndrId p-       => Outputable (HsTyVarBndr (GhcPass p)) where-    ppr (UserTyVar _ n)     = ppr n-    ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k]-    ppr (XTyVarBndr nec)    = noExtCon nec--instance Outputable thing-       => Outputable (HsImplicitBndrs (GhcPass p) thing) where-    ppr (HsIB { hsib_body = ty }) = ppr ty-    ppr (XHsImplicitBndrs x) = ppr x--instance Outputable thing-       => Outputable (HsWildCardBndrs (GhcPass p) thing) where-    ppr (HsWC { hswc_body = ty }) = ppr ty-    ppr (XHsWildCardBndrs x) = ppr x--pprAnonWildCard :: SDoc-pprAnonWildCard = char '_'---- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@--- only when @-dppr-debug@ is enabled.-pprHsForAll :: (OutputableBndrId p)-            => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)]-            -> LHsContext (GhcPass p) -> SDoc-pprHsForAll = pprHsForAllExtra Nothing---- | Version of 'pprHsForAll' that can also print an extra-constraints--- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This--- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just'--- containing the location of the extra-constraints wildcard. A special--- function for this is needed, as the extra-constraints wildcard is removed--- from the actual context and type, and stored in a separate field, thus just--- printing the type will not print the extra-constraints wildcard.-pprHsForAllExtra :: (OutputableBndrId p)-                 => Maybe SrcSpan -> ForallVisFlag-                 -> [LHsTyVarBndr (GhcPass p)]-                 -> LHsContext (GhcPass p) -> SDoc-pprHsForAllExtra extra fvf qtvs cxt-  = pp_forall <+> pprLHsContextExtra (isJust extra) cxt-  where-    pp_forall | null qtvs = whenPprDebug (forAllLit <> separator)-              | otherwise = forAllLit <+> interppSP qtvs <> separator--    separator = ppr_forall_separator fvf---- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print--- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'-pprHsExplicitForAll :: (OutputableBndrId p)-                    => ForallVisFlag-                    -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc-pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs-                                                 <> ppr_forall_separator fvf-pprHsExplicitForAll _   Nothing     = empty---- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for--- invisible @forall@s (e.g., @forall a.@).-ppr_forall_separator :: ForallVisFlag -> SDoc-ppr_forall_separator ForallVis   = space <> arrow-ppr_forall_separator ForallInvis = dot--pprLHsContext :: (OutputableBndrId p)-              => LHsContext (GhcPass p) -> SDoc-pprLHsContext lctxt-  | null (unLoc lctxt) = empty-  | otherwise          = pprLHsContextAlways lctxt---- For use in a HsQualTy, which always gets printed if it exists.-pprLHsContextAlways :: (OutputableBndrId p)-                    => LHsContext (GhcPass p) -> SDoc-pprLHsContextAlways (L _ ctxt)-  = case ctxt of-      []       -> parens empty             <+> darrow-      [L _ ty] -> ppr_mono_ty ty           <+> darrow-      _        -> parens (interpp'SP ctxt) <+> darrow---- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@-pprLHsContextExtra :: (OutputableBndrId p)-                   => Bool -> LHsContext (GhcPass p) -> SDoc-pprLHsContextExtra show_extra lctxt@(L _ ctxt)-  | not show_extra = pprLHsContext lctxt-  | null ctxt      = char '_' <+> darrow-  | otherwise      = parens (sep (punctuate comma ctxt')) <+> darrow-  where-    ctxt' = map ppr ctxt ++ [char '_']--pprConDeclFields :: (OutputableBndrId p)-                 => [LConDeclField (GhcPass p)] -> SDoc-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))-  where-    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,-                                 cd_fld_doc = doc }))-        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc-    ppr_fld (L _ (XConDeclField x)) = ppr x-    ppr_names [n] = ppr n-    ppr_names ns = sep (punctuate comma (map ppr ns))--{--Note [Printing KindedTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#3830 reminded me that we should really only print the kind-signature on a KindedTyVar if the kind signature was put there by the-programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,-rather than converting to KindedTyVars as before.--(As it happens, the message in #3830 comes out a different way now,-and the problem doesn't show up; but having the flag on a KindedTyVar-seems like the Right Thing anyway.)--}---- Printing works more-or-less as for Types--pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-pprHsType ty = ppr_mono_ty ty--ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc-ppr_mono_lty ty = ppr_mono_ty (unLoc ty)--ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty })-  = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty]--ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })-  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]--ppr_mono_ty (HsBangTy _ b ty)   = ppr b <> ppr_mono_lty ty-ppr_mono_ty (HsRecTy _ flds)      = pprConDeclFields flds-ppr_mono_ty (HsTyVar _ prom (L _ name))-  | isPromoted prom = quote (pprPrefixOcc name)-  | otherwise       = pprPrefixOcc name-ppr_mono_ty (HsFunTy _ ty1 ty2)   = ppr_fun_ty ty1 ty2-ppr_mono_ty (HsTupleTy _ con tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Unit x`, not `(x)`-  | [ty] <- tys-  , BoxedTuple <- std_con-  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = tupleParens std_con (pprWithCommas ppr tys)-  where std_con = case con of-                    HsUnboxedTuple -> UnboxedTuple-                    _              -> BoxedTuple-ppr_mono_ty (HsSumTy _ tys)-  = tupleParens UnboxedTuple (pprWithBars ppr tys)-ppr_mono_ty (HsKindSig _ ty kind)-  = ppr_mono_lty ty <+> dcolon <+> ppr kind-ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)-ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)-ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s-ppr_mono_ty (HsExplicitListTy _ prom tys)-  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)-  | otherwise       = brackets (interpp'SP tys)-ppr_mono_ty (HsExplicitTupleTy _ tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `'Unit x`, not `'(x)`-  | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)-ppr_mono_ty (HsTyLit _ t)       = ppr_tylit t-ppr_mono_ty (HsWildCardTy {})   = char '_'--ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')--ppr_mono_ty (HsAppTy _ fun_ty arg_ty)-  = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]-ppr_mono_ty (HsAppKindTy _ ty k)-  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k-ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)-  = sep [ ppr_mono_lty ty1-        , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]--ppr_mono_ty (HsParTy _ ty)-  = parens (ppr_mono_lty ty)-  -- Put the parens in where the user did-  -- But we still use the precedence stuff to add parens because-  --    toHsType doesn't put in any HsParTys, so we may still need them--ppr_mono_ty (HsDocTy _ ty doc)-  -- AZ: Should we add parens?  Should we introduce "-- ^"?-  = ppr_mono_lty ty <+> ppr (unLoc doc)-  -- we pretty print Haddock comments on types as if they were-  -- postfix operators--ppr_mono_ty (XHsType t) = ppr t-----------------------------ppr_fun_ty :: (OutputableBndrId p)-           => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc-ppr_fun_ty ty1 ty2-  = let p1 = ppr_mono_lty ty1-        p2 = ppr_mono_lty ty2-    in-    sep [p1, arrow <+> p2]-----------------------------ppr_tylit :: HsTyLit -> SDoc-ppr_tylit (HsNumTy _ i) = integer i-ppr_tylit (HsStrTy _ s) = text (show s)----- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses--- under precedence @p@.-hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool-hsTypeNeedsParens p = go-  where-    go (HsForAllTy{})        = p >= funPrec-    go (HsQualTy{})          = p >= funPrec-    go (HsBangTy{})          = p > topPrec-    go (HsRecTy{})           = False-    go (HsTyVar{})           = False-    go (HsFunTy{})           = p >= funPrec-    go (HsTupleTy{})         = False-    go (HsSumTy{})           = False-    go (HsKindSig{})         = p >= sigPrec-    go (HsListTy{})          = False-    go (HsIParamTy{})        = p > topPrec-    go (HsSpliceTy{})        = False-    go (HsExplicitListTy{})  = False-    go (HsExplicitTupleTy{}) = False-    go (HsTyLit{})           = False-    go (HsWildCardTy{})      = False-    go (HsStarTy{})          = False-    go (HsAppTy{})           = p >= appPrec-    go (HsAppKindTy{})       = p >= appPrec-    go (HsOpTy{})            = p >= opPrec-    go (HsParTy{})           = False-    go (HsDocTy _ (L _ t) _) = go t-    go (XHsType{})           = False--maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc--- See Note [Printing promoted type constructors]--- in IfaceType.  This code implements the same--- logic for printing HsType-maybeAddSpace tys doc-  | (ty : _) <- tys-  , lhsTypeHasLeadingPromotionQuote ty = space <> doc-  | otherwise                          = doc--lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool-lhsTypeHasLeadingPromotionQuote ty-  = goL ty-  where-    goL (L _ ty) = go ty--    go (HsForAllTy{})        = False-    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})-      | L _ (c:_) <- ctxt    = goL c-      | otherwise            = goL body-    go (HsBangTy{})          = False-    go (HsRecTy{})           = False-    go (HsTyVar _ p _)       = isPromoted p-    go (HsFunTy _ arg _)     = goL arg-    go (HsListTy{})          = False-    go (HsTupleTy{})         = False-    go (HsSumTy{})           = False-    go (HsOpTy _ t1 _ _)     = goL t1-    go (HsKindSig _ t _)     = goL t-    go (HsIParamTy{})        = False-    go (HsSpliceTy{})        = False-    go (HsExplicitListTy _ p _) = isPromoted p-    go (HsExplicitTupleTy{}) = True-    go (HsTyLit{})           = False-    go (HsWildCardTy{})      = False-    go (HsStarTy{})          = False-    go (HsAppTy _ t _)       = goL t-    go (HsAppKindTy _ t _)   = goL t-    go (HsParTy{})           = False-    go (HsDocTy _ t _)       = goL t-    go (XHsType{})           = False---- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is--- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply--- returns @ty@.-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)-parenthesizeHsType p lty@(L loc ty)-  | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty)-  | otherwise              = lty---- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint--- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@--- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply--- returns @ctxt@ unchanged.-parenthesizeHsContext :: PprPrec-                      -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)-parenthesizeHsContext p lctxt@(L loc ctxt) =-  case ctxt of-    [c] -> L loc [parenthesizeHsType p c]-    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of-                 -- being tuples.
GHC/Hs/Utils.hs view
@@ -1,1428 +1,1882 @@-{-|-Module      : GHC.Hs.Utils-Description : Generic helpers for the HsSyn type.-Copyright   : (c) The University of Glasgow, 1992-2006--Here we collect a variety of helper functions that construct or-analyse HsSyn.  All these functions deal with generic HsSyn; functions-which deal with the instantiated versions are located elsewhere:--   Parameterised by          Module-   ----------------          --------------   GhcPs/RdrName             parser/RdrHsSyn-   GhcRn/Name                rename/RnHsSyn-   GhcTc/Id                  typecheck/TcHsSyn--The @mk*@ functions attempt to construct a not-completely-useless SrcSpan-from their components, compared with the @nl*@ functions which-just attach noSrcSpan to everything.---}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--module GHC.Hs.Utils(-  -- * Terms-  mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,-  mkSimpleMatch, unguardedGRHSs, unguardedRHS,-  mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,-  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,-  mkHsDictLet, mkHsLams,-  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,-  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,-  mkHsCmdIf,--  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,-  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,-  nlHsIntLit, nlHsVarApps,-  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,-  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,-  typeToLHsType,--  -- * Constructing general big tuples-  -- $big_tuples-  mkChunkified, chunkify,--  -- * Bindings-  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,-  mkPatSynBind,-  isInfixFunBind,--  -- * Literals-  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,--  -- * Patterns-  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,-  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,-  nlWildPatName, nlTuplePat, mkParPat, nlParPat,-  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,--  -- * Types-  mkHsAppTy, mkHsAppKindTy,-  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,-  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,--  -- * Stmts-  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,-  mkLastStmt,-  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,-  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,-  unitRecStmtTc,--  -- * Template Haskell-  mkUntypedSplice, mkTypedSplice,-  mkHsQuasiQuote, unqualQuasiQuote,--  -- * Collecting binders-  isUnliftedHsBind, isBangedHsBind,--  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,-  collectHsIdBinders,-  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,-  collectPatBinders, collectPatsBinders,-  collectLStmtsBinders, collectStmtsBinders,-  collectLStmtBinders, collectStmtBinders,--  hsLTyClDeclBinders, hsTyClForeignBinders,-  hsPatSynSelectors, getPatSynBinds,-  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,--  -- * Collecting implicit binders-  lStmtsImplicits, hsValBindsImplicits, lPatImplicits-  ) where--#include "HsVersions.h"--import GhcPrelude--import GHC.Hs.Decls-import GHC.Hs.Binds-import GHC.Hs.Expr-import GHC.Hs.Pat-import GHC.Hs.Types-import GHC.Hs.Lit-import GHC.Hs.PlaceHolder-import GHC.Hs.Extension--import TcEvidence-import RdrName-import Var-import TyCoRep-import Type   ( appTyArgFlags, splitAppTys, tyConArgFlags, tyConAppNeedsKindSig )-import TysWiredIn ( unitTy )-import TcType-import DataCon-import ConLike-import Id-import Name-import NameSet hiding ( unitFV )-import NameEnv-import BasicTypes-import SrcLoc-import FastString-import Util-import Bag-import Outputable-import Constants--import Data.Either-import Data.Function-import Data.List--{--************************************************************************-*                                                                      *-        Some useful helpers for constructing syntax-*                                                                      *-************************************************************************--These functions attempt to construct a not-completely-useless 'SrcSpan'-from their components, compared with the @nl*@ functions below which-just attach 'noSrcSpan' to everything.--}---- | e => (e)-mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsPar e = cL (getLoc e) (HsPar noExtField e)--mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))-              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))-              -> LMatch (GhcPass p) (Located (body (GhcPass p)))-mkSimpleMatch ctxt pats rhs-  = cL loc $-    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats-          , m_grhss = unguardedGRHSs rhs }-  where-    loc = case pats of-                []      -> getLoc rhs-                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)--unguardedGRHSs :: Located (body (GhcPass p))-               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))-unguardedGRHSs rhs@(dL->L loc _)-  = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds)--unguardedRHS :: SrcSpan -> Located (body (GhcPass p))-             -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]-unguardedRHS loc rhs = [cL loc (GRHS noExtField [] rhs)]--mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)-             => Origin -> [LMatch name (Located (body name))]-             -> MatchGroup name (Located (body name))-mkMatchGroup origin matches = MG { mg_ext = noExtField-                                 , mg_alts = mkLocatedList matches-                                 , mg_origin = origin }--mkLocatedList ::  [Located a] -> Located [Located a]-mkLocatedList [] = noLoc []-mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms--mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExtField e1 e2)--mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)-            => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)-mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)-  where-    t_body    = hswc_body t-    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }--mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn-mkHsAppTypes = foldl' mkHsAppType--mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>-  [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExtField matches))-  where-    matches = mkMatchGroup Generated-                           [mkSimpleMatch LambdaExpr pats' body]-    pats' = map (parenthesizePat appPrec) pats--mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc-mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars-                                       <.> mkWpLams dicts) expr---- |A simple case alternative with a single pattern, no binds, no guards;--- pre-typechecking-mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))-            -> LMatch (GhcPass p) (Located (body (GhcPass p)))-mkHsCaseAlt pat expr-  = mkSimpleMatch CaseAlt [pat] expr--nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)-nlHsTyApp fun_id tys-  = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id)))--nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]-           -> LHsExpr (GhcPass id)-nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs----------- Adding parens ------------ | Wrap in parens if (hsExprNeedsParens appPrec) says it needs them--- So   'f x'  becomes '(f x)', but '3' stays as '3'-mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkLHsPar le@(dL->L loc e)-  | hsExprNeedsParens appPrec e = cL loc (HsPar noExtField le)-  | otherwise                   = le--mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)-mkParPat lp@(dL->L loc p)-  | patNeedsParens appPrec p = cL loc (ParPat noExtField lp)-  | otherwise                = lp--nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)-nlParPat p = noLoc (ParPat noExtField p)------------------------------------ These are the bits of syntax that contain rebindable names--- See RnEnv.lookupSyntaxName--mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs-mkHsFractional :: FractionalLit -> HsOverLit GhcPs-mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs-mkHsDo         :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs-mkHsComp       :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-               -> HsExpr GhcPs--mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)-            -> Pat GhcPs-mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs--mkLastStmt :: Located (bodyR (GhcPass idR))-           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))-mkBodyStmt :: Located (bodyR GhcPs)-           -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))-mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)-                         (Located (bodyR (GhcPass idR))) ~ NoExtField)-           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))-           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))-mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)-             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))--emptyRecStmt     :: StmtLR (GhcPass idL) GhcPs bodyR-emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR-emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR-mkRecStmt        :: [LStmtLR (GhcPass idL) GhcPs bodyR]-                 -> StmtLR (GhcPass idL) GhcPs bodyR---mkHsIntegral     i  = OverLit noExtField (HsIntegral       i) noExpr-mkHsFractional   f  = OverLit noExtField (HsFractional     f) noExpr-mkHsIsString src s  = OverLit noExtField (HsIsString   src s) noExpr--mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts)-mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])-  where-    last_stmt = cL (getLoc expr) $ mkLastStmt expr--mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-       -> HsExpr (GhcPass p)-mkHsIf c a b = HsIf noExtField (Just noSyntaxExpr) c a b--mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)-       -> HsCmd (GhcPass p)-mkHsCmdIf c a b = HsCmdIf noExtField (Just noSyntaxExpr) c a b--mkNPat lit neg     = NPat noExtField lit neg noSyntaxExpr-mkNPlusKPat id lit-  = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr--mkTransformStmt    :: [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkTransformByStmt  :: [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupUsingStmt   :: [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)--emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)-emptyTransStmt = TransStmt { trS_ext = noExtField-                           , trS_form = panic "emptyTransStmt: form"-                           , trS_stmts = [], trS_bndrs = []-                           , trS_by = Nothing, trS_using = noLoc noExpr-                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr-                           , trS_fmap = noExpr }-mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }-mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }-mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }-mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }--mkLastStmt body = LastStmt noExtField body False noSyntaxExpr-mkBodyStmt body-  = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr-mkBindStmt pat body-  = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr-mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr-  -- don't use placeHolderTypeTc above, because that panics during zonking--emptyRecStmt' :: forall idL idR body.-                 XRecStmt (GhcPass idL) (GhcPass idR) body-              -> StmtLR (GhcPass idL) (GhcPass idR) body-emptyRecStmt' tyVal =-   RecStmt-     { recS_stmts = [], recS_later_ids = []-     , recS_rec_ids = []-     , recS_ret_fn = noSyntaxExpr-     , recS_mfix_fn = noSyntaxExpr-     , recS_bind_fn = noSyntaxExpr-     , recS_ext = tyVal }--unitRecStmtTc :: RecStmtTc-unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy-                          , recS_later_rets = []-                          , recS_rec_rets = []-                          , recS_ret_ty = unitTy }--emptyRecStmt     = emptyRecStmt' noExtField-emptyRecStmtName = emptyRecStmt' noExtField-emptyRecStmtId   = emptyRecStmt' unitRecStmtTc-                                        -- a panic might trigger during zonking-mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }------------------------------------ | A useful function for building @OpApps@.  The operator is always a--- variable, and we don't know the fixity yet.-mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs-mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2--unqualSplice :: RdrName-unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))--mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e--mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e--mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs-mkHsQuasiQuote quoter span quote-  = HsQuasiQuote noExtField unqualSplice quoter span quote--unqualQuasiQuote :: RdrName-unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))-                -- A name (uniquified later) to-                -- identify the quasi-quote--mkHsString :: String -> HsLit (GhcPass p)-mkHsString s = HsString NoSourceText (mkFastString s)--mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)-mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)---{--************************************************************************-*                                                                      *-        Constructing syntax with no location info-*                                                                      *-************************************************************************--}--nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)-nlHsVar n = noLoc (HsVar noExtField (noLoc n))---- | NB: Only for LHsExpr **Id**-nlHsDataCon :: DataCon -> LHsExpr GhcTc-nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con))--nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)-nlHsLit n = noLoc (HsLit noExtField n)--nlHsIntLit :: Integer -> LHsExpr (GhcPass p)-nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))--nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)-nlVarPat n = noLoc (VarPat noExtField (noLoc n))--nlLitPat :: HsLit GhcPs -> LPat GhcPs-nlLitPat l = noLoc (LitPat noExtField l)--nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x))--nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]-               -> LHsExpr (GhcPass id)-nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun-                           , syn_arg_wraps = arg_wraps-                           , syn_res_wrap  = res_wrap }) args-  | [] <- arg_wraps   -- in the noSyntaxExpr case-  = ASSERT( isIdHsWrapper res_wrap )-    foldl' nlHsApp (noLoc fun) args--  | otherwise-  = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"-                                                     mkLHsWrap arg_wraps args))--nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs--nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)-nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f))-                                               (map ((HsVar noExtField) . noLoc) xs))-                 where-                   mk f a = HsApp noExtField (noLoc f) (noLoc a)--nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs-nlConVarPat con vars = nlConPat con (map nlVarPat vars)--nlConVarPatName :: Name -> [Name] -> LPat GhcRn-nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)--nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs-nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)-                              (InfixCon (parenthesizePat opPrec l)-                                        (parenthesizePat opPrec r)))--nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs-nlConPat con pats =-  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))--nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn-nlConPatName con pats =-  noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))--nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)-nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))--nlWildConPat :: DataCon -> LPat GhcPs-nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))-                         (PrefixCon (replicate (dataConSourceArity con)-                                             nlWildPat)))---- | Wildcard pattern - after parsing-nlWildPat :: LPat GhcPs-nlWildPat  = noLoc (WildPat noExtField )---- | Wildcard pattern - after renaming-nlWildPatName :: LPat GhcRn-nlWildPatName  = noLoc (WildPat noExtField )--nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]-       -> LHsExpr GhcPs-nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)--nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)--nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs-nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsIf   :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-         -> LHsExpr (GhcPass id)-nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]-         -> LHsExpr GhcPs-nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs--nlHsLam match          = noLoc (HsLam noExtField (mkMatchGroup Generated [match]))-nlHsPar e              = noLoc (HsPar noExtField e)---- | Note [Rebindable nlHsIf]--- nlHsIf should generate if-expressions which are NOT subject to--- RebindableSyntax, so the first field of HsIf is Nothing. (#12080)-nlHsIf cond true false = noLoc (HsIf noExtField Nothing cond true false)--nlHsCase expr matches-  = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))-nlList exprs          = noLoc (ExplicitList noExtField Nothing exprs)--nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)-nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)--nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t))-nlHsTyVar x   = noLoc (HsTyVar noExtField NotPromoted (noLoc x))-nlHsFunTy a b = noLoc (HsFunTy noExtField (parenthesizeHsType funPrec a) b)-nlHsParTy t   = noLoc (HsParTy noExtField t)--nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)-nlHsTyConApp tycon tys  = foldl' nlHsAppTy (nlHsTyVar tycon) tys--nlHsAppKindTy ::-  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)-nlHsAppKindTy f k-  = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))--{--Tuples.  All these functions are *pre-typechecker* because they lack-types on the tuple.--}--mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)--- Makes a pre-typechecker boxed tuple, deals with 1 case-mkLHsTupleExpr [e] = e-mkLHsTupleExpr es-  = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed--mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)-mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)--nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs-nlTuplePat pats box = noLoc (TuplePat noExtField pats box)--missingTupArg :: HsTupArg GhcPs-missingTupArg = Missing noExtField--mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn-mkLHsPatTup []     = noLoc $ TuplePat noExtField [] Boxed-mkLHsPatTup [lpat] = lpat-mkLHsPatTup lpats  = cL (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed---- | The Big equivalents for the source tuple expressions-mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)-mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)--mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkBigLHsTup = mkChunkified mkLHsTupleExpr---- | The Big equivalents for the source tuple patterns-mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn-mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)--mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn-mkBigLHsPatTup = mkChunkified mkLHsPatTup---- $big_tuples--- #big_tuples#------ GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but--- we might concievably want to build such a massive tuple as part of the--- output of a desugaring stage (notably that for list comprehensions).------ We call tuples above this size \"big tuples\", and emulate them by--- creating and pattern matching on >nested< tuples that are expressible--- by GHC.------ Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects)--- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any--- construction to be big.------ If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector'--- and 'mkTupleCase' functions to do all your work with tuples you should be--- fine, and not have to worry about the arity limitation at all.---- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon-mkChunkified :: ([a] -> a)      -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE'-             -> [a]             -- ^ Possible \"big\" list of things to construct from-             -> a               -- ^ Constructed thing made possible by recursive decomposition-mkChunkified small_tuple as = mk_big_tuple (chunkify as)-  where-        -- Each sub-list is short enough to fit in a tuple-    mk_big_tuple [as] = small_tuple as-    mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))--chunkify :: [a] -> [[a]]--- ^ Split a list into lists that are small enough to have a corresponding--- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE'--- But there may be more than 'mAX_TUPLE_SIZE' sub-lists-chunkify xs-  | n_xs <= mAX_TUPLE_SIZE = [xs]-  | otherwise              = split xs-  where-    n_xs     = length xs-    split [] = []-    split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)--{--************************************************************************-*                                                                      *-        LHsSigType and LHsSigWcType-*                                                                      *-********************************************************************* -}--mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs-mkLHsSigType ty = mkHsImplicitBndrs ty--mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs-mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)--mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))-                     -> [LSig GhcRn]-                     -> NameEnv a-mkHsSigEnv get_info sigs-  = mkNameEnv          (mk_pairs ordinary_sigs)-   `extendNameEnvList` (mk_pairs gen_dm_sigs)-   -- The subtlety is this: in a class decl with a-   -- default-method signature as well as a method signature-   -- we want the latter to win (#12533)-   --    class C x where-   --       op :: forall a . x a -> x a-   --       default op :: forall b . x b -> x b-   --       op x = ...(e :: b -> b)...-   -- The scoped type variables of the 'default op', namely 'b',-   -- scope over the code for op.   The 'forall a' does not!-   -- This applies both in the renamer and typechecker, both-   -- of which use this function-  where-    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs-    is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True-    is_gen_dm_sig _                                 = False--    mk_pairs :: [LSig GhcRn] -> [(Name, a)]-    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs-                            , (dL->L _ n) <- ns ]--mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]--- ^ Convert TypeSig to ClassOpSig--- The former is what is parsed, but the latter is--- what we need in class/instance declarations-mkClassOpSigs sigs-  = map fiddle sigs-  where-    fiddle (dL->L loc (TypeSig _ nms ty))-      = cL loc (ClassOpSig noExtField False nms (dropWildCards ty))-    fiddle sig = sig--typeToLHsType :: Type -> LHsType GhcPs--- ^ Converting a Type to an HsType RdrName--- This is needed to implement GeneralizedNewtypeDeriving.------ Note that we use 'getRdrName' extensively, which--- generates Exact RdrNames rather than strings.-typeToLHsType ty-  = go ty-  where-    go :: Type -> LHsType GhcPs-    go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res })-      = case af of-          VisArg   -> nlHsFunTy (go arg) (go res)-          InvisArg | (theta, tau) <- tcSplitPhiTy ty-                   -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)-                                      , hst_xqual = noExtField-                                      , hst_body = go tau })--    go ty@(ForAllTy (Bndr _ argf) _)-      | (tvs, tau) <- tcSplitForAllTysSameVis argf ty-      = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf-                          , hst_bndrs = map go_tv tvs-                          , hst_xforall = noExtField-                          , hst_body = go tau })-    go (TyVarTy tv)         = nlHsTyVar (getRdrName tv)-    go (LitTy (NumTyLit n))-      = noLoc $ HsTyLit noExtField (HsNumTy NoSourceText n)-    go (LitTy (StrTyLit s))-      = noLoc $ HsTyLit noExtField (HsStrTy NoSourceText s)-    go ty@(TyConApp tc args)-      | tyConAppNeedsKindSig True tc (length args)-        -- We must produce an explicit kind signature here to make certain-        -- programs kind-check. See Note [Kind signatures in typeToLHsType].-      = nlHsParTy $ noLoc $ HsKindSig noExtField ty' (go (tcTypeKind ty))-      | otherwise = ty'-       where-        ty' :: LHsType GhcPs-        ty' = go_app (nlHsTyVar (getRdrName tc)) args (tyConArgFlags tc args)-    go ty@(AppTy {})        = go_app (go head) args (appTyArgFlags head args)-      where-        head :: Type-        args :: [Type]-        (head, args) = splitAppTys ty-    go (CastTy ty _)        = go ty-    go (CoercionTy co)      = pprPanic "toLHsSigWcType" (ppr co)--         -- Source-language types have _invisible_ kind arguments,-         -- so we must remove them here (#8563)--    go_app :: LHsType GhcPs -- The type being applied-           -> [Type]        -- The argument types-           -> [ArgFlag]     -- The argument types' visibilities-           -> LHsType GhcPs-    go_app head args arg_flags =-      foldl' (\f (arg, flag) ->-               let arg' = go arg in-               case flag of-                 Inferred  -> f-                 Specified -> f `nlHsAppKindTy` arg'-                 Required  -> f `nlHsAppTy`     arg')-             head (zip args arg_flags)--    go_tv :: TyVar -> LHsTyVarBndr GhcPs-    go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv))-                                   (go (tyVarKind tv))--{--Note [Kind signatures in typeToLHsType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are types that typeToLHsType can produce which require explicit kind-signatures in order to kind-check. Here is an example from #14579:--  -- type P :: forall {k} {t :: k}. Proxy t-  type P = 'Proxy--  -- type Wat :: forall a. Proxy a -> *-  newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a)-    deriving Eq--  -- type Wat2 :: forall {a}. Proxy a -> *-  type Wat2 = Wat--  -- type Glurp :: * -> *-  newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a))-    deriving Eq--The derived Eq instance for Glurp (without any kind signatures) would be:--  instance Eq a => Eq (Glurp a) where-    (==) = coerce @(Wat2 P  -> Wat2 P  -> Bool)-                  @(Glurp a -> Glurp a -> Bool)-                  (==) :: Glurp a -> Glurp a -> Bool--(Where the visible type applications use types produced by typeToLHsType.)--The type P (in Wat2 P) has an underspecified kind, so we must ensure that-typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish-this, whenever we see an application of a tycon to some arguments, we use-the tyConAppNeedsKindSig function to determine if it requires an explicit kind-signature to resolve some ambiguity. (See Note-Note [When does a tycon application need an explicit kind signature?] for a-more detailed explanation of how this works.)--Note that we pass True to tyConAppNeedsKindSig since we are generated code with-visible kind applications, so even specified arguments count towards injective-positions in the kind of the tycon.--}--{- *********************************************************************-*                                                                      *-    --------- HsWrappers: type args, dict args, casts ----------*                                                                      *-********************************************************************* -}--mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)---- | Avoid (HsWrap co (HsWrap co' _)).--- See Note [Detecting forced eta expansion] in DsExpr-mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)-mkHsWrap co_fn e | isIdHsWrapper co_fn = e-mkHsWrap co_fn (HsWrap _ co_fn' e)     = mkHsWrap (co_fn <.> co_fn') e-mkHsWrap co_fn e                       = HsWrap noExtField co_fn e--mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b-           -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)-mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e--mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b-            -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)-mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e--mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)--mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)-mkHsCmdWrap w cmd | isIdHsWrapper w = cmd-                  | otherwise       = HsCmdWrap noExtField w cmd--mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)-mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)--mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)-mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p-                       | otherwise           = CoPat noExtField co_fn p ty--mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)-mkHsWrapPatCo co pat ty | isTcReflCo co = pat-                        | otherwise    = CoPat noExtField (mkWpCastN co) pat ty--mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc-mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr--{--l-************************************************************************-*                                                                      *-                Bindings; with a location at the top-*                                                                      *-************************************************************************--}--mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]-          -> HsBind GhcPs--- ^ Not infix, with place holders for coercion and free vars-mkFunBind origin fn ms-  = FunBind { fun_id = fn-            , fun_matches = mkMatchGroup origin ms-            , fun_co_fn = idHsWrapper-            , fun_ext = noExtField-            , fun_tick = [] }--mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]-             -> HsBind GhcRn--- ^ In Name-land, with empty bind_fvs-mkTopFunBind origin fn ms = FunBind { fun_id = fn-                                    , fun_matches = mkMatchGroup origin ms-                                    , fun_co_fn = idHsWrapper-                                    , fun_ext  = emptyNameSet -- NB: closed-                                                              --     binding-                                    , fun_tick = [] }--mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs-mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs--mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)-mkVarBind var rhs = cL (getLoc rhs) $-                    VarBind { var_ext = noExtField,-                              var_id = var, var_rhs = rhs, var_inline = False }--mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)-             -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs-mkPatSynBind name details lpat dir = PatSynBind noExtField psb-  where-    psb = PSB{ psb_ext = noExtField-             , psb_id = name-             , psb_args = details-             , psb_def = lpat-             , psb_dir = dir }---- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is--- considered infix.-isInfixFunBind :: HsBindLR id1 id2 -> Bool-isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)-  = any (isInfixMatch . unLoc) (unLoc matches)-isInfixFunBind _ = False------------------ | Convenience function using 'mkFunBind'.--- This is for generated bindings only, do not use for user-written code.-mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]-                -> LHsExpr GhcPs -> LHsBind GhcPs-mkSimpleGeneratedFunBind loc fun pats expr-  = cL loc $ mkFunBind Generated (cL loc fun)-              [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr-                       (noLoc emptyLocalBinds)]---- | Make a prefix, non-strict function 'HsMatchContext'-mkPrefixFunRhs :: Located id -> HsMatchContext id-mkPrefixFunRhs n = FunRhs { mc_fun = n-                          , mc_fixity = Prefix-                          , mc_strictness = NoSrcStrict }---------------mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))-        -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)-        -> Located (HsLocalBinds (GhcPass p))-        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))-mkMatch ctxt pats expr lbinds-  = noLoc (Match { m_ext   = noExtField-                 , m_ctxt  = ctxt-                 , m_pats  = map paren pats-                 , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })-  where-    paren lp@(dL->L l p)-      | patNeedsParens appPrec p = cL l (ParPat noExtField lp)-      | otherwise                = lp--{--************************************************************************-*                                                                      *-        Collecting binders-*                                                                      *-************************************************************************--Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.--...-where-  (x, y) = ...-  f i j  = ...-  [a, b] = ...--it should return [x, y, f, a, b] (remember, order important).--Note [Collect binders only after renaming]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These functions should only be used on HsSyn *after* the renamer,-to return a [Name] or [Id].  Before renaming the record punning-and wild-card mechanism makes it hard to know what is bound.-So these functions should not be applied to (HsSyn RdrName)--Note [Unlifted id check in isUnliftedHsBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function isUnliftedHsBind is used to complain if we make a top-level-binding for a variable of unlifted type.--Such a binding is illegal if the top-level binding would be unlifted;-but also if the local letrec generated by desugaring AbsBinds would be.-E.g.-      f :: Num a => (# a, a #)-      g :: Num a => a -> a-      f = ...g...-      g = ...g...--The top-level bindings for f,g are not unlifted (because of the Num a =>),-but the local, recursive, monomorphic bindings are:--      t = /\a \(d:Num a).-         letrec fm :: (# a, a #) = ...g...-                gm :: a -> a = ...f...-         in (fm, gm)--Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.--BUT we have a special case when abs_sig is true;-  see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds--}------------------- Bindings ------------------------------ | Should we treat this as an unlifted bind? This will be true for any--- bind that binds an unlifted variable, but we must be careful around--- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage--- information, see Note [Strict binds check] is DsBinds.-isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds-isUnliftedHsBind bind-  | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind-  = if has_sig-    then any (is_unlifted_id . abe_poly) exports-    else any (is_unlifted_id . abe_mono) exports-    -- If has_sig is True we wil never generate a binding for abe_mono,-    -- so we don't need to worry about it being unlifted. The abe_poly-    -- binding might not be: e.g. forall a. Num a => (# a, a #)--  | otherwise-  = any is_unlifted_id (collectHsBindBinders bind)-  where-    is_unlifted_id id = isUnliftedType (idType id)---- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?-isBangedHsBind :: HsBind GhcTc -> Bool-isBangedHsBind (AbsBinds { abs_binds = binds })-  = anyBag (isBangedHsBind . unLoc) binds-isBangedHsBind (FunBind {fun_matches = matches})-  | [dL->L _ match] <- unLoc $ mg_alts matches-  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match-  = True-isBangedHsBind (PatBind {pat_lhs = pat})-  = isBangedLPat pat-isBangedHsBind _-  = False--collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)-                    -> [IdP (GhcPass idL)]-collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds-                                         -- No pattern synonyms here-collectLocalBinders (HsIPBinds {})      = []-collectLocalBinders (EmptyLocalBinds _) = []-collectLocalBinders (XHsLocalBindsLR _) = []--collectHsIdBinders, collectHsValBinders-  :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]--- ^ Collect Id binders only, or Ids + pattern synonyms, respectively-collectHsIdBinders  = collect_hs_val_binders True-collectHsValBinders = collect_hs_val_binders False--collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>-                        HsBindLR p idR -> [IdP p]--- ^ Collect both Ids and pattern-synonym binders-collectHsBindBinders b = collect_bind False b []--collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]-collectHsBindsBinders binds = collect_binds False binds []--collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]--- ^ Same as collectHsBindsBinders, but works over a list of bindings-collectHsBindListBinders = foldr (collect_bind False . unLoc) []--collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)-                       -> [IdP (GhcPass idL)]-collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []-collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))-  = collect_out_binds ps binds--collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->-                     [IdP (GhcPass p)]-collect_out_binds ps = foldr (collect_binds ps . snd) []--collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->-                 [IdP (GhcPass p)] -> [IdP (GhcPass p)]--- ^ Collect Ids, or Ids + pattern synonyms, depending on boolean flag-collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds--collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>-                Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]-collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc-collect_bind _ (FunBind { fun_id = (dL->L _ f) })  acc = f : acc-collect_bind _ (VarBind { var_id = f })            acc = f : acc-collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc-        -- I don't think we want the binders from the abe_binds--        -- binding (hence see AbsBinds) is in zonking in TcHsSyn-collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc-  | omitPatSyn                  = acc-  | otherwise                   = ps : acc-collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc-collect_bind _ (XHsBindsLR _) acc = acc--collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]--- ^ Used exclusively for the bindings of an instance decl which are all FunBinds-collectMethodBinders binds = foldr (get . unLoc) [] binds-  where-    get (FunBind { fun_id = f }) fs = f : fs-    get _                        fs = fs-       -- Someone else complains about non-FunBinds------------------- Statements ---------------------------collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]-                     -> [IdP (GhcPass idL)]-collectLStmtsBinders = concatMap collectLStmtBinders--collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]-                    -> [IdP (GhcPass idL)]-collectStmtsBinders = concatMap collectStmtBinders--collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body-                    -> [IdP (GhcPass idL)]-collectLStmtBinders = collectStmtBinders . unLoc--collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body-                   -> [IdP (GhcPass idL)]-  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?-collectStmtBinders (BindStmt _ pat _ _ _)  = collectPatBinders pat-collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)-collectStmtBinders (BodyStmt {})           = []-collectStmtBinders (LastStmt {})           = []-collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders-                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]-collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts-collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss-collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args- where-  collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat-  collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat-  collectArgBinders _ = []-collectStmtBinders (XStmtLR nec) = noExtCon nec-------------------- Patterns ---------------------------collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]-collectPatBinders pat = collect_lpat pat []--collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]-collectPatsBinders pats = foldr collect_lpat [] pats----------------collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>-                 LPat p -> [IdP p] -> [IdP p]-collect_lpat p bndrs-  = go (unLoc p)-  where-    go (VarPat _ var)             = unLoc var : bndrs-    go (WildPat _)                = bndrs-    go (LazyPat _ pat)            = collect_lpat pat bndrs-    go (BangPat _ pat)            = collect_lpat pat bndrs-    go (AsPat _ a pat)            = unLoc a : collect_lpat pat bndrs-    go (ViewPat _ _ pat)          = collect_lpat pat bndrs-    go (ParPat _ pat)             = collect_lpat pat bndrs--    go (ListPat _ pats)           = foldr collect_lpat bndrs pats-    go (TuplePat _ pats _)        = foldr collect_lpat bndrs pats-    go (SumPat _ pat _ _)         = collect_lpat pat bndrs--    go (ConPatIn _ ps)            = foldr collect_lpat bndrs (hsConPatArgs ps)-    go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)-        -- See Note [Dictionary binders in ConPatOut]-    go (LitPat _ _)               = bndrs-    go (NPat {})                  = bndrs-    go (NPlusKPat _ n _ _ _ _)    = unLoc n : bndrs--    go (SigPat _ pat _)           = collect_lpat pat bndrs--    go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))-                                  = go pat-    go (SplicePat _ _)            = bndrs-    go (CoPat _ _ pat _)          = go pat-    go (XPat {})                  = bndrs--{--Note [Dictionary binders in ConPatOut] See also same Note in DsArrows-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do *not* gather (a) dictionary and (b) dictionary bindings as binders-of a ConPatOut pattern.  For most calls it doesn't matter, because-it's pre-typechecker and there are no ConPatOuts.  But it does matter-more in the desugarer; for example, DsUtils.mkSelectorBinds uses-collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,-we want to generate bindings for x,y but not for dictionaries bound by-C.  (The type checker ensures they would not be used.)--Desugaring of arrow case expressions needs these bindings (see DsArrows-and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its-own pat-binder-collector:--Here's the problem.  Consider--data T a where-   C :: Num a => a -> Int -> T a--f ~(C (n+1) m) = (n,m)--Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),-and *also* uses that dictionary to match the (n+1) pattern.  Yet, the-variables bound by the lazy pattern are n,m, *not* the dictionary d.-So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.--}--hsGroupBinders :: HsGroup GhcRn -> [Name]-hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,-                          hs_fords = foreign_decls })-  =  collectHsValBinders val_decls-  ++ hsTyClForeignBinders tycl_decls foreign_decls-hsGroupBinders (XHsGroup nec) = noExtCon nec--hsTyClForeignBinders :: [TyClGroup GhcRn]-                     -> [LForeignDecl GhcRn]-                     -> [Name]--- We need to look at instance declarations too,--- because their associated types may bind data constructors-hsTyClForeignBinders tycl_decls foreign_decls-  =    map unLoc (hsForeignDeclsBinders foreign_decls)-    ++ getSelectorNames-         (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls-         `mappend`-         foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)-  where-    getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]-    getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs----------------------hsLTyClDeclBinders :: Located (TyClDecl (GhcPass p))-                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])--- ^ Returns all the /binding/ names of the decl.  The first one is--- guaranteed to be the name of the decl. The first component--- represents all binding names except record fields; the second--- represents field occurrences. For record fields mentioned in--- multiple constructors, the SrcLoc will be from the first occurrence.------ Each returned (Located name) has a SrcSpan for the /whole/ declaration.--- See Note [SrcSpan for binders]--hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl-                                            { fdLName = (dL->L _ name) } }))-  = ([cL loc name], [])-hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl nec }))-  = noExtCon nec-hsLTyClDeclBinders (dL->L loc (SynDecl-                               { tcdLName = (dL->L _ name) }))-  = ([cL loc name], [])-hsLTyClDeclBinders (dL->L loc (ClassDecl-                               { tcdLName = (dL->L _ cls_name)-                               , tcdSigs  = sigs-                               , tcdATs   = ats }))-  = (cL loc cls_name :-     [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl-                                        { fdLName = L _ fam_name })) <- ats ]-     ++-     [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs-                           , (dL->L _ mem_name) <- ns ]-    , [])-hsLTyClDeclBinders (dL->L loc (DataDecl    { tcdLName = (dL->L _ name)-                                           , tcdDataDefn = defn }))-  = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn-hsLTyClDeclBinders (dL->L _ (XTyClDecl nec)) = noExtCon nec-hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"-                             -- due to #15884-----------------------hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]--- ^ See Note [SrcSpan for binders]-hsForeignDeclsBinders foreign_decls-  = [ cL decl_loc n-    | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))-        <- foreign_decls]-----------------------hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]--- ^ Collects record pattern-synonym selectors only; the pattern synonym--- names are collected by collectHsValBinders.-hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"-hsPatSynSelectors (XValBindsLR (NValBinds binds _))-  = foldr addPatSynSelector [] . unionManyBags $ map snd binds--addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]-addPatSynSelector bind sels-  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind-  = map (unLoc . recordPatSynSelectorId) as ++ sels-  | otherwise = sels--getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]-getPatSynBinds binds-  = [ psb | (_, lbinds) <- binds-          , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]----------------------hsLInstDeclBinders :: LInstDecl (GhcPass p)-                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-hsLInstDeclBinders (dL->L _ (ClsInstD-                             { cid_inst = ClsInstDecl-                                          { cid_datafam_insts = dfis }}))-  = foldMap (hsDataFamInstBinders . unLoc) dfis-hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))-  = hsDataFamInstBinders fi-hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty-hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl nec)))-  = noExtCon nec-hsLInstDeclBinders (dL->L _ (XInstDecl nec))-  = noExtCon nec-hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"-                             -- due to #15884------------------------ | the SrcLoc returned are for the whole declarations, not just the names-hsDataFamInstBinders :: DataFamInstDecl (GhcPass p)-                     -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                       FamEqn { feqn_rhs = defn }}})-  = hsDataDefnBinders defn-  -- There can't be repeated symbols because only data instances have binders-hsDataFamInstBinders (DataFamInstDecl-                                    { dfid_eqn = HsIB { hsib_body = XFamEqn nec}})-  = noExtCon nec-hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs nec))-  = noExtCon nec------------------------ | the SrcLoc returned are for the whole declarations, not just the names-hsDataDefnBinders :: HsDataDefn (GhcPass p)-                  -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-hsDataDefnBinders (HsDataDefn { dd_cons = cons })-  = hsConDeclsBinders cons-  -- See Note [Binders in family instances]-hsDataDefnBinders (XHsDataDefn nec) = noExtCon nec----------------------type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]-                 -- Filters out ones that have already been seen--hsConDeclsBinders :: [LConDecl (GhcPass p)]-                  -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-   -- See hsLTyClDeclBinders for what this does-   -- The function is boringly complicated because of the records-   -- And since we only have equality, we have to be a little careful-hsConDeclsBinders cons-  = go id cons-  where-    go :: Seen p -> [LConDecl (GhcPass p)]-       -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-    go _ [] = ([], [])-    go remSeen (r:rs)-      -- Don't re-mangle the location of field names, because we don't-      -- have a record of the full location of the field declaration anyway-      = let loc = getLoc r-        in case unLoc r of-           -- remove only the first occurrence of any seen field in order to-           -- avoid circumventing detection of duplicate fields (#9156)-           ConDeclGADT { con_names = names, con_args = args }-             -> (map (cL loc . unLoc) names ++ ns, flds ++ fs)-             where-                (remSeen', flds) = get_flds remSeen args-                (ns, fs) = go remSeen' rs--           ConDeclH98 { con_name = name, con_args = args }-             -> ([cL loc (unLoc name)] ++ ns, flds ++ fs)-             where-                (remSeen', flds) = get_flds remSeen args-                (ns, fs) = go remSeen' rs--           XConDecl nec -> noExtCon nec--    get_flds :: Seen p -> HsConDeclDetails (GhcPass p)-             -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds remSeen (RecCon flds)-       = (remSeen', fld_names)-       where-          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))-          remSeen' = foldr (.) remSeen-                               [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v-                               | v <- fld_names]-    get_flds remSeen _-       = (remSeen, [])--{---Note [SrcSpan for binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When extracting the (Located RdrNme) for a binder, at least for the-main name (the TyCon of a type declaration etc), we want to give it-the @SrcSpan@ of the whole /declaration/, not just the name itself-(which is how it appears in the syntax tree).  This SrcSpan (for the-entire declaration) is used as the SrcSpan for the Name that is-finally produced, and hence for error messages.  (See #8607.)--Note [Binders in family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a type or data family instance declaration, the type-constructor is an *occurrence* not a binding site-    type instance T Int = Int -> Int   -- No binders-    data instance S Bool = S1 | S2     -- Binders are S1,S2---************************************************************************-*                                                                      *-        Collecting binders the user did not write-*                                                                      *-************************************************************************--The job of this family of functions is to run through binding sites and find the set of all Names-that were defined "implicitly", without being explicitly written by the user.--The main purpose is to find names introduced by record wildcards so that we can avoid-warning the user when they don't use those names (#4404)--Since the addition of -Wunused-record-wildcards, this function returns a pair-of [(SrcSpan, [Name])]. Each element of the list is one set of implicit-binders, the first component of the tuple is the document describes the possible-fix to the problem (by removing the ..).--This means there is some unfortunate coupling between this function and where it-is used but it's only used for one specific purpose in one place so it seemed-easier.--}--lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]-                -> [(SrcSpan, [Name])]-lStmtsImplicits = hs_lstmts-  where-    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]-              -> [(SrcSpan, [Name])]-    hs_lstmts = concatMap (hs_stmt . unLoc)--    hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))-            -> [(SrcSpan, [Name])]-    hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat-    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args-      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat-            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts-            do_arg (_, XApplicativeArg nec) = noExtCon nec-    hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)-    hs_stmt (BodyStmt {})         = []-    hs_stmt (LastStmt {})         = []-    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs-                                                , s <- ss]-    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts-    hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss-    hs_stmt (XStmtLR nec)         = noExtCon nec--    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds-    hs_local_binds (HsIPBinds {})           = []-    hs_local_binds (EmptyLocalBinds _)      = []-    hs_local_binds (XHsLocalBindsLR _)      = []--hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]-hsValBindsImplicits (XValBindsLR (NValBinds binds _))-  = concatMap (lhsBindsImplicits . snd) binds-hsValBindsImplicits (ValBinds _ binds _)-  = lhsBindsImplicits binds--lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]-lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []-  where-    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat-    lhs_bind _ = []--lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]-lPatImplicits = hs_lpat-  where-    hs_lpat lpat = hs_pat (unLoc lpat)--    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []--    hs_pat (LazyPat _ pat)      = hs_lpat pat-    hs_pat (BangPat _ pat)      = hs_lpat pat-    hs_pat (AsPat _ _ pat)      = hs_lpat pat-    hs_pat (ViewPat _ _ pat)    = hs_lpat pat-    hs_pat (ParPat _ pat)       = hs_lpat pat-    hs_pat (ListPat _ pats)     = hs_lpats pats-    hs_pat (TuplePat _ pats _)  = hs_lpats pats--    hs_pat (SigPat _ pat _)     = hs_lpat pat-    hs_pat (CoPat _ _ pat _)    = hs_pat pat--    hs_pat (ConPatIn n ps)           = details n ps-    hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps--    hs_pat _ = []--    details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon ps)   = hs_lpats ps-    details n (RecCon fs)      =-      [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]-        ++ hs_lpats explicit_pats--      where implicit_pats = map (hsRecFieldArg . unLoc) implicit-            explicit_pats = map (hsRecFieldArg . unLoc) explicit---            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld-                                                    | (i, fld) <- [0..] `zip` rec_flds fs-                                                    ,  let  pat_explicit =-                                                              maybe True ((i<) . unLoc)-                                                                         (rec_dotdot fs)]-            err_loc = maybe (getLoc n) getLoc (rec_dotdot fs)--    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TupleSections   #-}++{-|+Module      : GHC.Hs.Utils+Description : Generic helpers for the HsSyn type.+Copyright   : (c) The University of Glasgow, 1992-2023++Here we collect a variety of helper functions that construct or+analyse HsSyn.  All these functions deal with generic HsSyn; functions+which deal with the instantiated versions are located elsewhere:++   Parameterised by          Module+   ----------------          -------------+   GhcPs/RdrName             GHC.Parser.PostProcess+   GhcRn/Name                GHC.Rename.*+   GhcTc/Id                  GHC.Tc.Zonk.Type++The @mk*@ functions attempt to construct a not-completely-useless SrcSpan+from their components, compared with the @nl*@ functions which+just attach noSrcSpan to everything.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE RecordWildCards #-}++module GHC.Hs.Utils(+  -- * Terms+  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps,+  mkHsAppType, mkHsAppTypes, mkHsCaseAlt,+  mkSimpleMatch, unguardedGRHSs, unguardedRHS,+  mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,+  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,+  mkHsDictLet, mkHsLams,+  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns,+  mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo,+  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,+  mkHsCmdIf, mkConLikeTc,++  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,+  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,+  nlHsIntLit, nlHsVarApps,+  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,+  mkLocatedList, nlAscribe,++  forgetUserRdr, noUserRdr,++  -- * Bindings+  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,+  mkPatSynBind,+  isInfixFunBind,+  spanHsLocaLBinds,++  -- * Literals+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit,+  mkHsCharPrimLit,++  -- * Patterns+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,+  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,+  nlWildPatName, nlTuplePat, mkParPat, nlParPat,+  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,++  -- * Types+  mkHsAppTy, mkHsAppKindTy,+  hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,+  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,++  -- * Stmts+  mkTransformStmt, mkTransformByStmt, mkBodyStmt,+  mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,+  mkLastStmt,+  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,+  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,+  unitRecStmtTc,+  mkLetStmt,++  -- * Collecting binders+  isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind,++  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,+  collectHsIdBinders,+  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,++  collectPatBinders, collectPatsBinders,+  collectLStmtsBinders, collectStmtsBinders,+  collectLStmtBinders, collectStmtBinders,+  CollectPass(..), CollectFlag(..),++  TyDeclBinders(..), LConsWithFields(..),+  hsLTyClDeclBinders, hsTyClForeignBinders,+  hsPatSynSelectors, getPatSynBinds,+  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,++  -- * Collecting implicit binders+  ImplicitFieldBinders(..),+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits,+  lHsRecFieldsImplicits+  ) where++import GHC.Prelude hiding (head, init, last, tail)++import GHC.Hs.Decls+import GHC.Hs.Binds+import GHC.Hs.Expr+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Hs.Lit+import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Parser.Annotation++import GHC.Tc.Types.Evidence++import GHC.Core.Coercion( isReflCo )+import GHC.Core.Multiplicity ( pattern ManyTy )+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.Make   ( mkChunkified )+import GHC.Core.Type   ( Type, isUnliftedType )++import GHC.Builtin.Types ( unitTy, manyDataConTy )++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Set hiding ( unitFV )+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Var+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Fixity+import GHC.Types.SourceText++import GHC.Data.FastString++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Arrow ( first )+import Data.Foldable ( toList )+import Data.List ( partition )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import qualified Data.List.NonEmpty as NE++import Data.IntMap ( IntMap )+import qualified Data.IntMap.Strict as IntMap+import Data.Map ( Map )+import qualified Data.Map.Strict as Map++{-+************************************************************************+*                                                                      *+        Some useful helpers for constructing syntax+*                                                                      *+************************************************************************++These functions attempt to construct a not-completely-useless 'SrcSpan'+from their components, compared with the @nl*@ functions below which+just attach 'noSrcSpan' to everything.+-}++-- | @e => (e)@+mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+mkHsPar e = L (getLoc e) (gHsPar e)++mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA,+                  Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ EpAnn NoEpAnns)+              => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+              -> LocatedE [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))+              -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))+mkSimpleMatch ctxt (L l pats) rhs+  = L loc $+    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = L l pats+          , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }+  where+    loc = case pats of+                []      -> getLoc rhs+                (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)++unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns+               => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn+               -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))+unguardedGRHSs loc rhs an+  = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds++unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns+             => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))+             -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p))))+unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs)++type AnnoBody p body+  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin+    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW+    , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA+    )++mkMatchGroup :: AnnoBody p body+             => Origin+             -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+             -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))+mkMatchGroup origin matches = MG { mg_ext = origin+                                 , mg_alts = matches }++mkLamCaseMatchGroup :: AnnoBody p body+                    => Origin+                    -> HsLamVariant+                    -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+                    -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))+mkLamCaseMatchGroup origin lam_variant (L l matches)+  = mkMatchGroup origin (L l $ map fixCtxt matches)+  where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant}++mkLocatedList :: (Semigroup a, NoAnn an)+  => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2]+mkLocatedList ms = case nonEmpty ms of+    Nothing -> noLocA []+    Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms++mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2)++mkHsAppWith+  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))+  -> LHsExpr (GhcPass id)+  -> LHsExpr (GhcPass id)+  -> LHsExpr (GhcPass id)+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)++mkHsApps+  :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)+mkHsApps = mkHsAppsWith addCLocA++mkHsAppsWith+ :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))+ -> LHsExpr (GhcPass id)+ -> [LHsExpr (GhcPass id)]+ -> LHsExpr (GhcPass id)+mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)++mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn+mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)+  where+    t_body    = hswc_body t+    paren_wct = t { hswc_body = t_body }++mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn+mkHsAppTypes = foldl' mkHsAppType++mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)+        => LocatedE [LPat (GhcPass p)]+        -> LHsExpr (GhcPass p)+        -> LHsExpr (GhcPass p)+mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))+  where+    matches = mkMatchGroup (Generated OtherExpansion SkipPmc)+                           (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body])+    pats' = map (parenthesizePat appPrec) pats++mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc+mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars+                                       <.> mkWpEvLams dicts) expr++mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+mkHsSyntaxApps ann (SyntaxExprTc { syn_expr      = fun+                                 , syn_arg_wraps = arg_wraps+                                 , syn_res_wrap  = res_wrap }) args+  = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual mkLHsWrap arg_wraps args))+mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)+  -- this function should never be called in scenarios where there is no+  -- syntax expr++-- |A simple case alternative with a single pattern, no binds, no guards;+-- pre-typechecking+mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns,+                 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA)+            => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))+            -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))+mkHsCaseAlt (L l pat) expr+  = mkSimpleMatch CaseAlt (L (l2l l) [L l pat]) expr++nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc+nlHsTyApp fun_id tys+  = noLocA (mkHsWrap (mkWpTyApps tys) (mkHsVar (noLocA fun_id)))++nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc+nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs++--------- Adding parens ---------+-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them+-- So @f x@ becomes @(f x)@, but @3@ stays as @3@.+mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkLHsPar = parenthesizeHsExpr appPrec++mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)+mkParPat = parenthesizePat appPrec++nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)+nlParPat p = noLocA (gParPat p)++-------------------------------+-- These are the bits of syntax that contain rebindable names+-- See GHC.Rename.Env.lookupSyntax++mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs+mkHsFractional :: FractionalLit -> HsOverLit GhcPs+mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs+mkHsDo         :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDoAnns     :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs+mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+               -> HsExpr GhcPs+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+               -> AnnList EpaLocation+               -> HsExpr GhcPs++mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-"+            -> Pat GhcPs+mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+"+            -> Pat GhcPs++-- NB: The following functions all use noSyntaxExpr: the generated expressions+--     will not work with rebindable syntax if used after the renamer+mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR))+           -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))+mkBodyStmt :: LocatedA (bodyR GhcPs)+           -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))+mkPsBindStmt :: EpUniToken "<-" "←" -> LPat GhcPs -> LocatedA (bodyR GhcPs)+             -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))+mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)+             -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))+mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)+             -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))++emptyRecStmt     :: (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnLW)+                 => StmtLR (GhcPass idL) GhcPs bodyR+emptyRecStmtName :: (Anno [GenLocated+                             (Anno (StmtLR GhcRn GhcRn bodyR))+                             (StmtLR GhcRn GhcRn bodyR)]+                        ~ SrcSpanAnnLW)+                 => StmtLR GhcRn GhcRn bodyR+emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc))++mkRecStmt :: forall (idL :: Pass) bodyR.+                    (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnLW)+                 => AnnList (EpToken "rec")+                 -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]+                 -> StmtLR (GhcPass idL) GhcPs bodyR+mkRecStmt anns stmts  = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)+                             { recS_stmts = stmts }+++mkHsIntegral     i  = OverLit noExtField (HsIntegral       i)+mkHsFractional   f  = OverLit noExtField (HsFractional     f)+mkHsIsString src s  = OverLit noExtField (HsIsString   src s)++mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts+mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts+mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn+mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns+  where+    -- Move the annotations to the top of the last_stmt+    last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e)+    last_stmt = L l last+    -- last_stmt actually comes first in a list comprehension, consider all spans+    loc  = noAnnSrcSpan $ getHasLocList (last_stmt:stmts)++-- restricted to GhcPs because other phases might need a SyntaxExpr+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf+       -> HsExpr GhcPs+mkHsIf c a b anns = HsIf anns c a b++-- restricted to GhcPs because other phases might need a SyntaxExpr+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf+       -> HsCmd GhcPs+mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b++mkNPat lit neg anns  = NPat anns lit neg noSyntaxExpr+mkNPlusKPat id lit anns+  = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr++mkTransformStmt    :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkTransformByStmt  :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkGroupUsingStmt   :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkGroupByUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)++emptyTransStmt :: AnnTransStmt -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+emptyTransStmt anns = TransStmt { trS_ext = anns+                                , trS_form = panic "emptyTransStmt: form"+                                , trS_stmts = [], trS_bndrs = []+                                , trS_by = Nothing, trS_using = noLocA noExpr+                                , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr+                                , trS_fmap = noExpr }+mkTransformStmt    a ss u   = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }+mkTransformByStmt  a ss u b = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }+mkGroupUsingStmt   a ss u   = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u }+mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }++mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr+mkBodyStmt body+  = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr+mkPsBindStmt ann pat body = BindStmt ann pat body+mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body+mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,+                                                xbstc_boundResultType = unitTy,+                                                   -- unitTy is a dummy value+                                                   -- can't panic here: it's forced during zonking+                                                xbstc_boundResultMult = ManyTy,+                                                xbstc_failOp = Nothing }) pat body++emptyRecStmt' :: forall idL idR body .+  (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)+              => XRecStmt (GhcPass idL) (GhcPass idR) body+              -> StmtLR (GhcPass idL) (GhcPass idR) body+emptyRecStmt' tyVal =+   RecStmt+     { recS_stmts = wrapXRec @(GhcPass idR) []+     , recS_later_ids = []+     , recS_rec_ids = []+     , recS_ret_fn = noSyntaxExpr+     , recS_mfix_fn = noSyntaxExpr+     , recS_bind_fn = noSyntaxExpr+     , recS_ext = tyVal }++unitRecStmtTc :: RecStmtTc+unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy+                          , recS_later_rets = []+                          , recS_rec_rets = []+                          , recS_ret_ty = unitTy }++emptyRecStmt     = emptyRecStmt' noAnn+emptyRecStmtName = emptyRecStmt' noExtField+emptyRecStmtId   = emptyRecStmt' unitRecStmtTc+                                        -- a panic might trigger during zonking++mkLetStmt :: EpToken "let" -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)+mkLetStmt anns binds = LetStmt anns binds++-------------------------------+-- | A useful function for building @OpApps@.  The operator is always a+-- variable, and we don't know the fixity yet.+mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (mkHsVar (noLocA op))) e2++mkHsString :: String -> HsLit (GhcPass p)+mkHsString s = HsString NoSourceText (mkFastString s)++mkHsStringFS :: FastString -> HsLit (GhcPass p)+mkHsStringFS s = HsString NoSourceText s++mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)+mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)++mkHsCharPrimLit :: Char -> HsLit (GhcPass p)+mkHsCharPrimLit c = HsChar NoSourceText c++mkConLikeTc :: ConLike -> HsExpr GhcTc+mkConLikeTc con = XExpr (ConLikeTc con [] [])++{-+************************************************************************+*                                                                      *+        Constructing syntax with no location info+*                                                                      *+************************************************************************+-}++nlHsVar :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LHsExpr (GhcPass p)+nlHsVar n = noLocA (mkHsVar (noLocA n))++-- | NB: Only for 'LHsExpr' 'Id'.+nlHsDataCon :: DataCon -> LHsExpr GhcTc+nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))++nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)+nlHsLit n = noLocA (HsLit noExtField n)++nlHsIntLit :: Integer -> LHsExpr (GhcPass p)+nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))++nlVarPat :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LPat (GhcPass p)+nlVarPat n = noLocA (VarPat noExtField (noLocA n))++nlLitPat :: HsLit GhcPs -> LPat GhcPs+nlLitPat l = noLocA (LitPat noExtField l)++nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x))++nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA++nlHsApps :: IsSrcSpanAnn p a+         => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)+nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs++nlHsVarApps :: IsSrcSpanAnn p a+            => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+nlHsVarApps f xs = noLocA (foldl' mk (mkHsVar (noLocA f))+                                         (map (mkHsVar . noLocA) xs))+                 where+                   mk f a = HsApp noExtField (noLocA f) (noLocA a)++nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs+nlConVarPat con vars = nlConPat con (map nlVarPat vars)++nlConVarPatName :: Name -> [Name] -> LPat GhcRn+nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)++nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs+nlInfixConPat con l r = noLocA $ ConPat+  { pat_con = noLocA con+  , pat_args = InfixCon (parenthesizePat opPrec l)+                        (parenthesizePat opPrec r)+  , pat_con_ext = noAnn+  }++nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs+nlConPat con pats = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  }++nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn+nlConPatName con pats = noLocA $ ConPat+  { pat_con_ext = noExtField+  , pat_con = noLocA (noUserRdr con)+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  }++nlNullaryConPat :: RdrName -> LPat GhcPs+nlNullaryConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon []+  }++nlWildConPat :: DataCon -> LPat GhcPs+nlWildConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA $ getRdrName con+  , pat_args = PrefixCon $+     replicate (dataConSourceArity con)+               nlWildPat+  }++-- | Wildcard pattern - after parsing+nlWildPat :: LPat GhcPs+nlWildPat  = noLocA (WildPat noExtField )++-- | Wildcard pattern - after renaming+nlWildPatName :: LPat GhcRn+nlWildPatName  = noLocA (WildPat noExtField )++nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]+       -> LHsExpr GhcPs+nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))++nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)++nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs+nlHsPar  :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+         -> LHsExpr GhcPs+nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs++nlHsLam match = noLocA $ HsLam noAnn LamSingle+                  $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])++nlHsPar e     = noLocA (gHsPar e)++-- nlHsIf should generate if-expressions which are NOT subject to+-- RebindableSyntax, so the first field of HsIf is False. (#12080)+nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+nlHsIf cond true false = noLocA (HsIf noAnn cond true false)++nlHsCase expr matches+  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches)))+nlList exprs          = noLocA (ExplicitList noAnn exprs)++nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsTyVar :: forall p a. IsSrcSpanAnn p a+          => PromotionFlag -> IdP (GhcPass p)           -> LHsType (GhcPass p)+nlHsFunTy :: forall p. IsPass p+          => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)++nlHsAppTy f t = noLocA (HsAppTy noExtField f t)+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA $ noUserRdrP @p x))+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b)+  where+    x = case ghcPass @p of+      GhcPs -> EpArrow noAnn+      GhcRn -> noExtField+      GhcTc -> manyDataConTy+nlHsParTy t   = noLocA (HsParTy noAnn t)++nlHsTyConApp :: forall p a. IsSrcSpanAnn p a+             => PromotionFlag+             -> LexicalFixity -> IdOccP (GhcPass p)+             -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)+nlHsTyConApp prom fixity tycon tys+  | Infix <- fixity+  , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys+  = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest+  | otherwise+  = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys+  where+    mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg+      -- parenthesize things like `(A + B) C`+    mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty+    mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki+    mk_app fun (HsArgPar _) = nlHsParTy fun++-- | Turn an 'IdP' into an 'IdOccP', with no user-written 'RdrName' information.+noUserRdrP :: forall p. IsPass p => IdP (GhcPass p) -> IdOccP (GhcPass p)+noUserRdrP =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> noUserRdr+    GhcTc -> id++-- | Turn an 'IdOccP' into an 'IdP', discarding the user-written 'RdrName'.+forgetUserRdr :: forall p. IsPass p => IdOccP (GhcPass p) -> IdP (GhcPass p)+forgetUserRdr =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> \ (WithUserRdr _rdr n) -> n+    GhcTc -> id++nlHsAppKindTy :: forall p. IsPass p =>+  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)+nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++{-+Tuples.  All these functions are *pre-typechecker* because they lack+types on the tuple.+-}++mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p)+-- Makes a pre-typechecker boxed tuple, deals with 1 case+mkLHsTupleExpr [e] _ = e+mkLHsTupleExpr es ext+  = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed++mkLHsVarTuple :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)+              -> LHsExpr (GhcPass p)+mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext++nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs+nlTuplePat pats box = noLocA (TuplePat noAnn pats box)++missingTupArg :: EpAnn Bool -> HsTupArg GhcPs+missingTupArg ann = Missing ann++mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn+mkLHsPatTup []     = noLocA $ TuplePat noExtField [] Boxed+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats@(lpat:_) = L (getLoc lpat) $ TuplePat noExtField lpats Boxed++-- | The Big equivalents for the source tuple expressions+mkBigLHsVarTup :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p)+mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns++mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)+            -> LHsExpr (GhcPass id)+mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es++-- | The Big equivalents for the source tuple patterns+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn+mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)++mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn+mkBigLHsPatTup = mkChunkified mkLHsPatTup++{-+************************************************************************+*                                                                      *+        LHsSigType and LHsSigWcType+*                                                                      *+********************************************************************* -}++-- | Convert an 'LHsType' to an 'LHsSigType'.+hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs+hsTypeToHsSigType lty@(L loc ty) = case ty of+  HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an+                                        , hsf_invis_bndrs = bndrs }+             , hst_body = body }+    -> L loc $ mkHsExplicitSigType an bndrs body+  _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc++-- | Convert an 'LHsType' to an 'LHsSigWcType'.+hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs+hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType++mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a))+                     -> [LSig GhcRn]+                     -> NameEnv a+mkHsSigEnv get_info sigs+  = mkNameEnv          (mk_pairs ordinary_sigs)+   `extendNameEnvList` (mk_pairs gen_dm_sigs)+   -- The subtlety is this: in a class decl with a+   -- default-method signature as well as a method signature+   -- we want the latter to win (#12533)+   --    class C x where+   --       op :: forall a . x a -> x a+   --       default op :: forall b . x b -> x b+   --       op x = ...(e :: b -> b)...+   -- The scoped type variables of the 'default op', namely 'b',+   -- scope over the code for op.   The 'forall a' does not!+   -- This applies both in the renamer and typechecker, both+   -- of which use this function+  where+    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs+    is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True+    is_gen_dm_sig _                             = False++    mk_pairs :: [LSig GhcRn] -> [(Name, a)]+    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs+                            , L _ n <- ns ]++mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]+-- ^ Convert 'TypeSig' to 'ClassOpSig'.+-- The former is what is parsed, but the latter is+-- what we need in class/instance declarations+mkClassOpSigs sigs+  = map fiddle sigs+  where+    fiddle (L loc (TypeSig anns nms ty))+      = L loc (ClassOpSig anns False nms (dropWildCards ty))+    fiddle sig = sig+++-- | Type ascription: (e :: ty)+nlAscribe :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+nlAscribe ty e = noLocA $ ExprWithTySig noAnn e+                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType+                           $ nlHsTyVar NotPromoted ty++{- *********************************************************************+*                                                                      *+    --------- HsWrappers: type args, dict args, casts ---------+*                                                                      *+********************************************************************* -}++mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)++mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrap co_fn e | isIdHsWrapper co_fn = e+mkHsWrap co_fn e                       = XExpr (WrapExpr co_fn e)++mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b+           -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e++mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b+            -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e++mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc+mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)++mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc+mkHsCmdWrap w cmd | isIdHsWrapper w = cmd+                  | otherwise       = XCmd (HsWrap w cmd)++mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)++mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p+                       | otherwise           = XPat $ CoPat co_fn p ty++mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc+mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty)++mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc+mkHsWrapPatCo co pat ty | isReflCo co = pat+                        | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty++mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc+mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr++{-+l+************************************************************************+*                                                                      *+                Bindings; with a location at the top+*                                                                      *+************************************************************************+-}++mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]+          -> HsBind GhcPs+-- ^ Not infix, with place holders for coercion and free vars+mkFunBind origin fn ms+  = FunBind { fun_id = fn+            , fun_matches = mkMatchGroup origin (noLocA ms)+            , fun_ext = noExtField+            }++mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]+             -> HsBind GhcRn+-- ^ In Name-land, with empty bind_fvs+mkTopFunBind origin fn ms = FunBind { fun_id = fn+                                    , fun_matches = mkMatchGroup origin (noLocA ms)+                                    , fun_ext  = emptyNameSet -- NB: closed+                                                              --     binding+                                    }++mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var (noLocA []) rhs++mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc+mkVarBind var rhs = L (getLoc rhs) $+                    VarBind { var_ext = noExtField,+                              var_id = var, var_rhs = rhs }++mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs+             -> LPat GhcPs -> HsPatSynDir GhcPs -> AnnPSB -> HsBind GhcPs+mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb+  where+    psb = PSB{ psb_ext = anns+             , psb_id = name+             , psb_args = details+             , psb_def = lpat+             , psb_dir = dir }++-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is+-- considered infix.+isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool+isInfixFunBind (FunBind { fun_matches = MG _ matches })+  = any (isInfixMatch . unLoc) (unLoc matches)+isInfixFunBind _ = False++-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds+spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan+spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan+spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA $ concatMap snd bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))+  = foldr combineSrcSpans noSrcSpan (map getLocA bs)++------------+-- | Convenience function using 'mkFunBind'.+-- This is for generated bindings only, do not use for user-written code.+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs]+                         -> LHsExpr GhcPs -> LHsBind GhcPs+mkSimpleGeneratedFunBind loc fun pats expr+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)+                                     [mkMatch ctxt pats expr emptyLocalBinds]+  where+    ctxt :: HsMatchContextPs+    ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn++-- | Make a prefix, non-strict function 'HsMatchContext'+mkPrefixFunRhs :: fn -> AnnFunRhs -> HsMatchContext fn+mkPrefixFunRhs n an = FunRhs { mc_fun        = n+                          , mc_fixity     = Prefix+                          , mc_strictness = NoSrcStrict+                          , mc_an         = an }++------------+mkMatch :: forall p. IsPass p+        => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+        -> LocatedE [LPat (GhcPass p)]+        -> LHsExpr (GhcPass p)+        -> HsLocalBinds (GhcPass p)+        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))+mkMatch ctxt pats expr binds+  = noLocA (Match { m_ext   = noExtField+                  , m_ctxt  = ctxt+                  , m_pats  = pats+                  , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })++{-+************************************************************************+*                                                                      *+        Collecting binders+*                                                                      *+************************************************************************++Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.++...+where+  (x, y) = ...+  f i j  = ...+  [a, b] = ...++it should return [x, y, f, a, b] (remember, order important).++Note [Collect binders only after renaming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions should only be used on HsSyn *after* the renamer,+to return a [Name] or [Id].  Before renaming the record punning+and wild-card mechanism makes it hard to know what is bound.+So these functions should not be applied to (HsSyn RdrName)++Note [isUnliftedHsBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function isUnliftedHsBind tells if the binding binds a variable of+unlifted type.  e.g.++  - I# x = blah+  - Just (I# x) = blah++isUnliftedHsBind is used in two ways:++* To complain if we make a top-level binding for a variable of unlifted+  type. E.g. any of the above bindings are illegal at top level++* To generate a case expression for a non-recursive local let.  E.g.+     let Just (I# x) = blah in body+  ==>+     case blah of Just (I# x) -> body+  See GHC.HsToCore.Expr.dsUnliftedBind.++Wrinkles:++(W1) For AbsBinds we must check if the local letrec generated by desugaring+     AbsBinds would be unlifted; so we just recurse into the abs_binds. E.g.+       f :: Num a => (# a, a #)+       g :: Num a => a -> a+       f = ...g...+       g = ...g...++    The top-level bindings for f,g are not unlifted (because of the Num a =>),+    but the local, recursive, monomorphic bindings are:+      t = /\a \(d:Num a).+         letrec fm :: (# a, a #) = ...g...+                gm :: a -> a = ...f...+         in (fm, gm)++   Here the binding for 'fm' is illegal.  So we recurse into the abs_binds++(W2) BUT we have a special case when abs_sig is true;+     see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds++(W3) isUnliftedHsBind returns False even if the binding itself is+     unlifted, provided it binds only lifted variables. E.g.+      -  (# a,b #) = (# reverse xs, xs #)++      -  x = sqrt# y#  :: Float#++      -  type Unl :: UnliftedType+         data Unl = MkUnl Int+         MkUnl z = blah++     In each case the RHS of the "=" has unlifted type, but isUnliftedHsBind+     returns False.  Reason: see GHC Proposal #35+        https://github.com/ghc-proposals/ghc-proposals/blob/master/+        proposals/0035-unbanged-strict-patterns.rst++(W4) In particular, (W3) applies to a pattern that binds no variables at all.+     So   { _ = sqrt# y :: Float# } returns False from isUnliftedHsBind, but+          { x = sqrt# y :: Float# } returns True.+     This is arguably a bit confusing (see #22719)+-}++----------------- Bindings --------------------------++-- | Should we treat this as an unlifted bind? This will be true for any+-- bind that binds an unlifted variable, but we must be careful around+-- AbsBinds. See Note [isUnliftedHsBind]. For usage+-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.+isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds+isUnliftedHsBind (XHsBindsLR (AbsBinds { abs_exports = exports+                                       , abs_sig     = has_sig+                                       , abs_binds   = binds }))+  | has_sig   = any (is_unlifted_id . abe_poly) exports+  | otherwise = isUnliftedHsBinds binds+    -- See wrinkle (W1) and (W2) in Note [isUnliftedHsBind]+    -- If has_sig is True we will never generate a binding for abe_mono,+    -- so we don't need to worry about it being unlifted. The abe_poly+    -- binding might not be: e.g. forall a. Num a => (# a, a #)+    -- If has_sig is False, just recurse++isUnliftedHsBind (FunBind { fun_id = L _ fun })+  = is_unlifted_id fun++isUnliftedHsBind (VarBind { var_id = var })+  = is_unlifted_id var++isUnliftedHsBind (PatBind { pat_lhs = pat })+  = any is_unlifted_id (collectPatBinders CollNoDictBinders pat)+    -- If we changed our view on (W3) you could add+    --    || isUnliftedType pat_ty+    -- to this check++isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind"++isUnliftedHsBinds :: LHsBinds GhcTc -> Bool+isUnliftedHsBinds = any (isUnliftedHsBind . unLoc)++is_unlifted_id :: Id -> Bool+is_unlifted_id id = isUnliftedType (idType id)+   -- Bindings always have a fixed RuntimeRep, so it's OK+   -- to call isUnliftedType here++-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?+isBangedHsBind :: HsBind GhcTc -> Bool+isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))+  = any (isBangedHsBind . unLoc) binds+isBangedHsBind (FunBind {fun_matches = matches})+  | [L _ match] <- unLoc $ mg_alts matches+  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match+  = True+isBangedHsBind (PatBind {pat_lhs = pat})+  = isBangedLPat pat+isBangedHsBind _+  = False++collectLocalBinders :: CollectPass (GhcPass idL)+                    => CollectFlag (GhcPass idL)+                    -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)+                    -> [IdP (GhcPass idL)]+collectLocalBinders flag = \case+    HsValBinds _ binds -> collectHsIdBinders flag binds+                          -- No pattern synonyms here+    HsIPBinds {}       -> []+    EmptyLocalBinds _  -> []++collectHsIdBinders :: CollectPass (GhcPass idL)+                   => CollectFlag (GhcPass idL)+                   -> HsValBindsLR (GhcPass idL) (GhcPass idR)+                   -> [IdP (GhcPass idL)]+-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively+collectHsIdBinders flag = collect_hs_val_binders True flag++collectHsValBinders :: CollectPass (GhcPass idL)+                    => CollectFlag (GhcPass idL)+                    -> HsValBindsLR (GhcPass idL) idR+                    -> [IdP (GhcPass idL)]+collectHsValBinders flag = collect_hs_val_binders False flag++collectHsBindBinders :: CollectPass p+                     => CollectFlag p+                     -> HsBindLR p idR+                     -> [IdP p]+-- ^ Collect both 'Id's and pattern-synonym binders+collectHsBindBinders flag b = collect_bind False flag b []++collectHsBindsBinders :: CollectPass p+                      => CollectFlag p+                      -> LHsBindsLR p idR+                      -> [IdP p]+collectHsBindsBinders flag binds = collect_binds False flag binds []++collectHsBindListBinders :: forall p idR. CollectPass p+                         => CollectFlag p+                         -> [LHsBindLR p idR]+                         -> [IdP p]+-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings+collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []++collect_hs_val_binders :: CollectPass (GhcPass idL)+                       => Bool+                       -> CollectFlag (GhcPass idL)+                       -> HsValBindsLR (GhcPass idL) idR+                       -> [IdP (GhcPass idL)]+collect_hs_val_binders ps flag = \case+    ValBinds _ binds _              -> collect_binds ps flag binds []+    XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds++collect_out_binds :: forall p. CollectPass p+                  => Bool+                  -> CollectFlag p+                  -> [(RecFlag, LHsBinds p)]+                  -> [IdP p]+collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []++collect_binds :: forall p idR. CollectPass p+              => Bool+              -> CollectFlag p+              -> LHsBindsLR p idR+              -> [IdP p]+              -> [IdP p]+-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag+collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds++collect_bind :: forall p idR. CollectPass p+             => Bool+             -> CollectFlag p+             -> HsBindLR p idR+             -> [IdP p]+             -> [IdP p]+collect_bind _ _    (FunBind { fun_id = f })         acc = unXRec @p f : acc+collect_bind _ flag (PatBind { pat_lhs = p })        acc = collect_lpat flag p acc+collect_bind _ _    (VarBind { var_id = f })         acc = f : acc+collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc+  | omitPatSyn                  = acc+  | otherwise                   = unXRec @p ps : acc+collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc+collect_bind _ _ (XHsBindsLR b) acc = collectXXHsBindsLR @p @idR b acc+++collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]+-- ^ Used exclusively for the bindings of an instance decl which are all+-- 'FunBinds'+collectMethodBinders binds = foldr (get . unXRec @idL) [] binds+  where+    get (FunBind { fun_id = f }) fs = f : fs+    get _                        fs = fs+       -- Someone else complains about non-FunBinds++----------------- Statements --------------------------+--+collectLStmtsBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> [LStmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)++collectStmtsBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> [StmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectStmtsBinders flag = concatMap (collectStmtBinders flag)++collectLStmtBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> LStmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]+collectLStmtBinders flag = collectStmtBinders flag . unLoc++collectStmtBinders+  :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> StmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]+  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?+collectStmtBinders flag = \case+    BindStmt _ pat _ -> collectPatBinders flag pat+    LetStmt _  binds -> collectLocalBinders flag binds+    BodyStmt {}      -> []+    LastStmt {}      -> []+    ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]+    TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts+    RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss+    XStmtLR x -> case ghcPass :: GhcPass idR of+        GhcRn -> collectApplicativeStmtBndrs x+        GhcTc -> collectApplicativeStmtBndrs x+  where+    collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]+    collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args++    collectArgBinders = \case+        ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat+        ApplicativeArgMany { bv_pattern = pat }     -> collectPatBinders flag pat++----------------- Patterns --------------------------++collectPatBinders+    :: CollectPass p+    => CollectFlag p+    -> LPat p+    -> [IdP p]+collectPatBinders flag pat = collect_lpat flag pat []++collectPatsBinders+    :: CollectPass p+    => CollectFlag p+    -> [LPat p]+    -> [IdP p]+collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats++-------------++-- | Indicate if evidence binders and type variable binders have+--   to be collected.+--+-- This type enumerates the modes of collecting bound variables+--                     | evidence |   type    |   term    |  ghc  |+--                     | binders  | variables | variables |  pass |+--                     --------------------------------------------+-- CollNoDictBinders   |  no      |    no     |    yes    |  any  |+-- CollWithDictBinders |  yes     |    no     |    yes    | GhcTc |+-- CollVarTyVarBinders |  no      |    yes    |    yes    | GhcRn |+--+-- See Note [Dictionary binders in ConPatOut]+data CollectFlag p where+    -- | Don't collect evidence binders+    CollNoDictBinders   :: CollectFlag p+    -- | Collect evidence binders+    CollWithDictBinders :: CollectFlag GhcTc+    -- | Collect variable and type variable binders, but no evidence binders+    CollVarTyVarBinders :: CollectFlag GhcRn+++collect_lpat :: forall p. CollectPass p+             => CollectFlag p+             -> LPat p+             -> [IdP p]+             -> [IdP p]+collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs++collect_pat :: forall p. CollectPass p+            => CollectFlag p+            -> Pat p+            -> [IdP p]+            -> [IdP p]+collect_pat flag pat bndrs = case pat of+  VarPat _ var          -> unXRec @p var : bndrs+  WildPat _             -> bndrs+  LazyPat _ pat         -> collect_lpat flag pat bndrs+  BangPat _ pat         -> collect_lpat flag pat bndrs+  AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs+  ViewPat _ _ pat       -> collect_lpat flag pat bndrs+  ParPat _ pat          -> collect_lpat flag pat bndrs+  ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats+  TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats+  OrPat _ _             -> []+      -- See Note [Implementation of OrPatterns], Renamer:+      -- evidence binders in an OrPat currently aren't visible outside their+      -- binding pattern, so we return [].+  SumPat _ pat _ _      -> collect_lpat flag pat bndrs+  LitPat _ _            -> bndrs+  NPat {}               -> bndrs+  NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs+  SigPat _ pat sig      -> case flag of+    CollNoDictBinders   -> collect_lpat flag pat bndrs+    CollWithDictBinders -> collect_lpat flag pat bndrs+    CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig+  XPat ext              -> collectXXPat @p flag ext bndrs+  SplicePat ext _       -> collectXSplicePat @p flag ext bndrs+  EmbTyPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+  InvisPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs++  -- See Note [Dictionary binders in ConPatOut]+  ConPat {pat_args=ps}  -> case flag of+    CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+    CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+                           ++ collectEvBinders (cpt_binds (pat_con_ext pat))+    CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)++collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"++collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p]+collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs++collectTyPatBndrs :: HsTyPat GhcRn -> [Name]+collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs++collectPatSigBndrs :: HsPatSigType GhcRn -> [Name]+collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs++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??+++-- | This class specifies how to collect variable identifiers from extension patterns in the given pass.+-- Consumers of the GHC API that define their own passes should feel free to implement instances in order+-- to make use of functions which depend on it.+--+-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that+-- it can reuse the code in GHC for collecting binders.+class UnXRec p => CollectPass p where+  collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]+  collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p]+  collectXSplicePat :: CollectFlag p -> XSplicePat p -> [IdP p] -> [IdP p]++instance IsPass p => CollectPass (GhcPass p) where+  collectXXPat flag ext =+    case ghcPass @p of+      GhcPs -> dataConCantHappen ext+      GhcRn+        | HsPatExpanded _ pat <- ext+        -> collect_pat flag pat+      GhcTc -> case ext of+        CoPat _ pat _      -> collect_pat flag pat+        ExpansionPat _ pat -> collect_pat flag pat+  collectXXHsBindsLR ext =+    case ghcPass @p of+      GhcPs -> dataConCantHappen ext+      GhcRn -> dataConCantHappen ext+      GhcTc -> case ext of+        AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++)+        -- I don't think we want the binders from the abe_binds+        -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type++  collectXSplicePat flag ext =+      case ghcPass @p of+        GhcPs -> id+        GhcRn | (HsUntypedSpliceTop _ pat) <- ext -> collect_pat flag pat+        GhcRn | (HsUntypedSpliceNested _)  <- ext -> id+        GhcTc -> dataConCantHappen ext+++{-+Note [Dictionary binders in ConPatOut]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag+to choose.++1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag.++2. In the desugarer, most of the time we don't want to collect evidence binders,+   so we also use CollNoDictBinders flag.++   Example of why it matters:++   In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings+   for x,y but not for dictionaries bound by C.+   (The type checker ensures they would not be used.)++   Here's the problem.  Consider++        data T a where+           C :: Num a => a -> Int -> T a++        f ~(C (n+1) m) = (n,m)++   Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),+   and *also* uses that dictionary to match the (n+1) pattern.  Yet, the+   variables bound by the lazy pattern are n,m, *not* the dictionary d.+   So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the+   variables bound.++   So in this case, we do *not* gather (a) dictionary and (b) dictionary+   bindings as binders of a ConPatOut pattern.+++3. On the other hand, desugaring of arrows needs evidence bindings and uses+   CollWithDictBinders flag.++   Consider++        h :: (ArrowChoice a, 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 { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x++   That is, it attaches the $dNum_123 binding to a ConPatOut in scope.++   During desugaring, evidence binders must be collected because their sets are+   intersected with free variable sets of subsequent commands to create+   (minimal) command environments.  Failing to do it properly leads to bugs+   (e.g., #18950).++   Note: attaching evidence binders to existing ConPatOut may be suboptimal for+   arrows.  In the example above we would prefer to generate:++        case compare x y of+          GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x++   So that the evidence isn't passed into the command environment. This issue+   doesn't arise with desugaring of non-arrow code because the simplifier can+   freely float and inline let-expressions created for evidence binders. But+   with arrow desugaring, the simplifier would have to see through the command+   environment tuple which is more complicated.++-}++hsGroupBinders :: HsGroup GhcRn -> [Name]+hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,+                          hs_fords = foreign_decls })+  =  collectHsValBinders CollNoDictBinders val_decls+  ++ hsTyClForeignBinders tycl_decls foreign_decls++hsTyClForeignBinders :: [TyClGroup GhcRn]+                     -> [LForeignDecl GhcRn]+                     -> [Name]+-- We need to look at instance declarations too,+-- because their associated types may bind data constructors+hsTyClForeignBinders tycl_decls foreign_decls+  =    map unLoc (hsForeignDeclsBinders foreign_decls)+    ++ getSelectorNames+         (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls+         `mappend`+         (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls))+  where+    getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]+    getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs++-------------------++data TyDeclBinders p+  = TyDeclBinders+  { tyDeclMainBinder     :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ())+  , tyDeclATs            :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())]+  , tyDeclOpSigs         :: ![LocatedA (IdP (GhcPass p))]+  , tyDeclConsWithFields :: !(LConsWithFields p) }++tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+tyDeclBinders (TyDeclBinders main ats sigs consWithFields)+  = (fst main : (fmap fst ats ++ sigs ++ cons), flds)+  where+    (cons, flds) = lconsWithFieldsBinders consWithFields++hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p)+                   => LocatedA (TyClDecl (GhcPass p))+                   -> TyDeclBinders p+-- ^ Returns all the /binding/ names of the decl.  The first one is+-- guaranteed to be the name of the decl. The first component+-- represents all binding names except record fields; the second+-- represents field occurrences. For record fields mentioned in+-- multiple constructors, the SrcLoc will be from the first occurrence.+--+-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.+-- See Note [SrcSpan for binders]++hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl+                                            { fdLName = (L _ name)+                                            , fdInfo  = fd_info } }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (SynDecl+                               { tcdLName = (L _ name) }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, TypeSynonymFlavour)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (ClassDecl+                               { tcdLName = (L _ cls_name)+                               , tcdSigs  = sigs+                               , tcdATs   = ats }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc cls_name, ClassFlavour)+  , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info)+                | (L fam_loc (FamilyDecl { fdLName = L _ fam_name+                                         , fdInfo = fd_info })) <- ats ]+  , tyDeclOpSigs = [ L mem_loc mem_name+                   | (L mem_loc (ClassOpSig _ False ns _)) <- sigs+                   , (L _ mem_name) <- ns ]+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)+                                       , tcdDataDefn = defn }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, flav )+  , tyDeclATs = []+  , tyDeclOpSigs = []+  , tyDeclConsWithFields = hsDataDefnBinders defn }+  where+    flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn++-------------------+hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)+                      => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]+-- ^ See Note [SrcSpan for binders]+hsForeignDeclsBinders foreign_decls+  = [ L (noAnnSrcSpan (locA decl_loc)) n+    | L decl_loc (ForeignImport { fd_name = L _ n })+        <- foreign_decls]+++-------------------+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]+-- ^ Collects record pattern-synonym selectors only; the pattern synonym+-- names are collected by 'collectHsValBinders'.+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"+hsPatSynSelectors (XValBindsLR (NValBinds binds _))+  = foldr addPatSynSelector [] . concat $ map snd binds++addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]+addPatSynSelector bind sels+  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind+  = map recordPatSynField as ++ sels+  | otherwise = sels++getPatSynBinds :: forall id. UnXRec id+               => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]+getPatSynBinds binds+  = [ psb | (_, lbinds) <- binds+          , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ]++-------------------+hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)+                   => LInstDecl (GhcPass p)+                   -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])+hsLInstDeclBinders (L _ (ClsInstD+                             { cid_inst = ClsInstDecl+                                          { cid_datafam_insts = dfis }}))+  = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))+  = lconsWithFieldsBinders $ hsDataFamInstBinders fi+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty++-------------------+-- | the 'SrcLoc' returned are for the whole declarations, not just the names+hsDataFamInstBinders :: (IsPass p, OutputableBndrId p)+                     => DataFamInstDecl (GhcPass p)+                     -> LConsWithFields p+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})+  = hsDataDefnBinders defn+  -- There can't be repeated symbols because only data instances have binders++-------------------+-- | the 'SrcLoc' returned are for the whole declarations, not just the names+hsDataDefnBinders :: (IsPass p, OutputableBndrId p)+                  => HsDataDefn (GhcPass p)+                  -> LConsWithFields p+hsDataDefnBinders (HsDataDefn { dd_cons = cons })+  = hsConDeclsBinders (toList cons)+  -- See Note [Binders in family instances]++-------------------++{- Note [Collecting record fields in data declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a data declaration that includes record constructors, we are, in+the end, going to to create a mapping from constructor to its field labels,+to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer,+which constructor has what fields.++In order to achieve this, we return the constructor and field information from+hsConDeclsBinders in the following format:++  - [(ConRdrName, [Located Int])], a list of the constructors, each associated+    with its record fields, in the form of a list of Int indices into...+  - IntMap FieldOcc, an IntMap of record fields.++(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating+that the constructor has unlabelled fields: see Note [Local constructor info in the renamer]+in GHC.Types.GREInfo.)++This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc):++  - create 'Name's for each of the record fields, to get IntMap FieldLabel,+  - create 'Name's for each of the constructors, to get [(ConName, [Int])],+  - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])].++NB: This can be a bit tricky to get right in the presence of data types with+duplicate constructors or fields. Storing locations allows us to report an error+for duplicate field declarations, see test cases T9156 T9156_DF.+Other relevant test cases: rnfail015.++-}++-- | A mapping from constructors to all of their fields.+--+-- See Note [Collecting record fields in data declarations].+data LConsWithFields p =+  LConsWithFields+    { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])]+    , consFields :: IntMap (LFieldOcc (GhcPass p))+    }++lconsWithFieldsBinders :: LConsWithFields p+                       -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])+lconsWithFieldsBinders (LConsWithFields cons fields)+  = (map fst cons, IntMap.elems fields)++emptyLConsWithFields :: LConsWithFields p+emptyLConsWithFields = LConsWithFields [] IntMap.empty++hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p)+                  => [LConDecl (GhcPass p)]+                  -> LConsWithFields p+  -- The function is boringly complicated because of the records+  -- And since we only have equality, we have to be a little careful+hsConDeclsBinders cons = go emptyFieldIndices cons+  where+    go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p+    go seen [] = LConsWithFields [] (fields seen)+    go seen (r:rs)+      -- Don't re-mangle the location of field names, because we don't+      -- have a record of the full location of the field declaration anyway+      = let loc = getLoc r+        in case unLoc r of+           ConDeclGADT { con_names = names, con_g_args = args }+             -> LConsWithFields (cons ++ ns) fs+             where+                cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names)+                (con_flds, seen') = get_flds_gadt seen args+                LConsWithFields ns fs = go seen' rs++           ConDeclH98 { con_name = name, con_args = args }+             -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs+             where+                (con_flds, seen') = get_flds_h98 seen args+                LConsWithFields ns fs = go seen' rs++    get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p)+                 -> (Maybe [Located Int], FieldIndices p)+    get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds+    get_flds_h98 seen (PrefixCon []) = (Just [], seen)+    get_flds_h98 seen _ = (Nothing, seen)++    get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)+                  -> (Maybe [Located Int], FieldIndices p)+    get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds+    get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)+    get_flds_gadt seen _ = (Nothing, seen)++    get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)]+             -> ([Located Int], FieldIndices p)+    get_flds seen flds =+      foldr add_fld ([], seen) fld_names+      where+        add_fld fld (is, ixs) =+          let (i, ixs') = insertField fld ixs+          in  (i:is, ixs')+        fld_names = concatMap (cdrf_names . unLoc) (unLoc flds)++-- | A bijection between record fields of a datatype and integers,+-- used to implement Note [Collecting record fields in data declarations].+data FieldIndices p =+  FieldIndices+    { fields       :: IntMap (LFieldOcc (GhcPass p))+        -- ^ Look up a field from its index.+    , fieldIndices :: Map RdrName Int+        -- ^ Look up the index of a field label in the previous 'IntMap'.+    , newInt       :: !Int+        -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'.+    }++emptyFieldIndices :: FieldIndices p+emptyFieldIndices =+  FieldIndices { fields       = IntMap.empty+               , fieldIndices = Map.empty+               , newInt       = 0 }++insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p)+insertField new_fld fi@(FieldIndices flds idxs new_idx)+  | Just i <- Map.lookup rdr idxs+  = (L loc i, fi)+  | otherwise+  = (L loc new_idx,+      FieldIndices (IntMap.insert new_idx new_fld flds)+                   (Map.insert rdr new_idx idxs)+                   (new_idx + 1))+  where+    loc = getLocA new_fld+    rdr = fieldOccRdrName . unLoc $ new_fld++{-++Note [SrcSpan for binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When extracting the (Located RdrName) for a binder, at least for the+main name (the TyCon of a type declaration etc), we want to give it+the @SrcSpan@ of the whole /declaration/, not just the name itself+(which is how it appears in the syntax tree).  This SrcSpan (for the+entire declaration) is used as the SrcSpan for the Name that is+finally produced, and hence for error messages.  (See #8607.)++Note [Binders in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type or data family instance declaration, the type+constructor is an *occurrence* not a binding site+    type instance T Int = Int -> Int   -- No binders+    data instance S Bool = S1 | S2     -- Binders are S1,S2+++************************************************************************+*                                                                      *+        Collecting binders the user did not write+*                                                                      *+************************************************************************++The job of the following family of functions is to run through binding sites and find+the set of all Names that were defined "implicitly", without being explicitly written+by the user.++Note [Collecting implicit binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We collect all the RHS Names that are implicitly introduced by record wildcards,+so that we can:++  - avoid warning the user when they don't use those names (#4404),+  - report deprecation warnings for deprecated fields that are used (#23382).++The functions that collect implicit binders return a collection of 'ImplicitFieldBinders',+which associates each implicitly-introduced record field with the bound variables in the+RHS of the record field pattern, e.g. in++  data R = MkR { fld :: Int }+  foo (MkR { .. }) = fld++the renamer will elaborate this to++  foo (MkR { fld = fld_var }) = fld_var++and the implicit binders function will return++  [ ImplicitFieldBinders { implFlBndr_field = fld+                         , implFlBndr_binders = [fld_var] } ]++This information is then used:++  - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit+    a warning when a record wildcard binds no new variables (redundant record wildcard)+    or none of the bound variables are used (unused record wildcard).+  - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning+    when the field is deprecated and any of the binders are used.++NOTE: the implFlBndr_binders field should always be a singleton+      (since the RHS of an implicit binding should always be a VarPat,+      created in rnHsRecPatsAndThen.mkVarPat)++-}++-- | All binders corresponding to a single implicit record field pattern.+--+-- See Note [Collecting implicit binders].+data ImplicitFieldBinders+  = ImplicitFieldBinders { implFlBndr_field :: Name+                             -- ^ The 'Name' of the record field+                         , implFlBndr_binders :: [Name]+                             -- ^ The binders of the RHS of the record field pattern+                             -- (in practice, always a singleton: see Note [Collecting implicit binders])+                         }++lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+                -> [(SrcSpan, [ImplicitFieldBinders])]+lStmtsImplicits = hs_lstmts+  where+    hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+              -> [(SrcSpan, [ImplicitFieldBinders])]+    hs_lstmts = concatMap (hs_stmt . unLoc)++    hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))+            -> [(SrcSpan, [ImplicitFieldBinders])]+    hs_stmt (BindStmt _ pat _) = lPatImplicits pat+    hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of+        GhcRn -> hs_applicative_stmt x+        GhcTc -> hs_applicative_stmt x+    hs_stmt (LetStmt _ binds)     = hs_local_binds binds+    hs_stmt (BodyStmt {})         = []+    hs_stmt (LastStmt {})         = []+    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss]+    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts+    hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss++    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds+    hs_local_binds (HsIPBinds {})           = []+    hs_local_binds (EmptyLocalBinds _)      = []++    hs_applicative_stmt (ApplicativeStmt _ args _) = concatMap do_arg args+      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat+            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts++hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)+                    -> [(SrcSpan, [ImplicitFieldBinders])]+hsValBindsImplicits (XValBindsLR (NValBinds binds _))+  = concatMap (lhsBindsImplicits . snd) binds+hsValBindsImplicits (ValBinds _ binds _)+  = lhsBindsImplicits binds++lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])]+lhsBindsImplicits = concatMap (lhs_bind . unLoc)+  where+    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat+    lhs_bind _ = []++-- | Collect all record wild card binders in the given pattern.+--+-- These are all the variables bound in all (possibly nested) record wildcard patterns+-- appearing inside the pattern.+--+-- See Note [Collecting implicit binders].+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+lPatImplicits = hs_lpat+  where+    hs_lpat lpat = hs_pat (unLoc lpat)++    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []++    hs_pat (LazyPat _ pat)      = hs_lpat pat+    hs_pat (BangPat _ pat)      = hs_lpat pat+    hs_pat (AsPat _ _ pat)      = hs_lpat pat+    hs_pat (ViewPat _ _ pat)    = hs_lpat pat+    hs_pat (ParPat _ pat)       = hs_lpat pat+    hs_pat (ListPat _ pats)     = hs_lpats pats+    hs_pat (TuplePat _ pats _)  = hs_lpats pats+    hs_pat (SigPat _ pat _)     = hs_lpat pat++    hs_pat (ConPat {pat_args=ps}) = details ps++    hs_pat _ = []++    details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+    details (PrefixCon ps) = hs_lpats ps+    details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))+      = hs_lpats $ map (hfbRHS . unLoc) rec_flds+    details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))+          = [(l2l err_loc, implicit_field_binders)]+          ++ hs_lpats explicit_pats++          where (explicit_pats, implicit_field_binders)+                  = rec_field_expl_impl rec_flds rec_dotdot++    details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2++lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)]+                      -> RecFieldsDotDot+                      -> [ImplicitFieldBinders]+lHsRecFieldsImplicits rec_flds rec_dotdot+  = snd $ rec_field_expl_impl rec_flds rec_dotdot++rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)]+                    -> RecFieldsDotDot+                    -> ([LPat GhcRn], [ImplicitFieldBinders])+rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })+  = ( map (hfbRHS . unLoc) explicit_binds+    , map implicit_field_binders implicit_binds )+  where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds+        implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))+          = ImplicitFieldBinders+              { implFlBndr_field   = unLoc $ foLabel (fld :: FieldOcc GhcRn)+              , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
+ GHC/HsToCore.hs view
@@ -0,0 +1,787 @@+{-# 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.DynFlags+import GHC.Driver.Config+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )+import GHC.Driver.Config.HsToCore.Ticks+import GHC.Driver.Env+import GHC.Driver.Backend+import GHC.Driver.Plugins++import GHC.Hs++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.Types.Origin ( Position(..), mkArgPos )+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.Predicate( scopedSort, mkNomEqPred )+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.Maybe    ( expectJust )+import GHC.Data.OrdList+import GHC.Data.SizedSeq ( sizeSS )++import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Logger++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( mkRepPolyIdConcreteTyVars )+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 GHC.Iface.Make (mkRecompUsageInfo)+import GHC.Runtime.Interpreter (interpreterProfiled)++{-+************************************************************************+*                                                                      *+*              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_rdr_env      = rdr_env,+                            tcg_fix_env      = fix_env,+                            tcg_inst_env     = inst_env,+                            tcg_fam_inst_env = fam_inst_env,+                            tcg_warns        = warns,+                            tcg_anns         = anns,+                            tcg_binds        = binds,+                            tcg_imp_specs    = imp_specs,+                            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_default_exports = defaults,+                            tcg_insts        = insts,+                            tcg_fam_insts    = fam_insts,+                            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+              -- See Note [Named default declarations] in GHC.Tc.Gen.Default++        ; (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)+        ; let modBreaks+                | Just (_, specs) <- m_tickInfo+                , breakpointsAllowed dflags+                = Just $ mkModBreaks (interpreterProfiled $ hscInterp hsc_env) mod specs+                | otherwise+                = Nothing++        ; 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++        ; (msgs, mb_res) <- initDs hsc_env tcg_env $+                       do { dsEvBinds ev_binds $ \ ds_ev_binds -> do+                          { 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 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)++        ; safe_mode <- finalSafeMode dflags tcg_env++        ; usages <- mkRecompUsageInfo hsc_env tcg_env++        -- 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_rdr_env      = rdr_env,+                mg_fix_env      = fix_env,+                mg_warns        = warns,+                mg_anns         = anns,+                mg_tcs          = tcs,+                mg_defaults     = defaults,+                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)+        }}}}++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 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 (addRulesToId rule_base . add_export_flag)+        -- addRulesToId: see Note [Attach rules to local ids]+        -- NB: the binder might have some existing rules,+        -- arising from specialisation pragmas++  where++    ---------- Rules --------+    rule_base = extendRuleBaseList emptyRuleBase rules++    ---------- Export flag --------+    -- See Note [Adding export flags]+    add_export_flag bndr+        | dont_discard bndr = setIdExported bndr+        | otherwise         = bndr++    dont_discard :: Id -> Bool+    dont_discard bndr = is_exported name+                     || name `elemNameSet` keep_alive+       where+         name = idName bndr++        -- 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_bndrs = RuleBndrs { rb_ext = bndrs }+                      , rd_lhs  = lhs+                      , rd_rhs  = rhs }))+  = putSrcSpanDs (locA loc) $+    do  { let bndrs' = scopedSort bndrs+                 -- The scopedSort is because the binders may not+                 -- be in dependency order; see wrinkle (FTV1) in+                 -- Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type++        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $+                  unsetWOptM Opt_WarnIdentities     $+                  zapUnspecables                    $+                  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 #-}++Finally, the `zapUnspecables` is to implement (NC1) of+Note [Desugaring non-canonical evidence] in GHC.HsToCore.Expr++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]+                 , mkNomEqPred 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 = mkGReflMCo Representational openAlphaTy 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++             concs = mkRepPolyIdConcreteTyVars+                     [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)]+                     unsafeCoercePrimName++             id   = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info+       ; return (id, old_expr) }
+ GHC/HsToCore/Arrows.hs view
@@ -0,0 +1,1259 @@+{-# 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 <- newSysLocalMDs (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 <- newSysLocalMDs a_ty+    b_var <- newSysLocalMDs b_ty+    pair_var <- newSysLocalMDs (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 <- newSysLocalMDs a_ty+    b_var <- newSysLocalMDs b_ty+    pair_var <- newSysLocalMDs (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 :: Id -> [Id] -> CoreExpr -> DsM CoreExpr+coreCaseTuple scrut_var vars body+  = mkBigTupleCase 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+    tup_var <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)+    match_env <- coreCaseTuple tup_var env_ids body+    pair_id <- newSysLocalMDs (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+    tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)+    tup_case <- coreCaseTuple tup_id env_ids body+    return (Lam tup_id tup_case)++----------------------------------------------+--              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 <- newSysLocalMDs (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) ManyTy 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   <- newSysLocalMDs 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   <- newSysLocalMDs 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 <- newSysLocalMDs stack_ty+    arg_id <- newSysLocalMDs 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 (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   <- newSysLocalMDs 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 <- newSysLocalMDs 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 (ArrowMatchCtxt ArrowCaseAlt) 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+        (HsCmdLam _ LamSingle (MG { mg_alts+          = (L _ [L _ (Match { m_pats  = L _ 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+      (HsCmdLam _ lam_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )+      env_ids = do+    arg_ids <- newSysLocalsDs arg_tys++    let match_ctxt = ArrowLamAlt lam_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 <- newSysLocalMDs 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 <- newSysLocalsMDs pat_tys+    stack_id' <- newSysLocalMDs 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 <- newSysLocalMDs 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+    dsHsWrapper wrap $ \core_wrap ->+      return (core_wrap core_cmd, env_ids')++-- 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 <- newSysLocalMDs 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 <- newSysLocalsMDs pat_tys+    stack_id' <- newSysLocalMDs 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'+        lam_cxt = ArrowMatchCtxt (ArrowLamAlt LamSingle)++    fail_expr <- mkFailExpr lam_cxt in_ty'+    -- match the patterns against the parameters+    match_code <- matchSimplys (map Var param_ids) lam_cxt 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 noExtField+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+      right_expr ty1 ty2 e = noLocA $ HsApp noExtField+                         (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 (HsLam noAnn LamCase+        (MG { mg_alts = noLocA []+            , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty (Generated OtherExpansion SkipPmc)+            }))++      -- 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 <- newSysLocalMDs 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 <- newSysLocalMDs env_ty2+    let+       after_c_ty = mkCorePairTy pat_ty env_ty2+       out_ty = mkBigCoreVarTupTy out_ids+    body_expr <- coreCaseTuple 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))) ManyTy pat body_expr fail_expr+    pair_id   <- newSysLocalMDs 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)++    env2_id <- newSysLocalMDs env2_ty+    let+        later_ty = mkBigCoreVarTupTy later_ids+        post_pair_ty = mkCorePairTy later_ty env2_ty+    post_loop_body <- coreCaseTuple 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 <- newSysLocalMDs 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+             -> HsMatchContextRn        -- 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 ManyTy 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 = L _ 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) <- toList 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 = noExtField, 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
+ GHC/HsToCore/Binds.hs view
@@ -0,0 +1,1854 @@++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# 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+   , dsImpSpecs, decomposeRuleLhs+   , dsHsWrapper, dsHsWrappers+   , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds+   , dsWarnOrphanRule+   )+where++import GHC.Prelude++import GHC.Driver.DynFlags+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.Pmc.Utils( tracePm )++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+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.InstEnv ( CanonicalEvidence(..) )+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.Rules+import GHC.Core.Ppr( pprCoreBinders )+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.Id.Info+import GHC.Types.Name+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var( EvVar, mkLocalVar )+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 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 (null unlifted_binds) || not (null bang_binds)+  = do { mapM_ (top_level_err UnliftedTypeBinds) unlifted_binds+       ; mapM_ (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 = filter (isUnliftedHsBind . unLoc) binds+    bang_binds     = filter (isBangedHsBind   . unLoc) binds++    top_level_err bindsType (L loc bind)+      = putSrcSpanDs (locA loc) $+        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)+{-+Note [Return non-recursive bindings in dependency order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For recursive bindings, the desugarer has no choice: it returns a single big+Rec{...} group.++But for /non-recursive/ bindings, the desugarer guarantees to desugar them to+a sequence of non-recurive Core bindings, in dependency order.++Why is this important?  Partly it saves a bit of work in the first run of the+occurrence analyser. But more importantly, for linear types, non-recursive lets+can be linear whereas recursive-let can't. Since we check the output of the+desugarer for linearity (see also Note [Linting linearity]), desugaring+non-recursive lets to recursive lets would break linearity checks. An+alternative is to refine the typing rule for recursive lets so that we don't+have to care (see in particular #23218 and #18694), but the outcome of this line+of work is still unclear. In the meantime, being a little precise in the+desugarer is cheap. (paragraph written on 2023-06-09)++In dsLHSBinds (and dependencies), a single binding can be desugared to multiple+bindings. For instance because the source binding has the {-# SPECIALIZE #-}+pragma. In:++f _ = …+ where+  {-# SPECIALIZE g :: F Int -> F Int #-}+  g :: C a => F a -> F a+  g _ = …++The g binding desugars to++let {+  $sg = … } in++  g+  [RULES: "SPEC g" g @Int $dC = $sg]+  g = …++In order to avoid generating a letrec that will immediately be reordered, we+make sure to return the binding in dependency order [$sg, g].++-}++-- | 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]+--+-- Invariant: the desugared bindings are returned in dependency order,+-- see Note [Return non-recursive bindings in dependency order]+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBinds binds+  = do { ds_bs <- mapM dsLHsBind binds+       ; return (foldr (\(a, a') (b, b') -> (a ++ b, a' ++ b'))+                         ([], []) 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).+--+-- Invariant: the desugared bindings are returned in dependency order,+-- see Note [Return non-recursive bindings in dependency order]+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)+                           })+ = dsHsWrapper co_fn $ \core_wrap ->+   do { (args, body) <- matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches++      ; 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 PatBindRhs 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 }))+  = addTyCs FromSource (listToBag dicts) $+             -- addTyCs: push type constraints deeper+             --            for inner pattern match check+             -- See Check, Note [Long-distance information]+    dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do+    do { ds_binds <- dsLHsBinds binds+         -- dsAbsBinds does the hard work+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds+                    (isSingleton 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 source binding+           -> Bool                      -- Single binding with signature+           -> DsM ([Id], [(Id,CoreExpr)])++dsAbsBinds dflags tyvars dicts exports+           ds_ev_binds (force_vars, bind_prs) is_singleton 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 { dsHsWrapper wrap $ \core_wrap -> do -- 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', fromOL spec_binds ++ [main_bind]) } }++    -- 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+    --+    -- See Note [The no-tyvar no-dict case]+  | null tyvars, null dicts+  = do { let wrap_first_bind f ((main, main_rhs):other_binds) =+               ((main, f main_rhs):other_binds)+             wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list"++             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 { dsHsWrapper wrap $ \core_wrap -> do+                    { return ( gbl_id `setInlinePragma` defaultInlinePragma+                             , core_wrap (Var lcl_id)) } }+       ; main_prs <- mapM mk_main exports+       ; let bind_prs' = map mk_aux_bind bind_prs+             -- When there's a single source binding, we wrap the evidence binding in a+             -- separate let-rec (DSB1) inside the first desugared binding (DSB2).+             -- See Note [The no-tyvar no-dict case].+             final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs'+                       | otherwise = flattenBinds ds_ev_binds ++ bind_prs'+       ; return (force_vars, final_prs ++ main_prs ) }++    -- The general case+    -- See Note [Desugaring AbsBinds]+  | otherwise+  = do { let aux_binds = Rec (map mk_aux_bind 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 <- newSysLocalMDs (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 [ABExport wrapper] in "GHC.Hs.Binds"+                = do { tup_id  <- newSysLocalMDs tup_ty+                     ; dsHsWrapper wrap $ \core_wrap -> do+                     { 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 (fromOL spec_binds ++ [(global', rhs)]) } }++       ; 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_bind :: (Id,CoreExpr) -> (Id,CoreExpr)+    mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id+                                                   `orElse` lcl_id+                                 in+                                 makeCorePair dflags lcl_w_inline False 0 rhs++    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 <- newSysLocalMDs+                     (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 [The no-tyvar no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are desugaring+    AbsBinds { tyvars   = []+             , dicts    = []+             , exports  = [ ABE f fm, ABE g gm ]+             , binds    = B+             , ev_binds = EB }+That is: no type variables or dictionary abstractions.  Here, `f` and `fm` are+the polymorphic and monomorphic versions of `f`; in this special case they will+both have the same type.++Specialising Note [Desugaring AbsBinds] for this case gives the desugaring++    tup = letrec EB' in letrec B' in (fm,gm)+    f = case tup of { (fm,gm) -> fm }+    g = case tup of { (fm,gm) -> fm }++where B' is the result of desugaring B. This desugaring is a little silly: we+don't need the intermediate tuple (contrast with the general case where fm and f+have different types). So instead, in this case, we desugar to++    EB'; B'; f=fm; g=gm++This is done in the `null tyvars, null dicts` case of `dsAbsBinds`.++But there is a wrinkle (DSB1).  If the original binding group was+/non-recursive/, we want to return a bunch of non-recursive bindings in+dependency order: see Note [Return non-recursive bindings in dependency order].++But there is no guarantee that EB', the desugared evidence bindings, will be+non-recursive.  Happily, in the non-recursive case, B will have just a single+binding (f = rhs), so we can wrap EB' around its RHS, thus:++   fm = letrec EB' in rhs; f = fm++There is a sub-wrinkle (DSB2).  If B is a /pattern/ bindings, it will desugar to+a "main" binding followed by a bunch of selectors. The main binding always+comes first, so we can pick it out and wrap EB' around its RHS.  For example++    AbsBinds { tyvars   = []+             , dicts    = []+             , exports  = [ ABE p pm, ABE q qm ]+             , binds    = PatBind (pm, Just qm) rhs+             , ev_binds = EB }++can desguar to++   pt = let EB' in+        case rhs of+          (pm,Just qm) -> (pm,qm)+   pm = case pt of (pm,qm) -> pm+   qm = case pt of (pm,qm) -> qm++   p = pm+   q = qm++The first three bindings come from desugaring the PatBind, and subsequently+wrapping the RHS of the main binding in EB'.++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.++Wrinkle 1: forcing linear variables++Consider++  let %1 !x = rhs in <body>+==>+  let x = rhs in x `seq` <body>++In the desugared version x is used in both arguments of seq. This isn't+recognised a linear. So we can't strictly speaking use seq. Instead, the code is+really desugared as++  let x = rhs in case x of x { _ -> <body> }++The shadowing with the case-binder is crucial. The linear linter (see+Note [Linting linearity] in GHC.Core.Lint) understands this as linear. This is+what the seqVar function does.++To be more precise, suppose x has multiplicity p, the fully annotated seqVar (in+Core, p is really stored inside x) is++  case x of %p x { _ -> <body> }++In linear Core, case u of %p y { _ -> v } consumes u with multiplicity p, and+makes y available with multiplicity p in v. Which is exactly what we want.++Wrinkle 2: linear patterns++Consider the following linear binding (linear lets are always non-recursive):++  let+     %1 f : g = rhs+  in <body>++The general case would desugar it to++  let t = let tm = rhs+              fm = case tm of fm:_ -> fm+              gm = case tm of _:gm -> gm+           in+           (tm, fm, gm)++  in let f = case t a of (_,fm,_) -> fm+  in let g = case t a of (_,_,gm) -> gm+  in let tm = case t a of (tm,_,_) -> tm+  in tm `seq` <body>++But all the case expression drop variables, which is prohibited by+linearity. But because this is a non-recursive let (in particular we're+desugaring a single binding), we can (and do) desugar the binding as a simple+case-expression instead:++  case rhs of {+    (f:g) -> <body>+  }++This is handled by the special case: a non-recursive PatBind in+GHC.HsToCore.Expr.ds_val_bind.++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.++Note [Desugaring new-form SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker,+which is desugared in this module by `dsSpec`.  For the context see+Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig++Suppose we have+  f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ...+  f = rhs+  {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-}++The type-checker generates `the_call` which looks like++  spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r)+  the_call = let d6 = dx1+                 d2 = $fOrdList d6+                 d3 = $fEqList $fEqInt+                 d7 = dx1   -- Solver may introduce+                 d1 = d7    -- these indirections+                 d4 = $fIxPair dx2 dx3+             in f @p @p @[Int] @(q,r)+                  (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r)++We /could/ generate+   RULE  f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4+   $sf d1 d2 d3 d4 = <rhs> d1 d2 d3 d4++But that would do no specialisation at all! What we want is this:+   RULE  f d1 _d2 _d3 d4 e1..en = $sf d1 d4+   $sf d1 d4 =  let d7 = d1   -- Renaming+                    dx1 = d1  -- Renaming+                    d6 = d1   -- Renaming+                    d2 = $fOrdList d6+                    d3 = $fEqList $fEqInt+                in rhs d1 d2 d3 d4++Notice that:+  * We pass some, but not all, of the matched dictionaries to $sf++  * We get specialisations for d2 and d3, but not for d1, nor d4.++  * We had to introduce some renaming bindings at the top+    to line things up++The transformation goes in these steps++(S1) decomposeCall: decompose `the_call` into+     - `binds`: the enclosing let-bindings+     - `rule_lhs_args`: the arguments of the call itself++  If the expression in the SPECIALISE pragma had a type signature, such as+     SPECIALISE g :: Eq b => Int -> b -> b+  then the desugared expression may have type abstractions and applications+  "in the way", like this:+     (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)+  The lambdas come from the type signature, which is then re-instantiated,+  hence the applications of those lambdas.++  To handle these, `decomposeCall` uses the simple optimiser to simplify+  this to+     let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d++  Wrinkle (S1a): do no inlining in this "simple optimiser" phase:+  use `simpleOptExprNoInline`. E.g. we don't want to turn it into+     f @Int @b $dfOrdInt d2+  because the latter is harder to match. Similarly if we have+     let { d1=d; d2=d } in f d1 d2+  we don't want to inline d1/d2 to get this+     f d d++  TL;DR: as a result the dictionary arguments of the actual call,+    `rule_lhs_args` are all distinct dictionary variables, not+    expressions.++(S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which+   will be the forall'd template variables of the RULE.  In the example,+       rule_bndrs = d1,d2,d3,d4+   These variables will get values from a successful RULE match.++(S3) `getRenamings`: starting from the rule_bndrs, make bindings for+   all other variables that are equal to them.  In the example, we+   make renaming-bindings for d7, dx1, d6.  Our goal is to bind+   as many variables as possible, by deducing them from `rule_bndrs`.+   If we have the binding+     d1 = d7  (where `d1` is a rule_bndr)+   we want to generate the renaming+     d7 = d1+   which instead deduces d7 from d1++   NB1: we don't actually have to remove the original bindings;+        it's harmless to leave them+   NB2: We also reverse bindings like  d1 = d2 |> co, to get+           d2 = d1 |> sym co+        It's easy and slightly improves our ability to get bindings+        for local variables from `rule_bndrs`. I'm not sure if it+        matters in practice, but it's easy to do.+   NB3: `getRenamings` works innermost first, so that we get transitivity.+        E.g in our example we have+                 d7 = dx1+                 d1 = d7     where d1 is rule_bndr+        `getRenamings` generate the renamings+                 dx1 = d1+                 d7 = d2++(S4) `pickSpecBinds`: pick the bindings we want to keep in the+   specialised function.  We start from `known_vars`, the variables we+   know, namely the `rule_bndrs` and the binders from (S3), which are+   all equal to one of the `rule_bndrs`.++   Then we keep a binding if the free vars of its RHS are all known.+   In our example, `d2` and `d3` are both picked, but `d4` is not.+   The non-picked ones won't end up being specialised.++(S5) Finally, work out which of the `rule_bndrs` we must pass on to+   specialised function. We just filter out ones bound by a renaming+   or a picked binding.+-}++------------------------+dsSpecs :: CoreExpr     -- Its rhs+        -> TcSpecPrags+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids+               , [CoreRule] )           -- Rules for the Global Ids+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig+dsSpecs _ IsDefaultMethod = return (nilOL, [])+dsSpecs poly_rhs (SpecPrags sps)+  = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps+       ; let (spec_binds_s, rules) = unzip pairs+       ; return (concatOL spec_binds_s, rules) }++dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM spec_one imp_specs+      ; let (spec_binds, spec_rules) = unzip spec_prs+      ; return (concatOL spec_binds, spec_rules) }+ where+   spec_one (L loc prag) = putSrcSpanDs loc $+                           dsSpec (get_rhs prag) prag++   get_rhs (SpecPrag poly_id _ _)              = get_rhs1 poly_id+   get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id++   get_rhs1 poly_id+    | 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++dsLSpec :: CoreExpr -> Located TcSpecPrag+        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsLSpec poly_rhs (L loc prag)+  = putSrcSpanDs loc $ dsSpec poly_rhs prag++dsSpec :: CoreExpr   -- RHS to be specialised+       -> TcSpecPrag+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)+  -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  | (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+  = dsHsWrapper spec_app $ \core_app ->+    dsSpec_help (idName poly_id) poly_id poly_rhs+                spec_inl spec_bndrs (core_app (Var poly_id))++dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm+                           , spe_fn_id = poly_id+                           , spe_inl   = spec_inl+                           , spe_bndrs = bndrs+                           , spe_call  = the_call })+  -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides]+                    unsetWOptM Opt_WarnIdentities     $+                    zapUnspecables $+                    dsLExpr the_call+       ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call }++dsSpec_help :: Name -> Id -> CoreExpr              -- Function to specialise+            -> InlinePragma -> [Var] -> CoreExpr+            -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call+  = do { -- Decompose the call+         -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas]+         mb_call_info <- decomposeCall poly_id ds_call+       ; case mb_call_info of {+            Nothing -> return Nothing ;+            Just (binds, rule_lhs_args) ->++    do { dflags   <- getDynFlags+       ; this_mod <- getModule+       ; uniq     <- newUnique+       ; let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds+             is_local :: Var -> Bool+             is_local v = v `elemVarSet` locals++             -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas]+             rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args)++             -- getRenamings: (S3) of  Note [Desugaring new-form SPECIALISE pragmas]+             rn_binds     = getRenamings orig_bndrs binds rule_bndrs++             -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas]+             known_vars   = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds+             picked_binds = pickSpecBinds is_local known_vars binds++             -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas]+             -- Make spec_bndrs, the variables to pass to the specialised+             -- function, by filtering out the rule_bndrs that aren't needed+             spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds)+                                   `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds)+             spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs++             mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds)  $+                                    mkApps fn_body rule_lhs_args+                                    -- NB: not mkCoreApps!  That uses exprType on fun+                                    --     which fails in specUnfolding, sigh++             poly_name  = idName poly_id+             spec_occ   = mkSpecOcc (getOccName poly_name)+             spec_name  = mkInternalName uniq spec_occ (getSrcSpan poly_name)+             id_inl     = idInlinePragma poly_id++             simpl_opts = initSimpleOpts dflags+             fn_unf     = realIdUnfolding poly_id+             spec_unf   = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf+             spec_info  = vanillaIdInfo+                          `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl+                          `setUnfoldingInfo`  spec_unf+             spec_id    = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info+                          -- Specialised binding is toplevel, hence Many.++             -- The RULE looks like+             --    RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs+             -- The specialised function looks like+             --    $sf spec_bndrs = mk_spec_body <f's original rhs>+             -- We also use mk_spec_body to specialise the methods in f's stable unfolding+             -- NB: spec_bindrs is a subset of rule_bndrs+             rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")+                               poly_id rule_bndrs rule_lhs_args+                               (mkVarApps (Var spec_id) spec_bndrs)++             rule_ty  = exprType (mkApps (Var poly_id) rule_lhs_args)+             spec_ty  = mkLamTypes spec_bndrs rule_ty+             spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)++             result = (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+       ; tracePm "dsSpec(new route)" $+         vcat [ text "poly_id" <+> ppr poly_id+              , text "unfolding" <+> ppr (realIdUnfolding poly_id)+              , text "orig_bndrs"   <+> pprCoreBinders orig_bndrs+              , text "locals" <+> ppr locals+              , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args)+              , text "ds_call" <+> ppr ds_call+              , text "binds" <+> ppr binds+              , text "rule_lhs_args" <+> ppr rule_lhs_args+              , text "rule_bndrs" <+> ppr rule_bndrs+              , text "spec_bndrs" <+> ppr spec_bndrs+              , text "rn_binds" <+> ppr rn_binds+              , text "picked_binds" <+> ppr picked_binds ]++       ; dsWarnOrphanRule rule++       ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs+                 no_act_spec spec_inl rule_act of+           Nothing -> return (Just result)++           Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason+                             ; if uselessSpecialisePragmaKeepAnyway reason+                               then return (Just result)+                               else return Nothing } } } }++  where+    -- 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+    id_inl        = idInlinePragma poly_id+    inl_prag_act  = inlinePragmaActivation id_inl+    spec_prag_act = inlinePragmaActivation spec_inl+    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 = inl_prag_act    -- Inherit+             | otherwise   = spec_prag_act   -- Specified by user++    is_dfun = case idDetails poly_id of+      DFunId {} -> True+      _ -> False++decomposeCall :: Id -> CoreExpr+              -> DsM (Maybe ([CoreBind], [CoreExpr] ))+-- Decompose the call into (let <binds> in f <args>)+-- See (S1) in Note [Desugaring new-form SPECIALISE pragmas]+decomposeCall poly_id ds_call+  = do { dflags  <- getDynFlags+       ; let simpl_opts = initSimpleOpts dflags+             core_call  = simpleOptExprNoInline simpl_opts ds_call+               -- simpleOptExprNoInline: see Wrinkle (S1a)!++       ; case go [] core_call of {+           Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)+                         ; return Nothing } ;+           Just result -> return (Just result) } }+  where+    go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr])+    go acc (Let bind body) = go (bind:acc) body+    go acc (Cast e _)      = go acc e  -- Discard outer casts+                                       -- ToDo: document this+    go acc e+      | (Var fun, args) <- collectArgs e+      = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $+        Just (reverse acc, args)+      | otherwise+      = Nothing++    -- Is this SPECIALISE pragma useless?+checkUselessSpecPrag :: Id -> [CoreExpr]+   -> [Var] -> Bool -> InlinePragma -> Activation+   ->  Maybe UselessSpecialisePragmaReason+checkUselessSpecPrag poly_id rule_lhs_args+                     spec_bndrs no_act_spec spec_inl rule_act+  | isJust (isClassOpId_maybe poly_id)+  -- 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+  = Just UselessSpecialiseForClassMethodSelector++  | no_act_spec, isNeverActive rule_act+  -- Function is NOINLINE, and the specialisation inherits that+  -- See Note [Activation pragmas for SPECIALISE]+  = Just UselessSpecialiseForNoInlineFunction++  | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl)+  -- The specialisation does nothing.+  -- But don't complain if it is SPECIALISE INLINE (#4444)+  = Just UselessSpecialiseNoSpecialisation++  | otherwise+  = Nothing++  where+    is_nop_arg (Type {})     = True+    is_nop_arg (Coercion {}) = True+    is_nop_arg (Cast e _)    = is_nop_arg e+    is_nop_arg (Tick _ e)    = is_nop_arg e+    is_nop_arg (Var x)       = x `elem` spec_bndrs+    is_nop_arg _             = False+++getRenamings :: [Var] -> [CoreBind]  -- orig_bndrs and bindings+             -> [Var]                -- rule_bndrs+             -> [CoreBind]           -- Binds some of the orig_bndrs to a rule_bndr+getRenamings orig_bndrs binds rule_bndrs+  = [ NonRec b e | b <- orig_bndrs+                 , not (b `elem` rule_bndrs)+                 , Just e <- [lookupVarEnv final_renamings b] ]+  where+    init_renamings, final_renamings :: IdEnv CoreExpr+    -- In this function, IdEnv maps a local variable to (v |> co),+    -- where `v` is a rule_bndr++    init_renamings = mkVarEnv [ (v, Var v) | v <- rule_bndrs, isId v ]+    final_renamings = go binds++    go :: [CoreBind] -> IdEnv CoreExpr+    go [] = init_renamings+    go (bind : binds)+       | NonRec b rhs <- bind+       , Just (v, mco) <- getCastedVar rhs+       , Just e <- lookupVarEnv renamings b+       = extendVarEnv renamings v (mkCastMCo e (mkSymMCo mco))+       | otherwise+       = renamings+       where+         renamings = go binds++pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]+pickSpecBinds _ _ [] = []+pickSpecBinds is_local known_bndrs (bind:binds)+      | all keep_me (rhssOfBind bind)+      , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind+      = bind : pickSpecBinds is_local known_bndrs' binds+      | otherwise+      = pickSpecBinds is_local known_bndrs binds+      where+        keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs)+        bad_var v = is_local v && not (v `elemVarSet` known_bndrs)++getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR)+getCastedVar (Var v)           = Just (v, MRefl)+getCastedVar (Cast (Var v) co) = Just (v, MCo co)+getCastedVar _                 = Nothing++specFunInlinePrag :: Id -> InlinePragma+                  -> InlinePragma -> InlinePragma+-- See Note [Activation pragmas for SPECIALISE]+specFunInlinePrag poly_id id_inl spec_inl+  | not (isDefaultInlinePragma spec_inl)    = spec_inl+  | isGlobalId poly_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++dsWarnOrphanRule :: CoreRule -> DsM ()+dsWarnOrphanRule rule+  = when (ruleIsOrphan 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 ->  -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+                    --                                   , text "orig_lhs:" <+> ppr orig_lhs+                    --                                   , text "rhs_fvs:" <+> ppr rhs_fvs+                    --                                   , text "lhs1:" <+> ppr lhs1+                    --                                   , text "lhs2:" <+> ppr lhs2+                    --                                   , text "fun2:" <+> ppr fun2+                    --                                   , text "args2:" <+> ppr args2+                    --                                   ]) $+                   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 "trimmed_bndrs:" <+> ppr trimmed_bndrs+            --                                   , text "extra_dicts:" <+> ppr extra_dicts+            --                                   , text "fn_id:" <+> ppr fn_id+            --                                   , text "args:"   <+> ppr args+            --                                   , text "args fvs:" <+> ppr (exprsFreeVarsList args)+            --                                   ]) $+            Right (trimmed_bndrs ++ extra_dicts, 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++                -- extra_dicts: see Note [Free dictionaries on rule LHS]+-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base+                extra_dicts+                  = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)+                    | d <- exprsSomeFreeVarsList is_extra args ]++                is_extra v+                  = isSimplePredTy (idType v)+                      -- isSimplePredTy: includes coercions and dictionaries+                      -- But NOT dictionary functions; and in particular not+                      -- superclass-selector fuctions++                    && 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)+     | isPredTy (idType d)+       -- isPredTy: catches dictionaries, yes, but also catches+       -- dictionary /functions/ arising from solving a+       -- quantified contraint (see #24370)+     = ((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.Sig, 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 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 of the binding doesn't+         mention one of the orig_bndrs, which we assume occur on RHS of+         the rule.  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* simplOptExpr, 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).+-}++dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a+dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)+dsHsWrappers []       k = k []++dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a+dsHsWrapper hs_wrap thing_inside+  = ds_hs_wrapper hs_wrap $ \ core_wrap ->+    addTyCs FromSource (hsWrapDictBinders hs_wrap) $+       -- addTyCs: Add type evidence to the refinement type+       --            predicate of the coverage checker+       --   See Note [Long-distance information] in "GHC.HsToCore.Pmc"+       -- 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.+    thing_inside core_wrap++ds_hs_wrapper :: HsWrapper+              -> ((CoreExpr -> CoreExpr) -> DsM a)+              -> DsM a+ds_hs_wrapper wrap = go wrap+  where+    go WpHole            k = k $ \e -> e+    go (WpTyApp ty)      k = k $ \e -> App e (Type ty)+    go (WpEvLam ev)      k = k $ Lam ev+    go (WpTyLam tv)      k = k $ Lam tv+    go (WpCast co)       k = assert (coercionRole co == Representational) $+                             k $ \e -> mkCastDs e co+    go (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm+                                ; k $ \e -> e `App` core_tm }+    go (WpLet ev_binds)  k = dsTcEvBinds ev_binds $ \bs ->+                             k (mkCoreLets bs)+    go (WpCompose c1 c2) k = go c1 $ \w1 ->+                             go c2 $ \w2 ->+                             k (w1 . w2)+    go (WpFun c1 c2 st)  k = -- See Note [Desugaring WpFun]+                             do { x <- newSysLocalDs st+                                ; go c1 $ \w1 ->+                                  go c2 $ \w2 ->+                                  let app f a = mkCoreApp (text "dsHsWrapper") f a+                                      arg     = w1 (Var x)+                                  in k (\e -> (Lam x (w2 (app e arg)))) }++--------------------------------------+dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a+dsTcEvBinds_s []       k = k []+dsTcEvBinds_s (b:rest) k = assert (null rest) $  -- Zonker ensures null+                           dsTcEvBinds b k++dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs++--   * Desugars the ev_binds, sorts them into dependency order, and+--     passes the resulting [CoreBind] to thing_inside+--   * Extends the DsM (dsl_unspecable field) with specialisability information+--     for each binder in ev_binds, before invoking thing_inside+dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a+dsEvBinds ev_binds thing_inside+  = do { ds_binds <- mapBagM dsEvBind ev_binds+       ; let comps = sort_ev_binds ds_binds+       ; go comps thing_inside }+  where+    go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a+    go (comp:comps) thing_inside+      = do { unspecables <- getUnspecables+           ; let (core_bind, new_unspecables) = ds_component unspecables comp+           ; addUnspecables new_unspecables $ go comps $ \ core_binds ->+               thing_inside (core_bind:core_binds) }+    go [] thing_inside = thing_inside []++    ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)+      where+        ((v, rhs), (this_canonical, deps)) = unpack_node node+        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> [v]+                        | otherwise               -> []+              where+                transitively_unspecable = is_unspecable this_canonical+                                          || any (`elemVarSet` unspecs) deps++    ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)+      where+        (pairs, direct_canonicity) = unzip $ map unpack_node nodes++        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> map fst pairs+                        | otherwise               -> []+              where+                 transitively_unspecable+                   = or [ is_unspecable this_canonical+                          || any (`elemVarSet` unspecs) deps+                        | (this_canonical, deps) <- direct_canonicity ]+            -- Bindings from a given SCC are transitively specialisable if+            -- all are specialisable and all their remote dependencies are+            -- also specialisable; see Note [Desugaring non-canonical evidence]++    unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }+       = ((v, rhs), (canonical, deps))++    is_unspecable :: CanonicalEvidence -> Bool+    is_unspecable EvNonCanonical = True+    is_unspecable EvCanonical    = False++sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]+-- 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.+sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges+  where+    edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ]+    edges = foldr ((:) . mk_node) [] ds_binds++    mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr)+    mk_node (var, canonical, rhs)+      = DigraphNode { node_payload = (canonical, rhs)+                    , node_key = var+                    , node_dependencies = nonDetEltsUniqSet $+                                          exprFreeVars rhs `unionVarSet`+                                          coVarsOfType (varType var) }+      -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq+      -- is still deterministic even if the edges are in nondeterministic order+      -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.++dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr)+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do+    e <- dsEvTerm r+    let canonical = case info of+            EvBindGiven{} -> EvCanonical+            EvBindWanted{ ebi_canonical = canonical } -> canonical+    return (v, canonical, e)+++{-**********************************************************************+*                                                                      *+           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 { dsTcEvBinds ev_binds $ \ds_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+       ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName+                    -- mkTrAppChecked :: 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 mkTrAppChecked) [ k1, k2, t1, t2 ])+                            [ e1, e2 ]+       -- ; pprRuntimeTrace "Trace mkTrAppChecked" (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.Instance.Class+    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)
+ GHC/HsToCore/Binds.hs-boot view
@@ -0,0 +1,6 @@+module GHC.HsToCore.Binds where+import GHC.HsToCore.Monad ( DsM )+import GHC.Core           ( CoreExpr )+import GHC.Tc.Types.Evidence    (HsWrapper)++dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
+ GHC/HsToCore/Breakpoints.hs view

file too large to diff

+ GHC/HsToCore/Coverage.hs view

file too large to diff

+ GHC/HsToCore/Docs.hs view

file too large to diff

+ GHC/HsToCore/Errors/Ppr.hs view

file too large to diff

+ GHC/HsToCore/Errors/Types.hs view

file too large to diff

+ GHC/HsToCore/Expr.hs view

file too large to diff

+ GHC/HsToCore/Expr.hs-boot view

file too large to diff

+ GHC/HsToCore/Foreign/C.hs view

file too large to diff

+ GHC/HsToCore/Foreign/Call.hs view

file too large to diff

+ GHC/HsToCore/Foreign/Decl.hs view

file too large to diff

+ GHC/HsToCore/Foreign/JavaScript.hs view

file too large to diff

+ GHC/HsToCore/Foreign/Prim.hs view

file too large to diff

+ GHC/HsToCore/Foreign/Utils.hs view

file too large to diff

+ GHC/HsToCore/Foreign/Wasm.hs view

file too large to diff

+ GHC/HsToCore/GuardedRHSs.hs view

file too large to diff

+ GHC/HsToCore/ListComp.hs view

file too large to diff

+ GHC/HsToCore/Match.hs view

file too large to diff

+ GHC/HsToCore/Match.hs-boot view

file too large to diff

+ GHC/HsToCore/Match/Constructor.hs view

file too large to diff

+ GHC/HsToCore/Match/Literal.hs view

file too large to diff

+ GHC/HsToCore/Monad.hs view

file too large to diff

− GHC/HsToCore/PmCheck.hs

file too large to diff

− GHC/HsToCore/PmCheck/Oracle.hs

file too large to diff

− GHC/HsToCore/PmCheck/Ppr.hs

file too large to diff

− GHC/HsToCore/PmCheck/Types.hs

file too large to diff

− GHC/HsToCore/PmCheck/Types.hs-boot

file too large to diff

+ GHC/HsToCore/Pmc.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Check.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Desugar.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Ppr.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Solver.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Solver/Types.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Types.hs view

file too large to diff

+ GHC/HsToCore/Pmc/Utils.hs view

file too large to diff

+ GHC/HsToCore/Quote.hs view

file too large to diff

+ GHC/HsToCore/Ticks.hs view

file too large to diff

+ GHC/HsToCore/Types.hs view

file too large to diff

+ GHC/HsToCore/Usage.hs view

file too large to diff

+ GHC/HsToCore/Utils.hs view

file too large to diff

+ GHC/Iface/Binary.hs view

file too large to diff

+ GHC/Iface/Decl.hs view

file too large to diff

+ GHC/Iface/Env.hs view

file too large to diff

+ GHC/Iface/Env.hs-boot view

file too large to diff

+ GHC/Iface/Errors.hs view

file too large to diff

+ GHC/Iface/Errors/Ppr.hs view

file too large to diff

+ GHC/Iface/Errors/Types.hs view

file too large to diff

+ GHC/Iface/Ext/Ast.hs view

file too large to diff

+ GHC/Iface/Ext/Binary.hs view

file too large to diff

+ GHC/Iface/Ext/Debug.hs view

file too large to diff

+ GHC/Iface/Ext/Fields.hs view

file too large to diff

+ GHC/Iface/Ext/Types.hs view

file too large to diff

+ GHC/Iface/Ext/Utils.hs view

file too large to diff

+ GHC/Iface/Flags.hs view

file too large to diff

+ GHC/Iface/Load.hs view

file too large to diff

+ GHC/Iface/Load.hs-boot view

file too large to diff

+ GHC/Iface/Make.hs view

file too large to diff

+ GHC/Iface/Recomp.hs view

file too large to diff

+ GHC/Iface/Recomp/Binary.hs view

file too large to diff

+ GHC/Iface/Recomp/Flags.hs view

file too large to diff

+ GHC/Iface/Recomp/Types.hs view

file too large to diff

+ GHC/Iface/Rename.hs view

file too large to diff

+ GHC/Iface/Syntax.hs view

file too large to diff

+ GHC/Iface/Tidy.hs view

file too large to diff

+ GHC/Iface/Tidy/StaticPtrTable.hs view

file too large to diff

+ GHC/Iface/Type.hs view

file too large to diff

+ GHC/Iface/Type.hs-boot view

file too large to diff

+ GHC/Iface/Warnings.hs view

file too large to diff

+ GHC/IfaceToCore.hs view

file too large to diff

+ GHC/IfaceToCore.hs-boot view

file too large to diff

+ GHC/JS/Ident.hs view

file too large to diff

+ GHC/JS/JStg/Monad.hs view

file too large to diff

+ GHC/JS/JStg/Syntax.hs view

file too large to diff

+ GHC/JS/Make.hs view

file too large to diff

+ GHC/JS/Opt/Expr.hs view

file too large to diff

+ GHC/JS/Opt/Simple.hs view

file too large to diff

+ GHC/JS/Optimizer.hs view

file too large to diff

+ GHC/JS/Ppr.hs view

file too large to diff

+ GHC/JS/Syntax.hs view

file too large to diff

+ GHC/JS/Transform.hs view

file too large to diff

+ GHC/Linker/Config.hs view

file too large to diff

+ GHC/Linker/Deps.hs view

file too large to diff

+ GHC/Linker/Dynamic.hs view

file too large to diff

+ GHC/Linker/External.hs view

file too large to diff

+ GHC/Linker/ExtraObj.hs view

file too large to diff

+ GHC/Linker/Loader.hs view

file too large to diff

+ GHC/Linker/MacOS.hs view

file too large to diff

+ GHC/Linker/Static.hs view

file too large to diff

+ GHC/Linker/Static/Utils.hs view

file too large to diff

+ GHC/Linker/Types.hs view

file too large to diff

+ GHC/Linker/Unit.hs view

file too large to diff

+ GHC/Linker/Windows.hs view

file too large to diff

+ GHC/Llvm.hs view

file too large to diff

+ GHC/Llvm/MetaData.hs view

file too large to diff

+ GHC/Llvm/Ppr.hs view

file too large to diff

+ GHC/Llvm/Syntax.hs view

file too large to diff

+ GHC/Llvm/Types.hs view

file too large to diff

+ GHC/Parser.hs view

file too large to diff

+ GHC/Parser.hs-boot view

file too large to diff

+ GHC/Parser/Annotation.hs view

file too large to diff

+ GHC/Parser/CharClass.hs view

file too large to diff

+ GHC/Parser/Errors/Basic.hs view

file too large to diff

+ GHC/Parser/Errors/Ppr.hs view

file too large to diff

+ GHC/Parser/Errors/Types.hs view

file too large to diff

+ GHC/Parser/HaddockLex.hs view

file too large to diff

+ GHC/Parser/Header.hs view

file too large to diff

+ GHC/Parser/Lexer.hs view

file too large to diff

+ GHC/Parser/Lexer/Interface.hs view

file too large to diff

+ GHC/Parser/Lexer/String.hs view

file too large to diff

+ GHC/Parser/PostProcess.hs view

file too large to diff

+ GHC/Parser/PostProcess/Haddock.hs view

file too large to diff

+ GHC/Parser/String.hs view

file too large to diff

+ GHC/Parser/Types.hs view

file too large to diff

+ GHC/Parser/Utils.hs view

file too large to diff

+ GHC/Platform.hs view

file too large to diff

GHC/Platform/AArch64.hs view

file too large to diff

GHC/Platform/ARM.hs view

file too large to diff

+ GHC/Platform/LA64.hs view

file too large to diff

GHC/Platform/NoRegs.hs view

file too large to diff

GHC/Platform/PPC.hs view

file too large to diff

+ GHC/Platform/Profile.hs view

file too large to diff

+ GHC/Platform/RISCV64.hs view

file too large to diff

+ GHC/Platform/Reg.hs view

file too large to diff

+ GHC/Platform/Reg/Class.hs view

file too large to diff

+ GHC/Platform/Reg/Class/NoVectors.hs view

file too large to diff

+ GHC/Platform/Reg/Class/Separate.hs view

file too large to diff

+ GHC/Platform/Reg/Class/Unified.hs view

file too large to diff

GHC/Platform/Regs.hs view

file too large to diff

GHC/Platform/S390X.hs view

file too large to diff

− GHC/Platform/SPARC.hs

file too large to diff

+ GHC/Platform/Wasm32.hs view

file too large to diff

+ GHC/Platform/Ways.hs view

file too large to diff

GHC/Platform/X86.hs view

file too large to diff

GHC/Platform/X86_64.hs view

file too large to diff

+ GHC/Plugins.hs view

file too large to diff

+ GHC/Prelude.hs view

file too large to diff

+ GHC/Prelude/Basic.hs view

file too large to diff

+ GHC/Rename/Bind.hs view

file too large to diff

+ GHC/Rename/Doc.hs view

file too large to diff

+ GHC/Rename/Env.hs view

file too large to diff

+ GHC/Rename/Expr.hs view

file too large to diff

+ GHC/Rename/Expr.hs-boot view

file too large to diff

+ GHC/Rename/Fixity.hs view

file too large to diff

+ GHC/Rename/HsType.hs view

file too large to diff

+ GHC/Rename/Module.hs view

file too large to diff

+ GHC/Rename/Names.hs view

file too large to diff

+ GHC/Rename/Pat.hs view

file too large to diff

+ GHC/Rename/Splice.hs view

file too large to diff

+ GHC/Rename/Splice.hs-boot view

file too large to diff

+ GHC/Rename/Unbound.hs view

file too large to diff

+ GHC/Rename/Utils.hs view

file too large to diff

+ GHC/Runtime/Context.hs view

file too large to diff

+ GHC/Runtime/Debugger.hs view

file too large to diff

+ GHC/Runtime/Debugger/Breakpoints.hs view

file too large to diff

+ GHC/Runtime/Eval.hs view

file too large to diff

+ GHC/Runtime/Eval/Types.hs view

file too large to diff

+ GHC/Runtime/Eval/Utils.hs view

file too large to diff

+ GHC/Runtime/Heap/Inspect.hs view

file too large to diff

+ GHC/Runtime/Heap/Layout.hs view

file too large to diff

+ GHC/Runtime/Interpreter.hs view

file too large to diff

+ GHC/Runtime/Interpreter/JS.hs view

file too large to diff

+ GHC/Runtime/Interpreter/Process.hs view

file too large to diff

+ GHC/Runtime/Interpreter/Types.hs view

file too large to diff

+ GHC/Runtime/Interpreter/Types/SymbolCache.hs view

file too large to diff

+ GHC/Runtime/Interpreter/Wasm.hs view

file too large to diff

+ GHC/Runtime/Loader.hs view

file too large to diff

+ GHC/Runtime/Utils.hs view

file too large to diff

+ GHC/Settings.hs view

file too large to diff

+ GHC/Settings/Constants.hs view

file too large to diff

+ GHC/Settings/IO.hs view

file too large to diff

+ GHC/Stg/BcPrep.hs view

file too large to diff

+ GHC/Stg/CSE.hs view

file too large to diff

+ GHC/Stg/Debug.hs view

file too large to diff

+ GHC/Stg/EnforceEpt.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/Rewrite.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/TagSig.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/Types.hs view

file too large to diff

+ GHC/Stg/FVs.hs view

file too large to diff

+ GHC/Stg/Lift.hs view

file too large to diff

+ GHC/Stg/Lift/Analysis.hs view

file too large to diff

+ GHC/Stg/Lift/Config.hs view

file too large to diff

+ GHC/Stg/Lift/Monad.hs view

file too large to diff

+ GHC/Stg/Lift/Types.hs view

file too large to diff

+ GHC/Stg/Lint.hs view

file too large to diff

+ GHC/Stg/Make.hs view

file too large to diff

+ GHC/Stg/Pipeline.hs view

file too large to diff

+ GHC/Stg/Stats.hs view

file too large to diff

+ GHC/Stg/Subst.hs view

file too large to diff

+ GHC/Stg/Syntax.hs view

file too large to diff

+ GHC/Stg/Unarise.hs view

file too large to diff

+ GHC/Stg/Utils.hs view

file too large to diff

+ GHC/StgToByteCode.hs view

file too large to diff

GHC/StgToCmm.hs view

file too large to diff

GHC/StgToCmm/ArgRep.hs view

file too large to diff

GHC/StgToCmm/Bind.hs view

file too large to diff

GHC/StgToCmm/Bind.hs-boot view

file too large to diff

GHC/StgToCmm/CgUtils.hs view

file too large to diff

GHC/StgToCmm/Closure.hs view

file too large to diff

+ GHC/StgToCmm/Config.hs view

file too large to diff

GHC/StgToCmm/DataCon.hs view

file too large to diff

GHC/StgToCmm/Env.hs view

file too large to diff

GHC/StgToCmm/Expr.hs view

file too large to diff

GHC/StgToCmm/ExtCode.hs view

file too large to diff

GHC/StgToCmm/Foreign.hs view

file too large to diff

+ GHC/StgToCmm/Foreign.hs-boot view

file too large to diff

GHC/StgToCmm/Heap.hs view

file too large to diff

GHC/StgToCmm/Hpc.hs view

file too large to diff

+ GHC/StgToCmm/InfoTableProv.hs view

file too large to diff

GHC/StgToCmm/Layout.hs view

file too large to diff

+ GHC/StgToCmm/Lit.hs view

file too large to diff

GHC/StgToCmm/Monad.hs view

file too large to diff

GHC/StgToCmm/Prim.hs view

file too large to diff

GHC/StgToCmm/Prof.hs view

file too large to diff

+ GHC/StgToCmm/Sequel.hs view

file too large to diff

+ GHC/StgToCmm/TagCheck.hs view

file too large to diff

GHC/StgToCmm/Ticky.hs view

file too large to diff

+ GHC/StgToCmm/Types.hs view

file too large to diff

GHC/StgToCmm/Utils.hs view

file too large to diff

+ GHC/StgToJS.hs view

file too large to diff

+ GHC/StgToJS/Apply.hs view

file too large to diff

+ GHC/StgToJS/Arg.hs view

file too large to diff

+ GHC/StgToJS/Closure.hs view

file too large to diff

+ GHC/StgToJS/CodeGen.hs view

file too large to diff

+ GHC/StgToJS/DataCon.hs view

file too large to diff

+ GHC/StgToJS/Deps.hs view

file too large to diff

+ GHC/StgToJS/Expr.hs view

file too large to diff

+ GHC/StgToJS/ExprCtx.hs view

file too large to diff

+ GHC/StgToJS/FFI.hs view

file too large to diff

+ GHC/StgToJS/Heap.hs view

file too large to diff

+ GHC/StgToJS/Ids.hs view

file too large to diff

+ GHC/StgToJS/Linker/Linker.hs view

file too large to diff

+ GHC/StgToJS/Linker/Opt.hs view

file too large to diff

+ GHC/StgToJS/Linker/Types.hs view

file too large to diff

+ GHC/StgToJS/Linker/Utils.hs view

file too large to diff

+ GHC/StgToJS/Literal.hs view

file too large to diff

+ GHC/StgToJS/Monad.hs view

file too large to diff

+ GHC/StgToJS/Object.hs view

file too large to diff

+ GHC/StgToJS/Prim.hs view

file too large to diff

+ GHC/StgToJS/Profiling.hs view

file too large to diff

+ GHC/StgToJS/Regs.hs view

file too large to diff

+ GHC/StgToJS/Rts/Rts.hs view

file too large to diff

+ GHC/StgToJS/Rts/Types.hs view

file too large to diff

+ GHC/StgToJS/Sinker/Collect.hs view

file too large to diff

+ GHC/StgToJS/Sinker/Sinker.hs view

file too large to diff

+ GHC/StgToJS/Sinker/StringsUnfloat.hs view

file too large to diff

+ GHC/StgToJS/Stack.hs view

file too large to diff

+ GHC/StgToJS/StaticPtr.hs view

file too large to diff

+ GHC/StgToJS/Symbols.hs view

file too large to diff

+ GHC/StgToJS/Types.hs view

file too large to diff

+ GHC/StgToJS/Utils.hs view

file too large to diff

+ GHC/SysTools.hs view

file too large to diff

+ GHC/SysTools/Ar.hs view

file too large to diff

+ GHC/SysTools/BaseDir.hs view

file too large to diff

+ GHC/SysTools/Cpp.hs view

file too large to diff

+ GHC/SysTools/Elf.hs view

file too large to diff

+ GHC/SysTools/Process.hs view

file too large to diff

+ GHC/SysTools/Tasks.hs view

file too large to diff

+ GHC/SysTools/Terminal.hs view

file too large to diff

+ GHC/Tc/Deriv.hs view

file too large to diff

+ GHC/Tc/Deriv/Functor.hs view

file too large to diff

+ GHC/Tc/Deriv/Generate.hs view

file too large to diff

+ GHC/Tc/Deriv/Generics.hs view

file too large to diff

+ GHC/Tc/Deriv/Infer.hs view

file too large to diff

+ GHC/Tc/Deriv/Utils.hs view

file too large to diff

+ GHC/Tc/Errors.hs view

file too large to diff

+ GHC/Tc/Errors/Hole.hs view

file too large to diff

+ GHC/Tc/Errors/Hole.hs-boot view

file too large to diff

+ GHC/Tc/Errors/Hole/FitTypes.hs view

file too large to diff

+ GHC/Tc/Errors/Hole/Plugin.hs view

file too large to diff

+ GHC/Tc/Errors/Hole/Plugin.hs-boot view

file too large to diff

+ GHC/Tc/Errors/Ppr.hs view

file too large to diff

+ GHC/Tc/Errors/Types.hs view

file too large to diff

+ GHC/Tc/Errors/Types/PromotionErr.hs view

file too large to diff

+ GHC/Tc/Gen/Annotation.hs view

file too large to diff

+ GHC/Tc/Gen/App.hs view

file too large to diff

+ GHC/Tc/Gen/Arrow.hs view

file too large to diff

+ GHC/Tc/Gen/Bind.hs view

file too large to diff

+ GHC/Tc/Gen/Default.hs view

file too large to diff

+ GHC/Tc/Gen/Do.hs view

file too large to diff

+ GHC/Tc/Gen/Export.hs view

file too large to diff

+ GHC/Tc/Gen/Expr.hs view

file too large to diff

+ GHC/Tc/Gen/Expr.hs-boot view

file too large to diff

+ GHC/Tc/Gen/Foreign.hs view

file too large to diff

+ GHC/Tc/Gen/Head.hs view

file too large to diff

+ GHC/Tc/Gen/HsType.hs view

file too large to diff

+ GHC/Tc/Gen/Match.hs view

file too large to diff

+ GHC/Tc/Gen/Match.hs-boot view

file too large to diff

+ GHC/Tc/Gen/Pat.hs view

file too large to diff

+ GHC/Tc/Gen/Sig.hs view

file too large to diff

+ GHC/Tc/Gen/Splice.hs view

file too large to diff

+ GHC/Tc/Gen/Splice.hs-boot view

file too large to diff

+ GHC/Tc/Instance/Class.hs view

file too large to diff

+ GHC/Tc/Instance/Family.hs view

file too large to diff

+ GHC/Tc/Instance/FunDeps.hs view

file too large to diff

+ GHC/Tc/Instance/Typeable.hs view

file too large to diff

+ GHC/Tc/Module.hs view

file too large to diff

+ GHC/Tc/Module.hs-boot view

file too large to diff

+ GHC/Tc/Plugin.hs view

file too large to diff

+ GHC/Tc/Solver.hs view

file too large to diff

+ GHC/Tc/Solver/Default.hs view

file too large to diff

+ GHC/Tc/Solver/Dict.hs view

file too large to diff

+ GHC/Tc/Solver/Equality.hs view

file too large to diff

+ GHC/Tc/Solver/InertSet.hs view

file too large to diff

+ GHC/Tc/Solver/Irred.hs view

file too large to diff

+ GHC/Tc/Solver/Monad.hs view

file too large to diff

+ GHC/Tc/Solver/Rewrite.hs view

file too large to diff

+ GHC/Tc/Solver/Solve.hs view

file too large to diff

+ GHC/Tc/Solver/Solve.hs-boot view

file too large to diff

+ GHC/Tc/Solver/Types.hs view

file too large to diff

+ GHC/Tc/TyCl.hs view

file too large to diff

+ GHC/Tc/TyCl/Build.hs view

file too large to diff

+ GHC/Tc/TyCl/Class.hs view

file too large to diff

+ GHC/Tc/TyCl/Instance.hs view

file too large to diff

+ GHC/Tc/TyCl/Instance.hs-boot view

file too large to diff

+ GHC/Tc/TyCl/PatSyn.hs view

file too large to diff

+ GHC/Tc/TyCl/PatSyn.hs-boot view

file too large to diff

+ GHC/Tc/TyCl/Utils.hs view

file too large to diff

+ GHC/Tc/Types.hs view

file too large to diff

+ GHC/Tc/Types/BasicTypes.hs view

file too large to diff

+ GHC/Tc/Types/Constraint.hs view

file too large to diff

+ GHC/Tc/Types/CtLoc.hs view

file too large to diff

+ GHC/Tc/Types/ErrCtxt.hs view

file too large to diff

+ GHC/Tc/Types/Evidence.hs view

file too large to diff

+ GHC/Tc/Types/LclEnv.hs view

file too large to diff

+ GHC/Tc/Types/LclEnv.hs-boot view

file too large to diff

+ GHC/Tc/Types/Origin.hs view

file too large to diff

+ GHC/Tc/Types/Origin.hs-boot view

file too large to diff

+ GHC/Tc/Types/Rank.hs view

file too large to diff

+ GHC/Tc/Types/TH.hs view

file too large to diff

+ GHC/Tc/Types/TcRef.hs view

file too large to diff

+ GHC/Tc/Utils/Backpack.hs view

file too large to diff

+ GHC/Tc/Utils/Concrete.hs view

file too large to diff

+ GHC/Tc/Utils/Env.hs view

file too large to diff

+ GHC/Tc/Utils/Instantiate.hs view

file too large to diff

+ GHC/Tc/Utils/Monad.hs view

file too large to diff

+ GHC/Tc/Utils/TcMType.hs view

file too large to diff

+ GHC/Tc/Utils/TcMType.hs-boot view

file too large to diff

+ GHC/Tc/Utils/TcType.hs view

file too large to diff

+ GHC/Tc/Utils/TcType.hs-boot view

file too large to diff

+ GHC/Tc/Utils/Unify.hs view

file too large to diff

+ GHC/Tc/Utils/Unify.hs-boot view

file too large to diff

+ GHC/Tc/Validity.hs view

file too large to diff

+ GHC/Tc/Zonk/Env.hs view

file too large to diff

+ GHC/Tc/Zonk/Monad.hs view

file too large to diff

+ GHC/Tc/Zonk/TcType.hs view

file too large to diff

+ GHC/Tc/Zonk/Type.hs view

file too large to diff

GHC/ThToHs.hs view

file too large to diff

+ GHC/Types/Annotations.hs view

file too large to diff

+ GHC/Types/Avail.hs view

file too large to diff

+ GHC/Types/Basic.hs view

file too large to diff

+ GHC/Types/CompleteMatch.hs view

file too large to diff

+ GHC/Types/CostCentre.hs view

file too large to diff

+ GHC/Types/CostCentre/State.hs view

file too large to diff

+ GHC/Types/Cpr.hs view

file too large to diff

+ GHC/Types/DefaultEnv.hs view

file too large to diff

+ GHC/Types/Demand.hs view

file too large to diff

+ GHC/Types/Error.hs view

file too large to diff

+ GHC/Types/Error/Codes.hs view

file too large to diff

+ GHC/Types/FieldLabel.hs view

file too large to diff

+ GHC/Types/Fixity.hs view

file too large to diff

+ GHC/Types/Fixity/Env.hs view

file too large to diff

+ GHC/Types/ForeignCall.hs view

file too large to diff

+ GHC/Types/ForeignStubs.hs view

file too large to diff

+ GHC/Types/GREInfo.hs view

file too large to diff

+ GHC/Types/Hint.hs view

file too large to diff

+ GHC/Types/Hint/Ppr.hs view

file too large to diff

+ GHC/Types/HpcInfo.hs view

file too large to diff

+ GHC/Types/IPE.hs view

file too large to diff

+ GHC/Types/Id.hs view

file too large to diff

+ GHC/Types/Id.hs-boot view

file too large to diff

+ GHC/Types/Id/Info.hs view

file too large to diff

+ GHC/Types/Id/Info.hs-boot view

file too large to diff

+ GHC/Types/Id/Make.hs view

file too large to diff

+ GHC/Types/Id/Make.hs-boot view

file too large to diff

+ GHC/Types/Literal.hs view

file too large to diff

+ GHC/Types/Meta.hs view

file too large to diff

+ GHC/Types/Name.hs view

file too large to diff

+ GHC/Types/Name.hs-boot view

file too large to diff

+ GHC/Types/Name/Cache.hs view

file too large to diff

+ GHC/Types/Name/Env.hs view

file too large to diff

+ GHC/Types/Name/Occurrence.hs view

file too large to diff

+ GHC/Types/Name/Occurrence.hs-boot view

file too large to diff

+ GHC/Types/Name/Ppr.hs view

file too large to diff

+ GHC/Types/Name/Reader.hs view

file too large to diff

+ GHC/Types/Name/Set.hs view

file too large to diff

+ GHC/Types/Name/Shape.hs view

file too large to diff

+ GHC/Types/PkgQual.hs view

file too large to diff

+ GHC/Types/ProfAuto.hs view

file too large to diff

+ GHC/Types/RepType.hs view

file too large to diff

+ GHC/Types/SafeHaskell.hs view

file too large to diff

+ GHC/Types/SaneDouble.hs view

file too large to diff

+ GHC/Types/SourceError.hs view

file too large to diff

+ GHC/Types/SourceFile.hs view

file too large to diff

+ GHC/Types/SourceText.hs view

file too large to diff

+ GHC/Types/SptEntry.hs view

file too large to diff

+ GHC/Types/SrcLoc.hs view

file too large to diff

+ GHC/Types/Target.hs view

file too large to diff

+ GHC/Types/ThLevelIndex.hs view

file too large to diff

+ GHC/Types/Tickish.hs view

file too large to diff

+ GHC/Types/TyThing.hs view

file too large to diff

+ GHC/Types/TyThing.hs-boot view

file too large to diff

+ GHC/Types/TyThing/Ppr.hs view

file too large to diff

+ GHC/Types/TyThing/Ppr.hs-boot view

file too large to diff

+ GHC/Types/TypeEnv.hs view

file too large to diff

+ GHC/Types/Unique.hs view

file too large to diff

+ GHC/Types/Unique/DFM.hs view

file too large to diff

+ GHC/Types/Unique/DSM.hs view

file too large to diff

+ GHC/Types/Unique/DSet.hs view

file too large to diff

+ GHC/Types/Unique/FM.hs view

file too large to diff

+ GHC/Types/Unique/Map.hs view

file too large to diff

+ GHC/Types/Unique/MemoFun.hs view

file too large to diff

+ GHC/Types/Unique/SDFM.hs view

file too large to diff

+ GHC/Types/Unique/Set.hs view

file too large to diff

+ GHC/Types/Unique/Supply.hs view

file too large to diff

+ GHC/Types/Var.hs view

file too large to diff

+ GHC/Types/Var.hs-boot view

file too large to diff

+ GHC/Types/Var/Env.hs view

file too large to diff

+ GHC/Types/Var/Set.hs view

file too large to diff

+ GHC/Unit.hs view

file too large to diff

+ GHC/Unit/Env.hs view

file too large to diff

+ GHC/Unit/External.hs view

file too large to diff

+ GHC/Unit/Finder.hs view

file too large to diff

+ GHC/Unit/Finder/Types.hs view

file too large to diff

+ GHC/Unit/Home.hs view

file too large to diff

+ GHC/Unit/Home/Graph.hs view

file too large to diff

+ GHC/Unit/Home/ModInfo.hs view

file too large to diff

+ GHC/Unit/Home/PackageTable.hs view

file too large to diff

+ GHC/Unit/Info.hs view

file too large to diff

+ GHC/Unit/Module.hs view

file too large to diff

+ GHC/Unit/Module/Deps.hs view

file too large to diff

+ GHC/Unit/Module/Env.hs view

file too large to diff

+ GHC/Unit/Module/Graph.hs view

file too large to diff

+ GHC/Unit/Module/Imported.hs view

file too large to diff

+ GHC/Unit/Module/Location.hs view

file too large to diff

+ GHC/Unit/Module/ModDetails.hs view

file too large to diff

+ GHC/Unit/Module/ModGuts.hs view

file too large to diff

+ GHC/Unit/Module/ModIface.hs view

file too large to diff

+ GHC/Unit/Module/ModNodeKey.hs view

file too large to diff

+ GHC/Unit/Module/ModSummary.hs view

file too large to diff

+ GHC/Unit/Module/Stage.hs view

file too large to diff

+ GHC/Unit/Module/Status.hs view

file too large to diff

+ GHC/Unit/Module/Warnings.hs view

file too large to diff

+ GHC/Unit/Module/WholeCoreBindings.hs view

file too large to diff

+ GHC/Unit/Parser.hs view

file too large to diff

+ GHC/Unit/Ppr.hs view

file too large to diff

+ GHC/Unit/State.hs view

file too large to diff

+ GHC/Unit/Types.hs view

file too large to diff

+ GHC/Unit/Types.hs-boot view

file too large to diff

+ GHC/Utils/Asm.hs view

file too large to diff

+ GHC/Utils/Binary.hs view

file too large to diff

+ GHC/Utils/Binary/Typeable.hs view

file too large to diff

+ GHC/Utils/BufHandle.hs view

file too large to diff

+ GHC/Utils/CliOption.hs view

file too large to diff

+ GHC/Utils/Constants.hs view

file too large to diff

+ GHC/Utils/Containers/Internal/BitUtil.hs view

file too large to diff

+ GHC/Utils/Containers/Internal/StrictPair.hs view

file too large to diff

+ GHC/Utils/Error.hs view

file too large to diff

+ GHC/Utils/Exception.hs view

file too large to diff

+ GHC/Utils/FV.hs view

file too large to diff

+ GHC/Utils/Fingerprint.hs view

file too large to diff

+ GHC/Utils/GlobalVars.hs view

file too large to diff

+ GHC/Utils/IO/Unsafe.hs view

file too large to diff

+ GHC/Utils/Json.hs view

file too large to diff

+ GHC/Utils/Lexeme.hs view

file too large to diff

+ GHC/Utils/Logger.hs view

file too large to diff

+ GHC/Utils/Misc.hs view

file too large to diff

+ GHC/Utils/Monad.hs view

file too large to diff

+ GHC/Utils/Monad/Codensity.hs view

file too large to diff

+ GHC/Utils/Monad/State/Strict.hs view

file too large to diff

+ GHC/Utils/Outputable.hs view

file too large to diff

+ GHC/Utils/Panic.hs view

file too large to diff

+ GHC/Utils/Panic/Plain.hs view

file too large to diff

+ GHC/Utils/Ppr.hs view

file too large to diff

+ GHC/Utils/Ppr/Colour.hs view

file too large to diff

+ GHC/Utils/TmpFs.hs view

file too large to diff

+ GHC/Utils/Touch.hs view

file too large to diff

+ GHC/Utils/Trace.hs view

file too large to diff

+ GHC/Utils/Unique.hs view

file too large to diff

+ GHC/Utils/Word64.hs view

file too large to diff

+ GHC/Wasm/ControlFlow.hs view

file too large to diff

+ GHC/Wasm/ControlFlow/FromCmm.hs view

file too large to diff

− HsVersions.h

file too large to diff

+ Language/Haskell/Syntax.hs view

file too large to diff

+ Language/Haskell/Syntax/Basic.hs view

file too large to diff

+ Language/Haskell/Syntax/Binds.hs view

file too large to diff

+ Language/Haskell/Syntax/BooleanFormula.hs view

file too large to diff

+ Language/Haskell/Syntax/Decls.hs view

file too large to diff

+ Language/Haskell/Syntax/Expr.hs view

file too large to diff

+ Language/Haskell/Syntax/Expr.hs-boot view

file too large to diff

+ Language/Haskell/Syntax/Extension.hs view

file too large to diff

+ Language/Haskell/Syntax/ImpExp.hs view

file too large to diff

+ Language/Haskell/Syntax/ImpExp/IsBoot.hs view

file too large to diff

+ Language/Haskell/Syntax/Lit.hs view

file too large to diff

+ Language/Haskell/Syntax/Module/Name.hs view

file too large to diff

+ Language/Haskell/Syntax/Pat.hs view

file too large to diff

+ Language/Haskell/Syntax/Pat.hs-boot view

file too large to diff

+ Language/Haskell/Syntax/Specificity.hs view

file too large to diff

+ Language/Haskell/Syntax/Type.hs view

file too large to diff

+ Language/Haskell/Syntax/Type.hs-boot view

file too large to diff

+ MachRegs.h view

file too large to diff

+ MachRegs/arm32.h view

file too large to diff

+ MachRegs/arm64.h view

file too large to diff

+ MachRegs/loongarch64.h view

file too large to diff

+ MachRegs/ppc.h view

file too large to diff

+ MachRegs/riscv64.h view

file too large to diff

+ MachRegs/s390x.h view

file too large to diff

+ MachRegs/wasm32.h view

file too large to diff

+ MachRegs/x86.h view

file too large to diff

+ Setup.hs view

file too large to diff

+ Unique.h view

file too large to diff

− backpack/BkpSyn.hs

file too large to diff

− backpack/DriverBkp.hs

file too large to diff

− backpack/NameShape.hs

file too large to diff

− backpack/RnModIface.hs

file too large to diff

− basicTypes/Avail.hs

file too large to diff

− basicTypes/BasicTypes.hs

file too large to diff

− basicTypes/ConLike.hs

file too large to diff

− basicTypes/ConLike.hs-boot

file too large to diff

− basicTypes/DataCon.hs

file too large to diff

− basicTypes/DataCon.hs-boot

file too large to diff

− basicTypes/Demand.hs

file too large to diff

− basicTypes/FieldLabel.hs

file too large to diff

− basicTypes/Id.hs

file too large to diff

− basicTypes/IdInfo.hs

file too large to diff

− basicTypes/IdInfo.hs-boot

file too large to diff

− basicTypes/Lexeme.hs

file too large to diff

− basicTypes/Literal.hs

file too large to diff

− basicTypes/MkId.hs

file too large to diff

− basicTypes/MkId.hs-boot

file too large to diff

− basicTypes/Module.hs

file too large to diff

− basicTypes/Module.hs-boot

file too large to diff

− basicTypes/Name.hs

file too large to diff

− basicTypes/Name.hs-boot

file too large to diff

− basicTypes/NameCache.hs

file too large to diff

− basicTypes/NameEnv.hs

file too large to diff

− basicTypes/NameSet.hs

file too large to diff

− basicTypes/OccName.hs

file too large to diff

− basicTypes/OccName.hs-boot

file too large to diff

− basicTypes/PatSyn.hs

file too large to diff

− basicTypes/PatSyn.hs-boot

file too large to diff

− basicTypes/Predicate.hs

file too large to diff

− basicTypes/RdrName.hs

file too large to diff

− basicTypes/SrcLoc.hs

file too large to diff

− basicTypes/UniqSupply.hs

file too large to diff

− basicTypes/Unique.hs

file too large to diff

− basicTypes/Var.hs

file too large to diff

− basicTypes/Var.hs-boot

file too large to diff

− basicTypes/VarEnv.hs

file too large to diff

− basicTypes/VarSet.hs

file too large to diff

+ cbits/cutils.c view

file too large to diff

cbits/genSym.c view

file too large to diff

+ cbits/keepCAFsForGHCi.c view

file too large to diff

− cmm/Bitmap.hs

file too large to diff

− cmm/BlockId.hs

file too large to diff

− cmm/BlockId.hs-boot

file too large to diff

− cmm/CLabel.hs

file too large to diff

− cmm/Cmm.hs

file too large to diff

− cmm/CmmBuildInfoTables.hs

file too large to diff

− cmm/CmmCallConv.hs

file too large to diff

− cmm/CmmCommonBlockElim.hs

file too large to diff

− cmm/CmmContFlowOpt.hs

file too large to diff

− cmm/CmmExpr.hs

file too large to diff

− cmm/CmmImplementSwitchPlans.hs

file too large to diff

− cmm/CmmInfo.hs

file too large to diff

− cmm/CmmLayoutStack.hs

file too large to diff

− cmm/CmmLex.x

file too large to diff

− cmm/CmmLint.hs

file too large to diff

− cmm/CmmLive.hs

file too large to diff

− cmm/CmmMachOp.hs

file too large to diff

− cmm/CmmMonad.hs

file too large to diff

− cmm/CmmNode.hs

file too large to diff

− cmm/CmmOpt.hs

file too large to diff

− cmm/CmmParse.y

file too large to diff

− cmm/CmmPipeline.hs

file too large to diff

− cmm/CmmProcPoint.hs

file too large to diff

− cmm/CmmSink.hs

file too large to diff

− cmm/CmmSwitch.hs

file too large to diff

− cmm/CmmType.hs

file too large to diff

− cmm/CmmUtils.hs

file too large to diff

− cmm/Debug.hs

file too large to diff

− cmm/Hoopl/Block.hs

file too large to diff

− cmm/Hoopl/Collections.hs

file too large to diff

− cmm/Hoopl/Dataflow.hs

file too large to diff

− cmm/Hoopl/Graph.hs

file too large to diff

− cmm/Hoopl/Label.hs

file too large to diff

− cmm/MkGraph.hs

file too large to diff

− cmm/PprC.hs

file too large to diff

− cmm/PprCmm.hs

file too large to diff

− cmm/PprCmmDecl.hs

file too large to diff

− cmm/PprCmmExpr.hs

file too large to diff

− cmm/SMRep.hs

file too large to diff

− coreSyn/CoreArity.hs

file too large to diff

− coreSyn/CoreFVs.hs

file too large to diff

− coreSyn/CoreLint.hs

file too large to diff

− coreSyn/CoreMap.hs

file too large to diff

− coreSyn/CoreOpt.hs

file too large to diff

− coreSyn/CorePrep.hs

file too large to diff

− coreSyn/CoreSeq.hs

file too large to diff

− coreSyn/CoreStats.hs

file too large to diff

− coreSyn/CoreSubst.hs

file too large to diff

− coreSyn/CoreSyn.hs

file too large to diff

− coreSyn/CoreTidy.hs

file too large to diff

− coreSyn/CoreUnfold.hs

file too large to diff

− coreSyn/CoreUnfold.hs-boot

file too large to diff

− coreSyn/CoreUtils.hs

file too large to diff

− coreSyn/MkCore.hs

file too large to diff

− coreSyn/PprCore.hs

file too large to diff

− deSugar/Coverage.hs

file too large to diff

− deSugar/Desugar.hs

file too large to diff

− deSugar/DsArrows.hs

file too large to diff

− deSugar/DsBinds.hs

file too large to diff

− deSugar/DsBinds.hs-boot

file too large to diff

− deSugar/DsCCall.hs

file too large to diff

− deSugar/DsExpr.hs

file too large to diff

− deSugar/DsExpr.hs-boot

file too large to diff

− deSugar/DsForeign.hs

file too large to diff

− deSugar/DsGRHSs.hs

file too large to diff

− deSugar/DsListComp.hs

file too large to diff

− deSugar/DsMeta.hs

file too large to diff

− deSugar/DsMonad.hs

file too large to diff

− deSugar/DsUsage.hs

file too large to diff

− deSugar/DsUtils.hs

file too large to diff

− deSugar/ExtractDocs.hs

file too large to diff

− deSugar/Match.hs

file too large to diff

− deSugar/Match.hs-boot

file too large to diff

− deSugar/MatchCon.hs

file too large to diff

− deSugar/MatchLit.hs

file too large to diff

ghc.cabal view

file too large to diff

− ghci/ByteCodeAsm.hs

file too large to diff

− ghci/ByteCodeGen.hs

file too large to diff

− ghci/ByteCodeInstr.hs

file too large to diff

− ghci/ByteCodeItbls.hs

file too large to diff

− ghci/ByteCodeLink.hs

file too large to diff

− ghci/ByteCodeTypes.hs

file too large to diff

− ghci/Debugger.hs

file too large to diff

− ghci/GHCi.hs

file too large to diff

− ghci/Linker.hs

file too large to diff

− ghci/LinkerTypes.hs

file too large to diff

− ghci/RtClosureInspect.hs

file too large to diff

− ghci/keepCAFsForGHCi.c

file too large to diff

− hieFile/HieAst.hs

file too large to diff

− hieFile/HieBin.hs

file too large to diff

− hieFile/HieDebug.hs

file too large to diff

− hieFile/HieTypes.hs

file too large to diff

− hieFile/HieUtils.hs

file too large to diff

− iface/BinFingerprint.hs

file too large to diff

− iface/BinIface.hs

file too large to diff

− iface/BuildTyCl.hs

file too large to diff

− iface/FlagChecker.hs

file too large to diff

− iface/IfaceEnv.hs

file too large to diff

− iface/IfaceEnv.hs-boot

file too large to diff

− iface/IfaceSyn.hs

file too large to diff

− iface/IfaceType.hs

file too large to diff

− iface/IfaceType.hs-boot

file too large to diff

− iface/LoadIface.hs

file too large to diff

− iface/LoadIface.hs-boot

file too large to diff

− iface/MkIface.hs

file too large to diff

− iface/TcIface.hs

file too large to diff

− iface/TcIface.hs-boot

file too large to diff

− iface/ToIface.hs

file too large to diff

− iface/ToIface.hs-boot

file too large to diff

+ jsbits/genSym.js view

file too large to diff

− llvmGen/Llvm.hs

file too large to diff

− llvmGen/Llvm/AbsSyn.hs

file too large to diff

− llvmGen/Llvm/MetaData.hs

file too large to diff

− llvmGen/Llvm/PpLlvm.hs

file too large to diff

− llvmGen/Llvm/Types.hs

file too large to diff

− llvmGen/LlvmCodeGen.hs

file too large to diff

− llvmGen/LlvmCodeGen/Base.hs

file too large to diff

− llvmGen/LlvmCodeGen/CodeGen.hs

file too large to diff

− llvmGen/LlvmCodeGen/Data.hs

file too large to diff

− llvmGen/LlvmCodeGen/Ppr.hs

file too large to diff

− llvmGen/LlvmCodeGen/Regs.hs

file too large to diff

− llvmGen/LlvmMangler.hs

file too large to diff

− main/Annotations.hs

file too large to diff

− main/Ar.hs

file too large to diff

− main/CliOption.hs

file too large to diff

− main/CmdLineParser.hs

file too large to diff

− main/CodeOutput.hs

file too large to diff

− main/Constants.hs

file too large to diff

− main/DriverMkDepend.hs

file too large to diff

− main/DriverPhases.hs

file too large to diff

− main/DriverPipeline.hs

file too large to diff

− main/DynFlags.hs

file too large to diff

− main/DynFlags.hs-boot

file too large to diff

− main/DynamicLoading.hs

file too large to diff

− main/Elf.hs

file too large to diff

− main/ErrUtils.hs

file too large to diff

− main/ErrUtils.hs-boot

file too large to diff

− main/FileCleanup.hs

file too large to diff

− main/FileSettings.hs

file too large to diff

− main/Finder.hs

file too large to diff

− main/GHC.hs

file too large to diff

− main/GhcMake.hs

file too large to diff

− main/GhcMonad.hs

file too large to diff

− main/GhcNameVersion.hs

file too large to diff

− main/GhcPlugins.hs

file too large to diff

− main/HeaderInfo.hs

file too large to diff

− main/Hooks.hs

file too large to diff

− main/Hooks.hs-boot

file too large to diff

− main/HscMain.hs

file too large to diff

− main/HscStats.hs

file too large to diff

− main/HscTypes.hs

file too large to diff

− main/InteractiveEval.hs

file too large to diff

− main/InteractiveEvalTypes.hs

file too large to diff

− main/PackageConfig.hs

file too large to diff

− main/PackageConfig.hs-boot

file too large to diff

− main/Packages.hs

file too large to diff

− main/Packages.hs-boot

file too large to diff

− main/PipelineMonad.hs

file too large to diff

− main/PlatformConstants.hs

file too large to diff

− main/Plugins.hs

file too large to diff

− main/Plugins.hs-boot

file too large to diff

− main/PprTyThing.hs

file too large to diff

− main/Settings.hs

file too large to diff

− main/StaticPtrTable.hs

file too large to diff

− main/SysTools.hs

file too large to diff

− main/SysTools/BaseDir.hs

file too large to diff

− main/SysTools/ExtraObj.hs

file too large to diff

− main/SysTools/Info.hs

file too large to diff

− main/SysTools/Process.hs

file too large to diff

− main/SysTools/Settings.hs

file too large to diff

− main/SysTools/Tasks.hs

file too large to diff

− main/SysTools/Terminal.hs

file too large to diff

− main/TidyPgm.hs

file too large to diff

− main/ToolSettings.hs

file too large to diff

− nativeGen/AsmCodeGen.hs

file too large to diff

− nativeGen/BlockLayout.hs

file too large to diff

− nativeGen/CFG.hs

file too large to diff

− nativeGen/CPrim.hs

file too large to diff

− nativeGen/Dwarf.hs

file too large to diff

− nativeGen/Dwarf/Constants.hs

file too large to diff

− nativeGen/Dwarf/Types.hs

file too large to diff

− nativeGen/Format.hs

file too large to diff

− nativeGen/Instruction.hs

file too large to diff

− nativeGen/NCGMonad.hs

file too large to diff

− nativeGen/PIC.hs

file too large to diff

− nativeGen/PPC/CodeGen.hs

file too large to diff

− nativeGen/PPC/Cond.hs

file too large to diff

− nativeGen/PPC/Instr.hs

file too large to diff

− nativeGen/PPC/Ppr.hs

file too large to diff

− nativeGen/PPC/RegInfo.hs

file too large to diff

− nativeGen/PPC/Regs.hs

file too large to diff

− nativeGen/PprBase.hs

file too large to diff

− nativeGen/Reg.hs

file too large to diff

− nativeGen/RegAlloc/Graph/ArchBase.hs

file too large to diff

− nativeGen/RegAlloc/Graph/ArchX86.hs

file too large to diff

− nativeGen/RegAlloc/Graph/Coalesce.hs

file too large to diff

− nativeGen/RegAlloc/Graph/Main.hs

file too large to diff

− nativeGen/RegAlloc/Graph/Spill.hs

file too large to diff

− nativeGen/RegAlloc/Graph/SpillClean.hs

file too large to diff

− nativeGen/RegAlloc/Graph/SpillCost.hs

file too large to diff

− nativeGen/RegAlloc/Graph/Stats.hs

file too large to diff

− nativeGen/RegAlloc/Graph/TrivColorable.hs

file too large to diff

− nativeGen/RegAlloc/Linear/Base.hs

file too large to diff

− nativeGen/RegAlloc/Linear/FreeRegs.hs

file too large to diff

− nativeGen/RegAlloc/Linear/JoinToTargets.hs

file too large to diff

− nativeGen/RegAlloc/Linear/Main.hs

file too large to diff

− nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs

file too large to diff

− nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs

file too large to diff

− nativeGen/RegAlloc/Linear/StackMap.hs

file too large to diff

− nativeGen/RegAlloc/Linear/State.hs

file too large to diff

− nativeGen/RegAlloc/Linear/Stats.hs

file too large to diff

− nativeGen/RegAlloc/Linear/X86/FreeRegs.hs

file too large to diff

− nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs

file too large to diff

− nativeGen/RegAlloc/Liveness.hs

file too large to diff

− nativeGen/RegClass.hs

file too large to diff

− nativeGen/SPARC/AddrMode.hs

file too large to diff

− nativeGen/SPARC/Base.hs

file too large to diff

− nativeGen/SPARC/CodeGen.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Amode.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Base.hs

file too large to diff

− nativeGen/SPARC/CodeGen/CondCode.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Expand.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Gen32.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Gen32.hs-boot

file too large to diff

− nativeGen/SPARC/CodeGen/Gen64.hs

file too large to diff

− nativeGen/SPARC/CodeGen/Sanity.hs

file too large to diff

− nativeGen/SPARC/Cond.hs

file too large to diff

− nativeGen/SPARC/Imm.hs

file too large to diff

− nativeGen/SPARC/Instr.hs

file too large to diff

− nativeGen/SPARC/Ppr.hs

file too large to diff

− nativeGen/SPARC/Regs.hs

file too large to diff

− nativeGen/SPARC/ShortcutJump.hs

file too large to diff

− nativeGen/SPARC/Stack.hs

file too large to diff

− nativeGen/TargetReg.hs

file too large to diff

− nativeGen/X86/CodeGen.hs

file too large to diff

− nativeGen/X86/Cond.hs

file too large to diff

− nativeGen/X86/Instr.hs

file too large to diff

− nativeGen/X86/Ppr.hs

file too large to diff

− nativeGen/X86/RegInfo.hs

file too large to diff

− nativeGen/X86/Regs.hs

file too large to diff

− parser/ApiAnnotation.hs

file too large to diff

− parser/Ctype.hs

file too large to diff

− parser/HaddockUtils.hs

file too large to diff

− parser/Lexer.x

file too large to diff

− parser/Parser.y

file too large to diff

− parser/RdrHsSyn.hs

file too large to diff

− parser/cutils.c

file too large to diff

− prelude/ForeignCall.hs

file too large to diff

− prelude/KnownUniques.hs

file too large to diff

− prelude/KnownUniques.hs-boot

file too large to diff

− prelude/PrelInfo.hs

file too large to diff

− prelude/PrelNames.hs

file too large to diff

− prelude/PrelNames.hs-boot

file too large to diff

− prelude/PrelRules.hs

file too large to diff

− prelude/PrimOp.hs

file too large to diff

− prelude/PrimOp.hs-boot

file too large to diff

− prelude/THNames.hs

file too large to diff

− prelude/TysPrim.hs

file too large to diff

− prelude/TysWiredIn.hs

file too large to diff

− prelude/TysWiredIn.hs-boot

file too large to diff

− profiling/CostCentre.hs

file too large to diff

− profiling/CostCentreState.hs

file too large to diff

− profiling/ProfInit.hs

file too large to diff

− rename/RnBinds.hs

file too large to diff

− rename/RnEnv.hs

file too large to diff

− rename/RnExpr.hs

file too large to diff

− rename/RnExpr.hs-boot

file too large to diff

− rename/RnFixity.hs

file too large to diff

− rename/RnHsDoc.hs

file too large to diff

− rename/RnNames.hs

file too large to diff

− rename/RnPat.hs

file too large to diff

− rename/RnSource.hs

file too large to diff

− rename/RnSplice.hs

file too large to diff

− rename/RnSplice.hs-boot

file too large to diff

− rename/RnTypes.hs

file too large to diff

− rename/RnUnbound.hs

file too large to diff

− rename/RnUtils.hs

file too large to diff

− simplCore/CSE.hs

file too large to diff

− simplCore/CallArity.hs

file too large to diff

− simplCore/CoreMonad.hs

file too large to diff

− simplCore/CoreMonad.hs-boot

file too large to diff

− simplCore/Exitify.hs

file too large to diff

− simplCore/FloatIn.hs

file too large to diff

− simplCore/FloatOut.hs

file too large to diff

− simplCore/LiberateCase.hs

file too large to diff

− simplCore/OccurAnal.hs

file too large to diff

− simplCore/SAT.hs

file too large to diff

− simplCore/SetLevels.hs

file too large to diff

− simplCore/SimplCore.hs

file too large to diff

− simplCore/SimplEnv.hs

file too large to diff

− simplCore/SimplMonad.hs

file too large to diff

− simplCore/SimplUtils.hs

file too large to diff

− simplCore/Simplify.hs

file too large to diff

− simplStg/RepType.hs

file too large to diff

− simplStg/SimplStg.hs

file too large to diff

− simplStg/StgCse.hs

file too large to diff

− simplStg/StgLiftLams.hs

file too large to diff

− simplStg/StgLiftLams/Analysis.hs

file too large to diff

− simplStg/StgLiftLams/LiftM.hs

file too large to diff

− simplStg/StgLiftLams/Transformation.hs

file too large to diff

− simplStg/StgStats.hs

file too large to diff

− simplStg/UnariseStg.hs

file too large to diff

− specialise/Rules.hs

file too large to diff

− specialise/SpecConstr.hs

file too large to diff

− specialise/Specialise.hs

file too large to diff

− stgSyn/CoreToStg.hs

file too large to diff

− stgSyn/StgFVs.hs

file too large to diff

− stgSyn/StgLint.hs

file too large to diff

− stgSyn/StgSubst.hs

file too large to diff

− stgSyn/StgSyn.hs

file too large to diff

− stranal/DmdAnal.hs

file too large to diff

− stranal/WorkWrap.hs

file too large to diff

− stranal/WwLib.hs

file too large to diff

− typecheck/ClsInst.hs

file too large to diff

− typecheck/Constraint.hs

file too large to diff

− typecheck/FamInst.hs

file too large to diff

− typecheck/FunDeps.hs

file too large to diff

− typecheck/Inst.hs

file too large to diff

− typecheck/TcAnnotations.hs

file too large to diff

− typecheck/TcArrows.hs

file too large to diff

− typecheck/TcBackpack.hs

file too large to diff

− typecheck/TcBinds.hs

file too large to diff

− typecheck/TcCanonical.hs

file too large to diff

− typecheck/TcClassDcl.hs

file too large to diff

− typecheck/TcDefaults.hs

file too large to diff

− typecheck/TcDeriv.hs

file too large to diff

− typecheck/TcDerivInfer.hs

file too large to diff

− typecheck/TcDerivUtils.hs

file too large to diff

− typecheck/TcEnv.hs

file too large to diff

− typecheck/TcEnv.hs-boot

file too large to diff

− typecheck/TcErrors.hs

file too large to diff

− typecheck/TcEvTerm.hs

file too large to diff

− typecheck/TcEvidence.hs

file too large to diff

− typecheck/TcExpr.hs

file too large to diff

− typecheck/TcExpr.hs-boot

file too large to diff

− typecheck/TcFlatten.hs

file too large to diff

− typecheck/TcForeign.hs

file too large to diff

− typecheck/TcGenDeriv.hs

file too large to diff

− typecheck/TcGenFunctor.hs

file too large to diff

− typecheck/TcGenGenerics.hs

file too large to diff

− typecheck/TcHoleErrors.hs

file too large to diff

− typecheck/TcHoleErrors.hs-boot

file too large to diff

− typecheck/TcHoleFitTypes.hs

file too large to diff

− typecheck/TcHoleFitTypes.hs-boot

file too large to diff

− typecheck/TcHsSyn.hs

file too large to diff

− typecheck/TcHsType.hs

file too large to diff

− typecheck/TcInstDcls.hs

file too large to diff

− typecheck/TcInstDcls.hs-boot

file too large to diff

− typecheck/TcInteract.hs

file too large to diff

− typecheck/TcMType.hs

file too large to diff

− typecheck/TcMatches.hs

file too large to diff

− typecheck/TcMatches.hs-boot

file too large to diff

− typecheck/TcOrigin.hs

file too large to diff

− typecheck/TcPat.hs

file too large to diff

− typecheck/TcPatSyn.hs

file too large to diff

− typecheck/TcPatSyn.hs-boot

file too large to diff

− typecheck/TcPluginM.hs

file too large to diff

− typecheck/TcRnDriver.hs

file too large to diff

− typecheck/TcRnDriver.hs-boot

file too large to diff

− typecheck/TcRnExports.hs

file too large to diff

− typecheck/TcRnMonad.hs

file too large to diff

− typecheck/TcRnTypes.hs

file too large to diff

− typecheck/TcRnTypes.hs-boot

file too large to diff

− typecheck/TcRules.hs

file too large to diff

− typecheck/TcSMonad.hs

file too large to diff

− typecheck/TcSigs.hs

file too large to diff

− typecheck/TcSimplify.hs

file too large to diff

− typecheck/TcSplice.hs

file too large to diff

− typecheck/TcSplice.hs-boot

file too large to diff

− typecheck/TcTyClsDecls.hs

file too large to diff

− typecheck/TcTyDecls.hs

file too large to diff

− typecheck/TcType.hs

file too large to diff

− typecheck/TcType.hs-boot

file too large to diff

− typecheck/TcTypeNats.hs

file too large to diff

− typecheck/TcTypeable.hs

file too large to diff

− typecheck/TcUnify.hs

file too large to diff

− typecheck/TcUnify.hs-boot

file too large to diff

− typecheck/TcValidity.hs

file too large to diff

− types/Class.hs

file too large to diff

− types/CoAxiom.hs

file too large to diff

− types/Coercion.hs

file too large to diff

− types/Coercion.hs-boot

file too large to diff

− types/FamInstEnv.hs

file too large to diff

− types/InstEnv.hs

file too large to diff

− types/OptCoercion.hs

file too large to diff

− types/TyCoFVs.hs

file too large to diff

− types/TyCoPpr.hs

file too large to diff

− types/TyCoPpr.hs-boot

file too large to diff

− types/TyCoRep.hs

file too large to diff

− types/TyCoRep.hs-boot

file too large to diff

− types/TyCoSubst.hs

file too large to diff

− types/TyCoTidy.hs

file too large to diff

− types/TyCon.hs

file too large to diff

− types/TyCon.hs-boot

file too large to diff

− types/Type.hs

file too large to diff

− types/Type.hs-boot

file too large to diff

− types/Unify.hs

file too large to diff

− utils/AsmUtils.hs

file too large to diff

− utils/Bag.hs

file too large to diff

− utils/Binary.hs

file too large to diff

− utils/BooleanFormula.hs

file too large to diff

− utils/BufWrite.hs

file too large to diff

− utils/Digraph.hs

file too large to diff

− utils/Dominators.hs

file too large to diff

− utils/Encoding.hs

file too large to diff

− utils/EnumSet.hs

file too large to diff

− utils/Exception.hs

file too large to diff

− utils/FV.hs

file too large to diff

− utils/FastFunctions.hs

file too large to diff

− utils/FastMutInt.hs

file too large to diff

− utils/FastString.hs

file too large to diff

− utils/FastStringEnv.hs

file too large to diff

− utils/Fingerprint.hs

file too large to diff

− utils/FiniteMap.hs

file too large to diff

− utils/GhcPrelude.hs

file too large to diff

− utils/GraphBase.hs

file too large to diff

− utils/GraphColor.hs

file too large to diff

− utils/GraphOps.hs

file too large to diff

− utils/GraphPpr.hs

file too large to diff

− utils/IOEnv.hs

file too large to diff

− utils/Json.hs

file too large to diff

− utils/ListSetOps.hs

file too large to diff

− utils/Maybes.hs

file too large to diff

− utils/MonadUtils.hs

file too large to diff

− utils/OrdList.hs

file too large to diff

− utils/Outputable.hs

file too large to diff

− utils/Outputable.hs-boot

file too large to diff

− utils/Pair.hs

file too large to diff

− utils/Panic.hs

file too large to diff

− utils/PlainPanic.hs

file too large to diff

− utils/PprColour.hs

file too large to diff

− utils/Pretty.hs

file too large to diff

− utils/State.hs

file too large to diff

− utils/Stream.hs

file too large to diff

− utils/StringBuffer.hs

file too large to diff

− utils/TrieMap.hs

file too large to diff

− utils/UnVarGraph.hs

file too large to diff

− utils/UniqDFM.hs

file too large to diff

− utils/UniqDSet.hs

file too large to diff

− utils/UniqFM.hs

file too large to diff

− utils/UniqMap.hs

file too large to diff

− utils/UniqSet.hs

file too large to diff

− utils/Util.hs

file too large to diff